X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=603d2dd1c6d772865e26c70aa22996dd567fc60d;hb=3c36d064aa4b141f6a17574253d97363967a8fe8;hp=636f170aae3ae908b45fcabc14cebe1d500d2cab;hpb=19108ede05d6528d0b66edb2bcf031e8da9522e2;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 636f170..603d2dd 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,14 +12,14 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreUtils +import CoreUtils ( rhsIsStatic, manifestArity, exprType ) import StgSyn import Type import TyCon ( isAlgTyCon ) -import Literal import Id import Var ( Var, globalIdDetails, varType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) #endif @@ -174,14 +174,13 @@ coreTopBindToStg env body_fvs (NonRec id rhs) env' = extendVarEnv env id how_bound how_bound = LetBound TopLet (manifestArity rhs) - (stg_rhs, fvs', lv_info) = + (stg_rhs, fvs') = initLne env ( coreToTopStgRhs body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> - returnLne (stg_rhs, fvs', lv_info) + returnLne (stg_rhs, fvs') ) - bind = StgNonRec (mkSRT lv_info) id stg_rhs + bind = StgNonRec id stg_rhs in ASSERT2(manifestArity rhs == stgRhsArity stg_rhs, ppr id) ASSERT2(consistentCafInfo id bind, ppr id) @@ -196,20 +195,18 @@ coreTopBindToStg env body_fvs (Rec pairs) | (b, rhs) <- pairs ] env' = extendVarEnvList env extra_env' - (stg_rhss, fvs', lv_info) + (stg_rhss, fvs') = initLne env' ( mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs `thenLne` \ (stg_rhss, fvss') -> let fvs' = unionFVInfos fvss' in - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> - returnLne (stg_rhss, fvs', lv_info) + returnLne (stg_rhss, fvs') ) - bind = StgRec (mkSRT lv_info) (zip binders stg_rhss) + bind = StgRec (zip binders stg_rhss) in ASSERT2(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) ASSERT2(consistentCafInfo (head binders) bind, ppr binders) --- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) #ifdef DEBUG @@ -219,10 +216,12 @@ coreTopBindToStg env body_fvs (Rec pairs) -- floated out a binding, in which case it will be approximate. consistentCafInfo id bind | occNameFS (nameOccName (idName id)) == FSLIT("sat") - = id_marked_caffy || not binding_is_caffy + = safe | otherwise - = id_marked_caffy == binding_is_caffy + = WARN (not exact, ppr id) safe where + safe = id_marked_caffy || not binding_is_caffy + exact = id_marked_caffy == binding_is_caffy id_marked_caffy = mayHaveCafRefs (idCafInfo id) binding_is_caffy = stgBindHasCafRefs bind #endif @@ -236,29 +235,33 @@ coreToTopStgRhs coreToTopStgRhs scope_fv_info (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, _) -> - returnLne (mkTopStgRhs upd rhs_fvs bndr_info new_rhs, rhs_fvs) + freeVarsToLiveVars rhs_fvs `thenLne` \ lv_info -> + returnLne (mkTopStgRhs is_static rhs_fvs (mkSRT lv_info) bndr_info new_rhs, rhs_fvs) where bndr_info = lookupFVInfo scope_fv_info bndr + is_static = rhsIsStatic rhs - upd | rhsIsNonUpd rhs = SingleEntry - | otherwise = Updatable +mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs -mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs - -mkTopStgRhs upd rhs_fvs binder_info (StgLam _ bndrs body) - = StgRhsClosure noCCS binder_info +mkTopStgRhs is_static rhs_fvs srt binder_info (StgLam _ bndrs body) + = ASSERT( is_static ) + StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant + srt bndrs body -mkTopStgRhs upd rhs_fvs binder_info (StgConApp con args) - | not (isUpdatable upd) -- StgConApps can be updatable (see isCrossDllConApp) +mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) + | is_static -- StgConApps can be updatable (see isCrossDllConApp) = StgRhsCon noCCS con args -mkTopStgRhs upd rhs_fvs binder_info rhs - = StgRhsClosure noCCS binder_info +mkTopStgRhs is_static rhs_fvs srt binder_info rhs + = ASSERT( not is_static ) + StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - upd + Updatable + srt [] rhs \end{code} @@ -330,7 +333,7 @@ coreToStgExpr (Note other_note expr) coreToStgExpr (Case scrut bndr alts) = extendVarEnvLne [(bndr, LambdaBound)] ( mapAndUnzip3Lne vars_alt alts `thenLne` \ (alts2, fvs_s, escs_s) -> - returnLne ( mkStgAlts (idType bndr) alts2, + returnLne ( alts2, unionFVInfos fvs_s, unionVarSets escs_s ) ) `thenLne` \ (alts2, alts_fvs, alts_escs) -> @@ -364,6 +367,7 @@ coreToStgExpr (Case scrut bndr alts) (getLiveVars alts_lv_info) bndr' (mkSRT alts_lv_info) + (mkStgAltType (idType bndr)) alts2, scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs @@ -403,28 +407,14 @@ coreToStgExpr (Let bind body) \end{code} \begin{code} -mkStgAlts scrut_ty orig_alts - | is_prim_case = StgPrimAlts (tyConAppTyCon scrut_ty) prim_alts deflt - | otherwise = StgAlgAlts maybe_tycon alg_alts deflt - where - is_prim_case = isUnLiftedType scrut_ty && not (isUnboxedTupleType scrut_ty) - - prim_alts = [(lit, rhs) | (LitAlt lit, _, _, rhs) <- other_alts] - alg_alts = [(con, bndrs, use, rhs) | (DataAlt con, bndrs, use, rhs) <- other_alts] - - (other_alts, deflt) - = case orig_alts of -- DEFAULT is always first if it's there at all - (DEFAULT, _, _, rhs) : other_alts -> (other_alts, StgBindDefault rhs) - other -> (orig_alts, StgNoDefault) - - maybe_tycon = case alg_alts of - -- Get the tycon from the data con - (dc, _, _, _) : _rest -> Just (dataConTyCon dc) - - -- Otherwise just do your best - [] -> case splitTyConApp_maybe (repType scrut_ty) of - Just (tc,_) | isAlgTyCon tc -> Just tc - _other -> Nothing +mkStgAltType scrut_ty + = case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc + | isPrimTyCon tc -> PrimAlt tc + | isAlgTyCon tc -> AlgAlt tc + | isFunTyCon tc -> PolyAlt + | otherwise -> pprPanic "mkStgAlts" (ppr tc) + Nothing -> PolyAlt \end{code} @@ -646,14 +636,12 @@ coreToStgLet let_no_escape bind body vars_bind body_fvs (NonRec binder rhs) - = coreToStgRhs body_fvs (binder,rhs) - `thenLne` \ (rhs2, bind_fvs, escs) -> - - freeVarsToLiveVars bind_fvs `thenLne` \ bind_lv_info -> + = coreToStgRhs body_fvs [] (binder,rhs) + `thenLne` \ (rhs2, bind_fvs, bind_lv_info, escs) -> let env_ext_item = mk_binding bind_lv_info binder rhs in - returnLne (StgNonRec (mkSRT bind_lv_info) binder rhs2, + returnLne (StgNonRec binder rhs2, bind_fvs, escs, bind_lv_info, [env_ext_item]) @@ -666,16 +654,14 @@ coreToStgLet let_no_escape bind body | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( - mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs) pairs - `thenLne` \ (rhss2, fvss, escss) -> + mapAndUnzip4Lne (coreToStgRhs rec_scope_fvs binders) pairs + `thenLne` \ (rhss2, fvss, lv_infos, escss) -> let bind_fvs = unionFVInfos fvss + bind_lv_info = foldr unionLiveInfo emptyLiveInfo lv_infos escs = unionVarSets escss in - freeVarsToLiveVars (binders `minusFVBinders` bind_fvs) - `thenLne` \ bind_lv_info -> - - returnLne (StgRec (mkSRT bind_lv_info) (binders `zip` rhss2), + returnLne (StgRec (binders `zip` rhss2), bind_fvs, escs, bind_lv_info, env_ext) ) ) @@ -688,32 +674,34 @@ is_join_var j = occNameUserString (getOccName j) == "$j" \begin{code} coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> [Id] -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) -coreToStgRhs scope_fv_info (bndr, rhs) +coreToStgRhs scope_fv_info binders (bndr, rhs) = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> getEnvLne `thenLne` \ env -> - returnLne (mkStgRhs env rhs_fvs bndr_info new_rhs, - rhs_fvs, rhs_escs) + freeVarsToLiveVars (binders `minusFVBinders` rhs_fvs) `thenLne` \ lv_info -> + returnLne (mkStgRhs rhs_fvs (mkSRT lv_info) bndr_info new_rhs, + rhs_fvs, lv_info, rhs_escs) where bndr_info = lookupFVInfo scope_fv_info bndr -mkStgRhs :: IdEnv HowBound -> FreeVarsInfo -> StgBinderInfo -> StgExpr -> StgRhs +mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -mkStgRhs env rhs_fvs binder_info (StgConApp con args) +mkStgRhs rhs_fvs srt binder_info (StgConApp con args) = StgRhsCon noCCS con args -mkStgRhs env rhs_fvs binder_info (StgLam _ bndrs body) +mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) ReEntrant - bndrs body + srt bndrs body -mkStgRhs env rhs_fvs binder_info rhs +mkStgRhs rhs_fvs srt binder_info rhs = StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - upd_flag [] rhs + upd_flag srt [] rhs where upd_flag = Updatable {- @@ -895,6 +883,14 @@ mapAndUnzip3Lne f (x:xs) mapAndUnzip3Lne f xs `thenLne` \ (rs1, rs2, rs3) -> returnLne (r1:rs1, r2:rs2, r3:rs3) +mapAndUnzip4Lne :: (a -> LneM (b,c,d,e)) -> [a] -> LneM ([b],[c],[d],[e]) + +mapAndUnzip4Lne f [] = returnLne ([],[],[],[]) +mapAndUnzip4Lne f (x:xs) + = f x `thenLne` \ (r1, r2, r3, r4) -> + mapAndUnzip4Lne f xs `thenLne` \ (rs1, rs2, rs3, rs4) -> + returnLne (r1:rs1, r2:rs2, r3:rs3, r4:rs4) + fixLne :: (a -> LneM a) -> LneM a fixLne expr env lvs_cont = result