X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FstgSyn%2FCoreToStg.lhs;h=15e9fc3cd65015eda357ce509949fe69b17a60ae;hb=1cfc9faaa059b9b090971399e4eb8ae9d364335c;hp=659e15ded36e61adf1ec95e5166e05cce6592848;hpb=4a1e12a1edfd959c133d922b1adc733c137610d7;p=ghc-hetmet.git diff --git a/ghc/compiler/stgSyn/CoreToStg.lhs b/ghc/compiler/stgSyn/CoreToStg.lhs index 659e15d..15e9fc3 100644 --- a/ghc/compiler/stgSyn/CoreToStg.lhs +++ b/ghc/compiler/stgSyn/CoreToStg.lhs @@ -12,7 +12,7 @@ module CoreToStg ( coreToStg, coreExprToStg ) where #include "HsVersions.h" import CoreSyn -import CoreUtils +import CoreUtils ( rhsIsStatic, manifestArity, exprType ) import StgSyn import Type @@ -20,19 +20,19 @@ import TyCon ( isAlgTyCon ) import Literal import Id import Var ( Var, globalIdDetails, varType ) +#ifdef ILX +import MkId ( unsafeCoerceId ) +#endif import IdInfo import DataCon import CostCentre ( noCCS ) import VarSet import VarEnv -import DataCon ( dataConWrapId ) -import IdInfo ( OccInfo(..) ) import Maybes ( maybeToBool ) -import Name ( getOccName, isExternallyVisibleName, isDllName ) -import OccName ( occNameUserString ) -import BasicTypes ( TopLevelFlag(..), isNotTopLevel, Arity ) +import Name ( getOccName, isExternalName, nameOccName ) +import OccName ( occNameUserString, occNameFS ) +import BasicTypes ( Arity ) import CmdLineOpts ( DynFlags, opt_RuntimeTypes ) -import FastTypes hiding ( fastOr ) import Outputable infixr 9 `thenLne` @@ -102,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 @@ -172,21 +171,19 @@ coreTopBindToStg coreTopBindToStg env body_fvs (NonRec id rhs) = let - caf_info = hasCafRefs env rhs env' = extendVarEnv env id how_bound - how_bound = LetBound (TopLet caf_info) (predictArity rhs) + how_bound = LetBound TopLet (manifestArity rhs) - (stg_rhs, fvs', lv_info) = + (stg_rhs, fvs') = initLne env ( - coreToStgRhs body_fvs TopLevel (id,rhs) `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(predictArity rhs == stgRhsArity stg_rhs, ppr id) - ASSERT2(consistent caf_info bind, ppr id) + 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) @@ -194,115 +191,78 @@ coreTopBindToStg env body_fvs (Rec pairs) = let (binders, rhss) = unzip pairs - -- To calculate caf_info, we initially map - -- all the binders to NoCafRefs - env1 = extendVarEnvList env - [ (b, LetBound (TopLet NoCafRefs) (error "no arity")) - | b <- binders ] - - caf_info = hasCafRefss env1{-NB: not env'-} rhss + extra_env' = [ (b, LetBound TopLet (manifestArity rhs)) + | (b, rhs) <- pairs ] + env' = extendVarEnvList env extra_env' - env' = extendVarEnvList env - [ (b, LetBound (TopLet caf_info) (predictArity rhs)) - | (b,rhs) <- pairs ] - - (stg_rhss, fvs', lv_info) + (stg_rhss, fvs') = initLne env' ( - mapAndUnzip3Lne (coreToStgRhs body_fvs TopLevel) pairs - `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 [predictArity 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(and [manifestArity rhs == stgRhsArity stg_rhs | (rhs,stg_rhs) <- rhss `zip` stg_rhss], ppr binders) + 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} -coreToStgRhs +coreToTopStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding - -> TopLevelFlag -> (Id,CoreExpr) - -> LneM (StgRhs, FreeVarsInfo, EscVarsSet) + -> LneM (StgRhs, FreeVarsInfo) -coreToStgRhs scope_fv_info top (binder, rhs) - = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> - returnLne (mkStgRhs top rhs_fvs binder_info new_rhs, - rhs_fvs, rhs_escs) +coreToTopStgRhs scope_fv_info (bndr, rhs) + = coreToStgExpr rhs `thenLne` \ (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 - binder_info = lookupFVInfo scope_fv_info binder + bndr_info = lookupFVInfo scope_fv_info bndr + is_static = rhsIsStatic rhs -mkStgRhs :: TopLevelFlag -> FreeVarsInfo -> StgBinderInfo - -> StgExpr -> StgRhs +mkTopStgRhs :: Bool -> FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr + -> StgRhs -mkStgRhs top 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 -mkStgRhs top rhs_fvs binder_info (StgConApp con args) - | isNotTopLevel top || not (isDllConApp con args) +mkTopStgRhs is_static rhs_fvs srt binder_info (StgConApp con args) + | is_static -- StgConApps can be updatable (see isCrossDllConApp) = StgRhsCon noCCS con args -mkStgRhs top 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) - (updatable [] rhs) + Updatable + srt [] rhs - where - updatable args body | null args && isPAP body = ReEntrant - | otherwise = Updatable -{- ToDo: - upd = if isOnceDem dem - then (if isNotTop toplev - then SingleEntry -- HA! Paydirt for "dem" - else -#ifdef DEBUG - trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ -#endif - Updatable) - else Updatable - -- For now we forbid SingleEntry CAFs; they tickle the - -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, - -- and I don't understand why. There's only one SE_CAF (well, - -- only one that tickled a great gaping bug in an earlier attempt - -- at ClosureInfo.getEntryConvention) in the whole of nofib, - -- specifically Main.lvl6 in spectral/cryptarithm2. - -- So no great loss. KSW 2000-07. --} -\end{code} - -Detect thunks which will reduce immediately to PAPs, and make them -non-updatable. This has several advantages: - - - the non-updatable thunk behaves exactly like the PAP, - - - the thunk is more efficient to enter, because it is - specialised to the task. - - - we save one update frame, one stg_update_PAP, one update - and lots of PAP_enters. - - - in the case where the thunk is top-level, we save building - a black hole and futhermore the thunk isn't considered to - be a CAF any more, so it doesn't appear in any SRTs. - -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 (StgApp f args) = idArity f > length args -isPAP _ = False \end{code} @@ -356,6 +316,15 @@ coreToStgExpr (Note (SCC cc) expr) = coreToStgExpr expr `thenLne` ( \ (expr2, fvs, escs) -> returnLne (StgSCC cc expr2, fvs, escs) ) +#ifdef ILX +-- For ILX, convert (__coerce__ to_ty from_ty e) +-- into (coerce to_ty from_ty e) +-- where coerce is real function +coreToStgExpr (Note (Coerce to_ty from_ty) expr) + = coreToStgExpr (mkApps (Var unsafeCoerceId) + [Type from_ty, Type to_ty, expr]) +#endif + coreToStgExpr (Note other_note expr) = coreToStgExpr expr @@ -499,10 +468,7 @@ coreToStgApp maybe_thunk_body f args -- No point in having correct arity info for f! -- Hence the hasArity stuff below. -- NB: f_arity is only consulted for LetBound things - f_arity = case how_bound of - LetBound _ arity -> arity - ImportBound -> idArity f - + f_arity = stgArity f how_bound saturated = f_arity <= n_val_args fun_occ @@ -531,12 +497,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 ( @@ -572,7 +538,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 @@ -667,7 +633,7 @@ coreToStgLet let_no_escape bind body binders = bindersOf bind mk_binding bind_lv_info binder rhs - = (binder, LetBound (NestedLet live_vars) (predictArity rhs)) + = (binder, LetBound (NestedLet live_vars) (manifestArity rhs)) where live_vars | let_no_escape = addLiveVar bind_lv_info binder | otherwise = unitLiveVar binder @@ -683,14 +649,12 @@ coreToStgLet let_no_escape bind body vars_bind body_fvs (NonRec binder rhs) - = coreToStgRhs body_fvs NotTopLevel (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]) @@ -703,16 +667,14 @@ coreToStgLet let_no_escape bind body | (b,rhs) <- pairs ] in extendVarEnvLne env_ext ( - mapAndUnzip3Lne (coreToStgRhs rec_scope_fvs NotTopLevel) 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) ) ) @@ -723,28 +685,91 @@ is_join_var :: Id -> Bool is_join_var j = occNameUserString (getOccName j) == "$j" \end{code} -%************************************************************************ -%* * -\subsection{Arity prediction} -%* * -%************************************************************************ +\begin{code} +coreToStgRhs :: FreeVarsInfo -- Free var info for the scope of the binding + -> [Id] + -> (Id,CoreExpr) + -> LneM (StgRhs, FreeVarsInfo, LiveInfo, EscVarsSet) + +coreToStgRhs scope_fv_info binders (bndr, rhs) + = coreToStgExpr rhs `thenLne` \ (new_rhs, rhs_fvs, rhs_escs) -> + getEnvLne `thenLne` \ env -> + 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 -To avoid yet another knot, we predict the arity of each function from -its Core form, based on the number of visible top-level lambdas. -It should be the same as the arity of the STG RHS! +mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs -\begin{code} -predictArity :: CoreExpr -> Int -predictArity (Lam x e) - | isTyVar x = predictArity e - | otherwise = 1 + predictArity e -predictArity (Note _ e) - -- Ignore coercions. Top level sccs are removed by the final - -- profiling pass, so we ignore those too. - = predictArity e -predictArity _ = 0 +mkStgRhs rhs_fvs srt binder_info (StgConApp con args) + = StgRhsCon noCCS con args + +mkStgRhs rhs_fvs srt binder_info (StgLam _ bndrs body) + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + ReEntrant + srt bndrs body + +mkStgRhs rhs_fvs srt binder_info rhs + = StgRhsClosure noCCS binder_info + (getFVs rhs_fvs) + 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 + then SingleEntry -- HA! Paydirt for "dem" + else +#ifdef DEBUG + trace "WARNING: SE CAFs unsupported, forcing UPD instead" $ +#endif + Updatable) + else Updatable + -- For now we forbid SingleEntry CAFs; they tickle the + -- ASSERT in rts/Storage.c line 215 at newCAF() re mut_link, + -- and I don't understand why. There's only one SE_CAF (well, + -- only one that tickled a great gaping bug in an earlier attempt + -- at ClosureInfo.getEntryConvention) in the whole of nofib, + -- specifically Main.lvl6 in spectral/cryptarithm2. + -- So no great loss. KSW 2000-07. +-} \end{code} +Detect thunks which will reduce immediately to PAPs, and make them +non-updatable. This has several advantages: + + - the non-updatable thunk behaves exactly like the PAP, + + - the thunk is more efficient to enter, because it is + specialised to the task. + + - we save one update frame, one stg_update_PAP, one update + and lots of PAP_enters. + + - in the case where the thunk is top-level, we save building + a black hole and futhermore the thunk isn't considered to + be a CAF any more, so it doesn't appear in any SRTs. + +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. + +isPAP env (StgApp f args) = listLengthCmp args arity == LT -- idArity f > length args + where + arity = stgArity f (lookupBinding env f) +isPAP env _ = False + %************************************************************************ %* * @@ -778,17 +803,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 @@ -869,6 +896,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 @@ -893,6 +928,9 @@ extendVarEnvLne ids_w_howbound expr env lvs_cont lookupVarLne :: Id -> LneM HowBound lookupVarLne v env lvs_cont = returnLne (lookupBinding env v) env lvs_cont +getEnvLne :: LneM (IdEnv HowBound) +getEnvLne env lvs_cont = returnLne env env lvs_cont + lookupBinding :: IdEnv HowBound -> Id -> HowBound lookupBinding env v = case lookupVarEnv env v of Just xx -> xx @@ -914,9 +952,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) @@ -999,7 +1037,7 @@ lookupFVInfo :: FreeVarsInfo -> Id -> StgBinderInfo -- Find how the given Id is used. -- Externally visible things may be used any old how lookupFVInfo fvs id - | isExternallyVisibleName (idName id) = noBinderInfo + | isExternalName (idName id) = noBinderInfo | otherwise = case lookupVarEnv fvs id of Nothing -> noBinderInfo Just (_,_,info) -> info @@ -1028,7 +1066,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} @@ -1065,134 +1103,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 --- Only called for the RHS of top-level lets -hasCafRefss :: IdEnv HowBound -> [CoreExpr] -> CafInfo - -- predicate returns True for a given Id if we look at this Id when - -- calculating the result. Used to *avoid* looking at the CafInfo - -- field for an Id that is part of the current recursive group. - -hasCafRefs p expr - | isCAF expr || isFastTrue (cafRefs p expr) = MayHaveCafRefs - | otherwise = NoCafRefs - - -- used for recursive groups. The whole group is set to - -- "MayHaveCafRefs" if at least one of the group is a CAF or - -- refers to any CAFs. -hasCafRefss p exprs - | any isCAF exprs || isFastTrue (cafRefss p exprs) = MayHaveCafRefs - | otherwise = NoCafRefs - --- 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)) - -isCAF :: CoreExpr -> Bool --- Only called for the RHS of top-level lets -isCAF e = not (rhsIsNonUpd e) - {- ToDo: check type for onceness, i.e. non-updatable thunks? -} - - -rhsIsNonUpd :: 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 (Lam b e) = isRuntimeVar b || rhsIsNonUpd e -rhsIsNonUpd (Note (SCC _) e) = False -rhsIsNonUpd (Note _ e) = rhsIsNonUpd e -rhsIsNonUpd other_expr - = go other_expr 0 [] - where - go (Var f) n_args args = idAppIsNonUpd 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 :: Id -> Int -> [CoreExpr] -> Bool -idAppIsNonUpd id n_val_args args - | Just con <- isDataConId_maybe id = not (isCrossDllConApp con args) - | otherwise = n_val_args < idArity id - -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.coreToStgRhs) - - -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 +stgArity :: Id -> HowBound -> Arity +stgArity f (LetBound _ arity) = arity +stgArity f ImportBound = idArity f +stgArity f LambdaBound = 0 \end{code}