X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=2f59489e0aa5a0ce1795c2d64f8fd4bc0105c637;hp=258260d350859330db750d5969297dd57f6d2a3d;hb=0a095555ecc6400aba433bb7562140ac407730e1;hpb=9af77fa423926fbda946b31e174173d0ec5ebac8 diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 258260d..2f59489 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 Var ( Var, globalIdDetails, idType ) +import TyCon ( isUnboxedTupleTyCon, isPrimTyCon, isFunTyCon, isHiBootTyCon ) #ifdef ILX import MkId ( unsafeCoerceId ) #endif @@ -28,14 +28,11 @@ import DataCon import CostCentre ( noCCS ) import VarSet import VarEnv -import DataCon ( dataConWrapId ) import Maybes ( maybeToBool ) -import Name ( getOccName, isExternalName, isDllName ) -import OccName ( occNameUserString ) +import Name ( getOccName, isExternalName, nameOccName ) +import OccName ( occNameUserString, occNameFS ) import BasicTypes ( Arity ) import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) -import FastTypes hiding ( fastOr ) -import Util ( listLengthCmp, mapAndUnzip ) import Outputable infixr 9 `thenLne` @@ -105,8 +102,7 @@ A top-level Id has CafInfo, which is one or more CAFs, or - NoCafRefs if it definitely doesn't -we collect the CafInfo first by analysing the original Core expression, and -also place this information in the environment. +The CafInfo has already been calculated during the CoreTidy pass. During CoreToStg, we then pin onto each binding and case expression, a list of Ids which represents the "live" CAFs at that point. The meaning @@ -175,21 +171,19 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let - (caf_info, upd) = hasCafRefs env rhs env' = extendVarEnv env id how_bound - how_bound = LetBound (TopLet caf_info) (manifestArity rhs) + how_bound = LetBound TopLet (manifestArity rhs) - (stg_rhs, fvs', lv_info) = + (stg_rhs, fvs') = initLne env ( - coreToTopStgRhs body_fvs ((id,rhs), upd) `thenLne` \ (stg_rhs, fvs') -> - freeVarsToLiveVars fvs' `thenLne` \ lv_info -> - returnLne (stg_rhs, fvs', lv_info) + coreToTopStgRhs 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(consistent caf_info bind, 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) @@ -197,71 +191,77 @@ coreTopBindToStg env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - -- To calculate caf_info, we initially map - -- all the binders to NoCafRefs - extra_env = [ (b, LetBound (TopLet NoCafRefs) (manifestArity rhs)) - | (b,rhs) <- pairs ] - env1 = extendVarEnvList env extra_env - (caf_infos, upd_flags) = mapAndUnzip (hasCafRefs env1) rhss - -- NB: use env1 not env' - - -- If any has a CAF ref, they all do - caf_info | any mayHaveCafRefs caf_infos = MayHaveCafRefs - | otherwise = NoCafRefs - - extra_env' = [ (b, LetBound (TopLet caf_info) arity) - | (b, LetBound _ arity) <- extra_env ] + 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 `zip` upd_flags) `thenLne` \ (stg_rhss, fvss') -> + 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(consistent caf_info bind, ppr binders) --- WARN(not (consistent caf_info bind), ppr binders <+> ppr cafs <+> ppCafInfo caf_info) + ASSERT2(consistentCafInfo (head binders) bind, ppr binders) (env', fvs' `unionFVInfo` body_fvs, bind) --- assertion helper -consistent caf_info bind = mayHaveCafRefs caf_info == stgBindHasCafRefs bind +#ifdef DEBUG +-- Assertion helper: this checks that the CafInfo on the Id matches +-- what CoreToStg has figured out about the binding's SRT. The +-- CafInfo will be exact in all cases except when CorePrep has +-- floated out a binding, in which case it will be approximate. +consistentCafInfo id bind + | occNameFS (nameOccName (idName id)) == FSLIT("sat") + = safe + | otherwise + = 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 \end{code} \begin{code} coreToTopStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> ((Id,CoreExpr), UpdateFlag) + -> (Id,CoreExpr) -> LneM (StgRhs, FreeVarsInfo) -coreToTopStgRhs scope_fv_info ((bndr, rhs), upd) +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 -mkTopStgRhs :: UpdateFlag -> FreeVarsInfo -> StgBinderInfo - -> StgExpr -> StgRhs +mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> 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 ReEntrant rhs_fvs binder_info (StgConApp con args) - -- StgConApps can be Updatable: see isCrossDllConApp below +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_flag 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_flag + Updatable + srt [] rhs \end{code} @@ -333,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) -> @@ -367,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 @@ -406,28 +407,15 @@ 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 + | isHiBootTyCon tc -> PolyAlt -- Algebraic, but no constructors visible + | isAlgTyCon tc -> AlgAlt tc + | isFunTyCon tc -> PolyAlt + | otherwise -> pprPanic "mkStgAlts" (ppr tc) + Nothing -> PolyAlt \end{code} @@ -458,7 +446,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 @@ -497,12 +485,12 @@ coreToStgApp maybe_thunk_body f args res_ty = exprType (mkApps (Var f) args) app = case globalIdDetails f of - DataConId dc | saturated -> StgConApp dc args' - PrimOpId op -> ASSERT( saturated ) - StgOpApp (StgPrimOp op) args' res_ty - FCallId call -> ASSERT( saturated ) - StgOpApp (StgFCallOp call (idUnique f)) args' res_ty - _other -> StgApp f args' + DataConWorkId dc | saturated -> StgConApp dc args' + PrimOpId op -> ASSERT( saturated ) + StgOpApp (StgPrimOp op) args' res_ty + FCallId call -> ASSERT( saturated ) + StgOpApp (StgFCallOp call (idUnique f)) args' res_ty + _other -> StgApp f args' in returnLne ( @@ -538,7 +526,7 @@ coreToStgArgs (arg : args) -- Non-type argument fvs = args_fvs `unionFVInfo` arg_fvs stg_arg = case arg' of StgApp v [] -> StgVarArg v - StgConApp con [] -> StgVarArg (dataConWrapId con) + StgConApp con [] -> StgVarArg (dataConWorkId con) StgLit lit -> StgLitArg lit _ -> pprPanic "coreToStgArgs" (ppr arg) in @@ -649,14 +637,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]) @@ -669,16 +655,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) ) ) @@ -691,35 +675,45 @@ 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 + {- + SDM: disabled. Eval/Apply can't handle functions with arity zero very + well; and making these into simple non-updatable thunks breaks other + assumptions (namely that they will be entered only once). + upd_flag | isPAP env rhs = ReEntrant | otherwise = Updatable + -} + {- ToDo: upd = if isOnceDem dem then (if isNotTop toplev @@ -759,12 +753,10 @@ We do it here, because the arity information is accurate, and we need to do it before the SRT pass to save the SRT entries associated with any top-level PAPs. -\begin{code} isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args where arity = stgArity f (lookupBinding env f) isPAP env _ = False -\end{code} %************************************************************************ @@ -799,18 +791,19 @@ data HowBound | LambdaBound -- Used for both lambda and case -data LetInfo = NestedLet LiveInfo -- For nested things, what is live if this thing is live? - -- Invariant: the binder itself is always a member of - -- the dynamic set of its own LiveInfo - - | TopLet CafInfo -- For top level things, is it a CAF, or can it refer to one? +data LetInfo + = TopLet -- top level things + | NestedLet LiveInfo -- For nested things, what is live if this + -- thing is live? Invariant: the binder + -- itself is always a member of + -- the dynamic set of its own LiveInfo isLetBound (LetBound _ _) = True isLetBound other = False -topLevelBound ImportBound = True -topLevelBound (LetBound (TopLet _) _) = True -topLevelBound other = False +topLevelBound ImportBound = True +topLevelBound (LetBound TopLet _) = True +topLevelBound other = False \end{code} For a let(rec)-bound variable, x, we record LiveInfo, the set of @@ -868,15 +861,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) -> @@ -884,13 +869,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 @@ -939,9 +930,9 @@ freeVarsToLiveVars fvs env live_in_cont = case how_bound of ImportBound -> unitLiveCaf v -- Only CAF imports are -- recorded in fvs - LetBound (TopLet caf_info) _ - | mayHaveCafRefs caf_info -> unitLiveCaf v - | otherwise -> emptyLiveInfo + LetBound TopLet _ + | mayHaveCafRefs (idCafInfo v) -> unitLiveCaf v + | otherwise -> emptyLiveInfo LetBound (NestedLet lvs) _ -> lvs -- lvs already contains v -- (see the invariant on NestedLet) @@ -1053,7 +1044,7 @@ check_eq_how_bound (LetBound li1 ar1) (LetBound li2 ar2) = ar1 == ar2 && check_e check_eq_how_bound hb1 hb2 = False check_eq_li (NestedLet _) (NestedLet _) = True -check_eq_li (TopLet _) (TopLet _) = True +check_eq_li TopLet TopLet = True check_eq_li li1 li2 = False #endif \end{code} @@ -1090,126 +1081,9 @@ myCollectArgs expr go _ as = pprPanic "CoreToStg.myCollectArgs" (ppr expr) \end{code} -%************************************************************************ -%* * -\subsection{Figuring out CafInfo for an expression} -%* * -%************************************************************************ - -hasCafRefs decides whether a top-level closure can point into the dynamic heap. -We mark such things as `MayHaveCafRefs' because this information is -used to decide whether a particular closure needs to be referenced -in an SRT or not. - -There are two reasons for setting MayHaveCafRefs: - a) The RHS is a CAF: a top-level updatable thunk. - b) The RHS refers to something that MayHaveCafRefs - -Possible improvement: In an effort to keep the number of CAFs (and -hence the size of the SRTs) down, we could also look at the expression and -decide whether it requires a small bounded amount of heap, so we can ignore -it as a CAF. In these cases however, we would need to use an additional -CAF list to keep track of non-collectable CAFs. - \begin{code} -hasCafRefs :: IdEnv HowBound -> CoreExpr -> (CafInfo, UpdateFlag) -hasCafRefs p expr - | is_caf || mentions_cafs = (MayHaveCafRefs, upd_flag) - | otherwise = (NoCafRefs, ReEntrant) - where - mentions_cafs = isFastTrue (cafRefs p expr) - is_caf = not (rhsIsNonUpd p expr) - upd_flag | is_caf = Updatable - | otherwise = ReEntrant - --- The environment that cafRefs uses has top-level bindings *only*. --- We don't bother to add local bindings as cafRefs traverses the expression --- because they will all be for LocalIds (all nested things are LocalIds) --- However, we must look in the env first, because some top level things --- might be local Ids - -cafRefs p (Var id) - = case lookupVarEnv p id of - Just (LetBound (TopLet caf_info) _) -> fastBool (mayHaveCafRefs caf_info) - Nothing | isGlobalId id -> fastBool (mayHaveCafRefs (idCafInfo id)) -- Imported - | otherwise -> fastBool False -- Nested binder - _other -> error ("cafRefs " ++ showSDoc (ppr id)) -- No nested things in env - -cafRefs p (Lit l) = fastBool False -cafRefs p (App f a) = fastOr (cafRefs p f) (cafRefs p) a -cafRefs p (Lam x e) = cafRefs p e -cafRefs p (Let b e) = fastOr (cafRefss p (rhssOfBind b)) (cafRefs p) e -cafRefs p (Case e bndr alts) = fastOr (cafRefs p e) (cafRefss p) (rhssOfAlts alts) -cafRefs p (Note n e) = cafRefs p e -cafRefs p (Type t) = fastBool False - -cafRefss p [] = fastBool False -cafRefss p (e:es) = fastOr (cafRefs p e) (cafRefss p) es - --- hack for lazy-or over FastBool. -fastOr a f x = fastBool (isFastTrue a || isFastTrue (f x)) - - -rhsIsNonUpd :: IdEnv HowBound -> CoreExpr -> Bool - -- True => Value-lambda, constructor, PAP - -- This is a bit like CoreUtils.exprIsValue, with the following differences: - -- a) scc "foo" (\x -> ...) is updatable (so we catch the right SCC) - -- - -- b) (C x xs), where C is a contructors is updatable if the application is - -- dynamic: see isDynConApp - -- - -- c) don't look through unfolding of f in (f x). I'm suspicious of this one - --- This function has to line up with what the update flag --- for the StgRhs gets set to in mkStgRhs (above) --- --- When opt_RuntimeTypes is on, we keep type lambdas and treat --- them as making the RHS re-entrant (non-updatable). -rhsIsNonUpd p (Lam b e) = isRuntimeVar b || rhsIsNonUpd p e -rhsIsNonUpd p (Note (SCC _) e) = False -rhsIsNonUpd p (Note _ e) = rhsIsNonUpd p e -rhsIsNonUpd p other_expr - = go other_expr 0 [] - where - go (Var f) n_args args = idAppIsNonUpd p f n_args args - - go (App f a) n_args args - | isTypeArg a = go f n_args args - | otherwise = go f (n_args + 1) (a:args) - - go (Note (SCC _) f) n_args args = False - go (Note _ f) n_args args = go f n_args args - - go other n_args args = False - -idAppIsNonUpd :: IdEnv HowBound -> Id -> Int -> [CoreExpr] -> Bool -idAppIsNonUpd p id n_val_args args - | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) - | otherwise = n_val_args < stgArity id (lookupBinding p id) - stgArity :: Id -> HowBound -> Arity stgArity f (LetBound _ arity) = arity stgArity f ImportBound = idArity f stgArity f LambdaBound = 0 - -isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool -isCrossDllConApp con args = isDllName (dataConName con) || any isCrossDllArg args --- Top-level constructor applications can usually be allocated --- statically, but they can't if --- a) the constructor, or any of the arguments, come from another DLL --- b) any of the arguments are LitLits --- (because we can't refer to static labels in other DLLs). --- If this happens we simply make the RHS into an updatable thunk, --- and 'exectute' it rather than allocating it statically. --- All this should match the decision in (see CoreToStg.mkStgRhs) - - -isCrossDllArg :: CoreExpr -> Bool --- True if somewhere in the expression there's a cross-DLL reference -isCrossDllArg (Type _) = False -isCrossDllArg (Var v) = isDllName (idName v) -isCrossDllArg (Note _ e) = isCrossDllArg e -isCrossDllArg (Lit lit) = isLitLitLit lit -isCrossDllArg (App e1 e2) = isCrossDllArg e1 || isCrossDllArg e2 -- must be a type app -isCrossDllArg (Lam v e) = isCrossDllArg e -- must be a type lam \end{code}