#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
import CostCentre ( noCCS )
import VarSet
import VarEnv
-import DataCon ( dataConWrapId )
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 Util ( listLengthCmp )
import Outputable
infixr 9 `thenLne`
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
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) (manifestArity 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(isLocalId id || idArity id == manifestArity rhs, ppr id)
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)
= 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 ]
+ extra_env' = [ (b, LetBound TopLet (manifestArity rhs))
+ | (b, rhs) <- pairs ]
+ env' = extendVarEnvList env extra_env'
- caf_info = hasCafRefss env1{-NB: not env'-} rhss
-
- env' = extendVarEnvList env
- [ (b, LetBound (TopLet caf_info) (manifestArity 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 [isLocalId bndr || manifestArity rhs == idArity bndr | (bndr,rhs) <- pairs], ppr binders)
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}
-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) = listLengthCmp args (idArity f) == LT -- idArity f > length args
-isPAP _ = False
\end{code}
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) ->
(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
\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}
-- 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
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 (
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
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])
| (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)
)
)
is_join_var j = occNameUserString (getOccName j) == "$j"
\end{code}
+\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
+
+mkStgRhs :: FreeVarsInfo -> SRT -> StgBinderInfo -> StgExpr -> StgRhs
+
+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
+
%************************************************************************
%* *
| 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
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
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
= 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)
-- 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
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}
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}
projects / ghc-hetmet.git / blobdiff