X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=824cabaacbd51c1468cf5ea6d56c8143c3a5edfc;hb=28a464a75e14cece5db40f2765a29348273ff2d2;hp=636f170aae3ae908b45fcabc14cebe1d500d2cab;hpb=19108ede05d6528d0b66edb2bcf031e8da9522e2;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 636f170..824caba 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, findDefault ) import StgSyn import Type import TyCon ( isAlgTyCon ) -import Literal import Id -import Var ( Var, globalIdDetails, varType ) +import Var ( Var, globalIdDetails, idType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) #endif @@ -30,9 +30,10 @@ import VarSet import VarEnv import Maybes ( maybeToBool ) import Name ( getOccName, isExternalName, nameOccName ) -import OccName ( occNameUserString, occNameFS ) +import OccName ( occNameString, occNameFS ) import BasicTypes ( Arity ) -import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) +import Packages ( HomeModules ) +import StaticFlags ( opt_RuntimeTypes ) import Outputable infixr 9 `thenLne` @@ -139,10 +140,10 @@ for x, solely to put in the SRTs lower down. %************************************************************************ \begin{code} -coreToStg :: DynFlags -> [CoreBind] -> IO [StgBinding] -coreToStg dflags pgm +coreToStg :: HomeModules -> [CoreBind] -> IO [StgBinding] +coreToStg hmods pgm = return pgm' - where (_, _, pgm') = coreTopBindsToStg emptyVarEnv pgm + where (_, _, pgm') = coreTopBindsToStg hmods emptyVarEnv pgm coreExprToStg :: CoreExpr -> StgExpr coreExprToStg expr @@ -150,66 +151,65 @@ coreExprToStg expr coreTopBindsToStg - :: IdEnv HowBound -- environment for the bindings + :: HomeModules + -> IdEnv HowBound -- environment for the bindings -> [CoreBind] -> (IdEnv HowBound, FreeVarsInfo, [StgBinding]) -coreTopBindsToStg env [] = (env, emptyFVInfo, []) -coreTopBindsToStg env (b:bs) +coreTopBindsToStg hmods env [] = (env, emptyFVInfo, []) +coreTopBindsToStg hmods env (b:bs) = (env2, fvs2, b':bs') where -- env accumulates down the list of binds, fvs accumulates upwards - (env1, fvs2, b' ) = coreTopBindToStg env fvs1 b - (env2, fvs1, bs') = coreTopBindsToStg env1 bs + (env1, fvs2, b' ) = coreTopBindToStg hmods env fvs1 b + (env2, fvs1, bs') = coreTopBindsToStg hmods env1 bs coreTopBindToStg - :: IdEnv HowBound + :: HomeModules + -> IdEnv HowBound -> FreeVarsInfo -- Info about the body -> CoreBind -> (IdEnv HowBound, FreeVarsInfo, StgBinding) -coreTopBindToStg env body_fvs (NonRec id rhs) +coreTopBindToStg hmods env body_fvs (NonRec id rhs) = let env' = extendVarEnv env id how_bound - how_bound = LetBound TopLet (manifestArity rhs) + 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) + coreToTopStgRhs hmods body_fvs (id,rhs) `thenLne` \ (stg_rhs, fvs') -> + 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) -- WARN(not (consistent caf_info bind), ppr id <+> ppr cafs <+> ppCafInfo caf_info) (env', fvs' `unionFVInfo` body_fvs, bind) -coreTopBindToStg env body_fvs (Rec pairs) +coreTopBindToStg hmods env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - extra_env' = [ (b, LetBound TopLet (manifestArity rhs)) + extra_env' = [ (b, LetBound TopLet $! manifestArity rhs) | (b, rhs) <- pairs ] env' = extendVarEnvList env extra_env' - (stg_rhss, fvs', lv_info) + (stg_rhss, fvs') = initLne env' ( - mapAndUnzipLne (coreToTopStgRhs body_fvs) pairs + mapAndUnzipLne (coreToTopStgRhs hmods 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 +219,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 @@ -230,35 +232,40 @@ consistentCafInfo id bind \begin{code} coreToTopStgRhs - :: FreeVarsInfo -- Free var info for the scope of the binding + :: HomeModules + -> FreeVarsInfo -- Free var info for the scope of the binding -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs scope_fv_info (bndr, rhs) +coreToTopStgRhs hmods 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 hmods 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 + = ASSERT2( not is_static, ppr rhs ) + StgRhsClosure noCCS binder_info (getFVs rhs_fvs) - upd + Updatable + srt [] rhs \end{code} @@ -327,10 +334,10 @@ coreToStgExpr (Note other_note expr) -- Cases require a little more real work. -coreToStgExpr (Case scrut bndr alts) +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 +371,7 @@ coreToStgExpr (Case scrut bndr alts) (getLiveVars alts_lv_info) bndr' (mkSRT alts_lv_info) + (mkStgAltType (idType bndr) alts) alts2, scrut_fvs `unionFVInfo` alts_fvs_wo_bndr, alts_escs_wo_bndr `unionVarSet` getFVSet scrut_fvs @@ -403,28 +411,29 @@ 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) +mkStgAltType scrut_ty alts + = case splitTyConApp_maybe (repType scrut_ty) of + Just (tc,_) | isUnboxedTupleTyCon tc -> UbxTupAlt tc + | isPrimTyCon tc -> PrimAlt tc + | isHiBootTyCon tc -> look_for_better_tycon + | isAlgTyCon tc -> AlgAlt tc + | isFunTyCon tc -> PolyAlt + | otherwise -> pprPanic "mkStgAlts" (ppr tc) + Nothing -> PolyAlt - 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 + where + -- Sometimes, the TyCon in the type of the scrutinee is an HiBootTyCon, + -- which may not have any constructors inside it. If so, then we + -- can get a better TyCon by grabbing the one from a constructor alternative + -- if one exists. + look_for_better_tycon + | ((DataAlt con, _, _) : _) <- data_alts = + AlgAlt (dataConTyCon con) + | otherwise = + ASSERT(null data_alts) + PolyAlt + where + (data_alts, _deflt) = findDefault alts \end{code} @@ -455,7 +464,7 @@ coreToStgApp maybe_thunk_body f args -- Here the free variables are "f", "x" AND the type variable "a" -- coreToStgArgs will deal with the arguments recursively if opt_RuntimeTypes then - fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (varType f)) + fvs `unionFVInfo` tyvarFVInfo (tyVarsOfType (idType f)) else fvs -- Mostly, the arity info of a function is in the fn's IdInfo @@ -646,14 +655,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 +673,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) ) ) @@ -683,37 +688,39 @@ coreToStgLet let_no_escape bind body is_join_var :: Id -> Bool -- A hack (used only for compiler debuggging) to tell if -- a variable started life as a join point ($j) -is_join_var j = occNameUserString (getOccName j) == "$j" +is_join_var j = occNameString (getOccName j) == "$j" \end{code} \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 {- @@ -872,15 +879,7 @@ thenLne :: LneM a -> (a -> LneM b) -> LneM b thenLne m k env lvs_cont = k (m env lvs_cont) env lvs_cont -mapLne :: (a -> LneM b) -> [a] -> LneM [b] -mapLne f [] = returnLne [] -mapLne f (x:xs) - = f x `thenLne` \ r -> - mapLne f xs `thenLne` \ rs -> - returnLne (r:rs) - mapAndUnzipLne :: (a -> LneM (b,c)) -> [a] -> LneM ([b],[c]) - mapAndUnzipLne f [] = returnLne ([],[]) mapAndUnzipLne f (x:xs) = f x `thenLne` \ (r1, r2) -> @@ -888,13 +887,19 @@ mapAndUnzipLne f (x:xs) returnLne (r1:rs1, r2:rs2) mapAndUnzip3Lne :: (a -> LneM (b,c,d)) -> [a] -> LneM ([b],[c],[d]) - mapAndUnzip3Lne f [] = returnLne ([],[],[]) mapAndUnzip3Lne f (x:xs) = f x `thenLne` \ (r1, r2, r3) -> 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 @@ -1034,12 +1039,12 @@ lookupFVInfo fvs id Just (_,_,info) -> info allFreeIds :: FreeVarsInfo -> [(Id,HowBound)] -- Both top level and non-top-level Ids -allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- rngVarEnv fvs, isId id] +allFreeIds fvs = [(id,how_bound) | (id,how_bound,_) <- varEnvElts fvs, isId id] -- Non-top-level things only, both type variables and ids -- (type variables only if opt_RuntimeTypes) getFVs :: FreeVarsInfo -> [Var] -getFVs fvs = [id | (id, how_bound, _) <- rngVarEnv fvs, +getFVs fvs = [id | (id, how_bound, _) <- varEnvElts fvs, not (topLevelBound how_bound) ] getFVSet :: FreeVarsInfo -> VarSet