Commit 19108ede authored by simonmar's avatar simonmar

[project @ 2003-03-03 12:43:31 by simonmar]

A round of space-leak fixing.

  - re-instate zapping of the PersistentCompilerState at various
    points during the compilation cycle in HscMain.  This affects
    one-shot compilation only, since in this mode the information
    collected in the PCS is not required after creating the final
    interface file.

  - Unravel the recursive dependency between MkIface and
    CoreTidy/CoreToStg.  Previously the CafInfo for each binding was
    calculated by CoreToStg, and fed back into the IdInfo of the Ids
    generated by CoreTidy (an earlier pass).  MkIface then took this
    IdInfo and the bindings from CoreTidy to generate the interface;
    but it couldn't do this until *after* CoreToStg, because the CafInfo
    hadn't been calculated yet.  The result was that the CoreTidy
    output lived until after CoreToStg, and at the same time as the
    CorePrep and STG syntax, which is wasted space, not to mention
    the complexity and general ugliness in HscMain.

    So now we calculate CafInfo directly in CoreTidy.  The downside is
    that we have to predict what CorePrep is going to do to the
    bindings so we can tell what will turn into a CAF later, but it's
    no worse than before (it turned out that we were doing this
    prediction before in CoreToStg anyhow).

  - The typechecker lazilly typechecks unfoldings.  It turns out that
    this is a good idea from a performance perspective, but it also
    means that it must hang on to all the information it needs to
    do the typechecking.  Previously this meant holding on to the
    whole of the typechecker's environment, which includes all sorts
    of stuff which isn't necessary to typecheck unfoldings.  By paring
    down the environment captured by the lazy unfoldings, we can
    save quite a bit of space in the phases after typechecking.
parent 1b2e253b
......@@ -48,7 +48,7 @@ module Id (
setIdNewStrictness, zapIdNewStrictness,
setIdWorkerInfo,
setIdSpecialisation,
setIdCgInfo,
setIdCafInfo,
setIdOccInfo,
#ifdef OLD_STRICTNESS
......@@ -66,7 +66,6 @@ module Id (
idWorkerInfo,
idUnfolding,
idSpecialisation, idCoreRules,
idCgInfo,
idCafInfo,
idLBVarInfo,
idOccInfo,
......@@ -397,20 +396,6 @@ idCoreRules id = [(id,rule) | rule <- rulesRules (idSpecialisation id)]
setIdSpecialisation :: Id -> CoreRules -> Id
setIdSpecialisation id spec_info = modifyIdInfo (`setSpecInfo` spec_info) id
---------------------------------
-- CG INFO
idCgInfo :: Id -> CgInfo
#ifdef OLD_STRICTNESS
idCgInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCgInfo" (ppr id)
info -> info
#else
idCgInfo id = cgInfo (idInfo id)
#endif
setIdCgInfo :: Id -> CgInfo -> Id
setIdCgInfo id cg_info = modifyIdInfo (`setCgInfo` cg_info) id
---------------------------------
-- CAF INFO
idCafInfo :: Id -> CafInfo
......@@ -419,8 +404,12 @@ idCafInfo id = case cgInfo (idInfo id) of
NoCgInfo -> pprPanic "idCafInfo" (ppr id)
info -> cgCafInfo info
#else
idCafInfo id = cgCafInfo (idCgInfo id)
idCafInfo id = cafInfo (idInfo id)
#endif
setIdCafInfo :: Id -> CafInfo -> Id
setIdCafInfo id caf_info = modifyIdInfo (`setCafInfo` caf_info) id
---------------------------------
-- CPR INFO
#ifdef OLD_STRICTNESS
......
......@@ -11,7 +11,7 @@ module IdInfo (
GlobalIdDetails(..), notGlobalId, -- Not abstract
IdInfo, -- Abstract
vanillaIdInfo, noCafIdInfo, hasCafIdInfo,
vanillaIdInfo, noCafIdInfo,
seqIdInfo, megaSeqIdInfo,
-- Zapping
......@@ -64,13 +64,8 @@ module IdInfo (
-- Specialisation
specInfo, setSpecInfo,
-- CG info
CgInfo(..), cgInfo, setCgInfo, pprCgInfo,
cgCafInfo, vanillaCgInfo,
CgInfoEnv, lookupCgInfo,
-- CAF info
CafInfo(..), ppCafInfo, setCafInfo, mayHaveCafRefs,
CafInfo(..), cafInfo, ppCafInfo, setCafInfo, mayHaveCafRefs,
-- Lambda-bound variable info
LBVarInfo(..), lbvarInfo, setLBVarInfo, noLBVarInfo, hasNoLBVarInfo
......@@ -80,12 +75,12 @@ module IdInfo (
import CoreSyn
import Type ( Type )
import TyCon ( TyCon )
import Class ( Class )
import PrimOp ( PrimOp )
import NameEnv ( NameEnv, lookupNameEnv )
#ifdef OLD_STRICTNESS
import Name ( Name )
#endif
import Var ( Id )
import BasicTypes ( OccInfo(..), isFragileOcc, isDeadOcc, seqOccInfo, isLoopBreaker,
InsideLam, insideLam, notInsideLam,
......@@ -114,7 +109,6 @@ infixl 1 `setSpecInfo`,
`setWorkerInfo`,
`setLBVarInfo`,
`setOccInfo`,
`setCgInfo`,
`setCafInfo`,
`setNewStrictnessInfo`,
`setAllStrictnessInfo`,
......@@ -298,7 +292,7 @@ data IdInfo
#endif
workerInfo :: WorkerInfo, -- Pointer to Worker Function
unfoldingInfo :: Unfolding, -- Its unfolding
cgInfo :: CgInfo, -- Code generator info (arity, CAF info)
cafInfo :: CafInfo, -- CAF info
lbvarInfo :: LBVarInfo, -- Info about a lambda-bound variable
inlinePragInfo :: InlinePragInfo, -- Inline pragma
occInfo :: OccInfo, -- How it occurs
......@@ -334,10 +328,8 @@ megaSeqIdInfo info
seqCpr (cprInfo info) `seq`
#endif
-- CgInfo is involved in a loop, so we have to be careful not to seq it
-- too early.
-- seqCg (cgInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqCaf (cafInfo info) `seq`
seqLBVar (lbvarInfo info) `seq`
seqOccInfo (occInfo info)
\end{code}
......@@ -380,8 +372,8 @@ setDemandInfo info dd = info { demandInfo = dd }
setCprInfo info cp = info { cprInfo = cp }
#endif
setArityInfo info ar = info { arityInfo = ar }
setCgInfo info cg = info { cgInfo = cg }
setArityInfo info ar = info { arityInfo = ar }
setCafInfo info caf = info { cafInfo = caf }
setLBVarInfo info lb = {-lb `seq`-} info { lbvarInfo = lb }
......@@ -394,7 +386,7 @@ setNewStrictnessInfo info dd = dd `seq` info { newStrictnessInfo = dd }
vanillaIdInfo :: IdInfo
vanillaIdInfo
= IdInfo {
cgInfo = noCgInfo,
cafInfo = vanillaCafInfo,
arityInfo = unknownArity,
#ifdef OLD_STRICTNESS
cprInfo = NoCPRInfo,
......@@ -411,11 +403,8 @@ vanillaIdInfo
newStrictnessInfo = Nothing
}
hasCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo MayHaveCafRefs
noCafIdInfo = vanillaIdInfo `setCgInfo` CgInfo NoCafRefs
noCafIdInfo = vanillaIdInfo `setCafInfo` NoCafRefs
-- Used for built-in type Ids in MkId.
-- These must have a valid CgInfo set, so you can't
-- use vanillaIdInfo!
\end{code}
......@@ -526,31 +515,7 @@ wrapperArity (HasWorker _ a) = a
%* *
%************************************************************************
CgInfo encapsulates calling-convention information produced by the code
generator. It is pasted into the IdInfo of each emitted Id by CoreTidy,
but only as a thunk --- the information is only actually produced further
downstream, by the code generator.
\begin{code}
#ifndef OLD_STRICTNESS
newtype CgInfo = CgInfo CafInfo -- We are back to only having CafRefs in CgInfo
noCgInfo = panic "NoCgInfo!"
#else
data CgInfo = CgInfo CafInfo
| NoCgInfo -- In debug mode we don't want a black hole here
-- See Id.idCgInfo
-- noCgInfo is used for local Ids, which shouldn't need any CgInfo
noCgInfo = NoCgInfo
#endif
cgCafInfo (CgInfo caf_info) = caf_info
setCafInfo info caf_info = info `setCgInfo` CgInfo caf_info
seqCg c = c `seq` () -- fields are strict anyhow
vanillaCgInfo = CgInfo MayHaveCafRefs -- Definitely safe
-- CafInfo is used to build Static Reference Tables (see simplStg/SRT.lhs).
data CafInfo
......@@ -562,30 +527,17 @@ data CafInfo
| NoCafRefs -- A function or static constructor
-- that refers to no CAFs.
vanillaCafInfo = MayHaveCafRefs -- Definitely safe
mayHaveCafRefs MayHaveCafRefs = True
mayHaveCafRefs _ = False
seqCaf c = c `seq` ()
pprCgInfo (CgInfo caf_info) = ppCafInfo caf_info
ppArity 0 = empty
ppArity n = hsep [ptext SLIT("__A"), int n]
ppCafInfo NoCafRefs = ptext SLIT("__C")
ppCafInfo NoCafRefs = ptext SLIT("NoCafRefs")
ppCafInfo MayHaveCafRefs = empty
\end{code}
\begin{code}
type CgInfoEnv = NameEnv CgInfo
lookupCgInfo :: NameEnv CgInfo -> Name -> CgInfo
lookupCgInfo env n = case lookupNameEnv env n of
Just info -> info
Nothing -> pprTrace "Urk! Not in CgInfo env" (ppr n) vanillaCgInfo
\end{code}
%************************************************************************
%* *
\subsection[cpr-IdInfo]{Constructed Product Result info about an @Id@}
......
......@@ -72,10 +72,9 @@ import Id ( idType, mkGlobalId, mkVanillaGlobal, mkSysLocal, mkLocalId,
mkTemplateLocals, mkTemplateLocalsNum, setIdLocalExported,
mkTemplateLocal, idNewStrictness, idName
)
import IdInfo ( IdInfo, noCafIdInfo, hasCafIdInfo,
setUnfoldingInfo,
import IdInfo ( IdInfo, noCafIdInfo, setUnfoldingInfo,
setArityInfo, setSpecInfo, setCafInfo,
setAllStrictnessInfo,
setAllStrictnessInfo, vanillaIdInfo,
GlobalIdDetails(..), CafInfo(..)
)
import NewDemand ( mkStrictSig, strictSigResInfo, DmdResult(..),
......@@ -970,7 +969,7 @@ pcMiscPrelId name ty info
pc_bottoming_Id name ty
= pcMiscPrelId name ty bottoming_info
where
bottoming_info = hasCafIdInfo `setAllStrictnessInfo` Just strict_sig
bottoming_info = vanillaIdInfo `setAllStrictnessInfo` Just strict_sig
-- Do *not* mark them as NoCafRefs, because they can indeed have
-- CAF refs. For example, pAT_ERROR_ID calls GHC.Err.untangle,
-- which has some CAFs
......
......@@ -40,7 +40,7 @@ import CgConTbls ( genStaticConBits )
import ClosureInfo ( mkClosureLFInfo )
import CmdLineOpts ( DynFlags, DynFlag(..),
opt_SccProfilingOn, opt_EnsureSplittableC )
import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..),
import HscTypes ( ModGuts(..), ModGuts, ForeignStubs(..), TypeEnv,
typeEnvTyCons )
import CostCentre ( CollectedCCs )
import Id ( Id, idName, setIdName )
......@@ -48,6 +48,7 @@ import Name ( nameSrcLoc, nameOccName, nameUnique, isInternalName, mkExternalNa
import OccName ( mkLocalOcc )
import PrimRep ( PrimRep(..) )
import TyCon ( isDataTyCon )
import Module ( Module )
import BasicTypes ( TopLevelFlag(..) )
import UniqSupply ( mkSplitUniqSupply )
import ErrUtils ( dumpIfSet_dyn, showPass )
......@@ -62,13 +63,15 @@ import DATA_IOREF ( readIORef )
\begin{code}
codeGen :: DynFlags
-> ModGuts
-> Module
-> TypeEnv
-> ForeignStubs
-> [Module] -- directly-imported modules
-> CollectedCCs -- (Local/global) cost-centres needing declaring/registering.
-> [(StgBinding,[Id])] -- Bindings to convert, with SRTs
-> IO AbstractC -- Output
codeGen dflags
mod_impl@(ModGuts { mg_module = mod_name, mg_types = type_env })
codeGen dflags this_mod type_env foreign_stubs imported_mods
cost_centre_info stg_binds
= do
showPass dflags "CodeGen"
......@@ -78,11 +81,17 @@ codeGen dflags
let
tycons = typeEnvTyCons type_env
data_tycons = filter isDataTyCon tycons
cinfo = MkCompInfo mod_name
mapM_ (\x -> seq x (return ())) data_tycons
let
cinfo = MkCompInfo this_mod
datatype_stuff = genStaticConBits cinfo data_tycons
code_stuff = initC cinfo (mapCs cgTopBinding stg_binds)
init_stuff = mkModuleInit way cost_centre_info mod_impl
init_stuff = mkModuleInit way cost_centre_info this_mod
foreign_stubs imported_mods
abstractC = mkAbstractCs [ maybeSplitCode,
init_stuff,
......@@ -108,17 +117,16 @@ codeGen dflags
mkModuleInit
:: String -- the "way"
-> CollectedCCs -- cost centre info
-> ModGuts
-> Module
-> ForeignStubs
-> [Module]
-> AbstractC
mkModuleInit way cost_centre_info
(ModGuts { mg_module = mod,
mg_foreign = for_stubs,
mg_dir_imps = imported_modules })
mkModuleInit way cost_centre_info this_mod foreign_stubs imported_mods
= let
(cc_decls, cc_regs) = mkCostCentreStuff cost_centre_info
register_foreign_exports
= case for_stubs of
= case foreign_stubs of
NoStubs -> []
ForeignStubs _ _ _ fe_bndrs -> map mk_export_register fe_bndrs
......@@ -134,12 +142,12 @@ mkModuleInit way cost_centre_info
CLbl (mkModuleInitLabel mod way) AddrRep
]
register_mod_imports = map mk_import_register imported_modules
register_mod_imports = map mk_import_register imported_mods
in
mkAbstractCs [
cc_decls,
CModuleInitBlock (mkPlainModuleInitLabel mod)
(mkModuleInitLabel mod way)
CModuleInitBlock (mkPlainModuleInitLabel this_mod)
(mkModuleInitLabel this_mod way)
(mkAbstractCs (register_foreign_exports ++
cc_regs :
register_mod_imports))
......
......@@ -26,7 +26,7 @@ import Id ( mkSysLocal, idType, idNewDemandInfo, idArity,
isLocalId, hasNoBinding, idNewStrictness,
idUnfolding, isDataConWorkId_maybe
)
import HscTypes ( ModGuts(..), ModGuts, typeEnvElts )
import HscTypes ( ModGuts(..), ModGuts, TypeEnv, typeEnvElts )
import BasicTypes ( TopLevelFlag(..), isTopLevel, isNotTopLevel,
RecFlag(..), isNonRec
)
......@@ -97,23 +97,23 @@ any trivial or useless bindings.
-- -----------------------------------------------------------------------------
\begin{code}
corePrepPgm :: DynFlags -> ModGuts -> IO ModGuts
corePrepPgm dflags mod_impl
corePrepPgm :: DynFlags -> [CoreBind] -> TypeEnv -> IO [CoreBind]
corePrepPgm dflags binds types
= do showPass dflags "CorePrep"
us <- mkSplitUniqSupply 's'
let implicit_binds = mkImplicitBinds (mg_types mod_impl)
let implicit_binds = mkImplicitBinds types
-- NB: we must feed mkImplicitBinds through corePrep too
-- so that they are suitably cloned and eta-expanded
binds_out = initUs_ us (
corePrepTopBinds (mg_binds mod_impl) `thenUs` \ floats1 ->
corePrepTopBinds binds `thenUs` \ floats1 ->
corePrepTopBinds implicit_binds `thenUs` \ floats2 ->
returnUs (deFloatTop (floats1 `appOL` floats2))
)
endPass dflags "CorePrep" Opt_D_dump_prep binds_out
return (mod_impl { mg_binds = binds_out })
return binds_out
corePrepExpr :: DynFlags -> CoreExpr -> IO CoreExpr
corePrepExpr dflags expr
......@@ -232,6 +232,19 @@ corePrepTopBinds binds
-- a = g y
-- x* = f a
-- And then x will actually end up case-bound
--
-- What happens to the CafInfo on the floated bindings? By
-- default, all the CafInfos will be set to MayHaveCafRefs,
-- which is safe.
--
-- This might be pessimistic, because eg. s1 & s2
-- might not refer to any CAFs and the GC will end up doing
-- more traversal than is necessary, but it's still better
-- than not floating the bindings at all, because then
-- the GC would have to traverse the structure in the heap
-- instead. Given this, we decided not to try to get
-- the CafInfo on the floated bindings correct, because
-- it looks difficult.
--------------------------------
corePrepTopBind :: CloneEnv -> CoreBind -> UniqSM (CloneEnv, OrdList FloatingBind)
......
......@@ -19,8 +19,9 @@ module CoreTidy (
import CoreSyn
import CoreUtils ( exprArity )
import PprCore ( pprIdRules )
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique, idType, idCoreRules )
import IdInfo ( vanillaIdInfo, setArityInfo,
import Id ( Id, mkUserLocal, idInfo, setIdInfo, idUnique,
idType, idCoreRules )
import IdInfo ( setArityInfo, noCafIdInfo,
newStrictnessInfo, setAllStrictnessInfo,
newDemandInfo, setNewDemandInfo )
import Type ( tidyType, tidyTyVarBndr )
......@@ -50,11 +51,11 @@ tidyBind :: TidyEnv
-> (TidyEnv, CoreBind)
tidyBind env (NonRec bndr rhs)
= tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
= tidyLetBndr env (bndr,rhs) =: \ (env', bndr') ->
(env', NonRec bndr' (tidyExpr env' rhs))
tidyBind env (Rec prs)
= mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
= mapAccumL tidyLetBndr env prs =: \ (env', bndrs') ->
map (tidyExpr env') (map snd prs) =: \ rhss' ->
(env', Rec (zip bndrs' rhss'))
......@@ -135,8 +136,9 @@ tidyLetBndr env (id,rhs)
where
((tidy_env,var_env), new_id) = tidyIdBndr env id
-- We need to keep around any interesting strictness and demand info
-- because later on we may need to use it when converting to A-normal form.
-- We need to keep around any interesting strictness and
-- demand info because later on we may need to use it when
-- converting to A-normal form.
-- eg.
-- f (g x), where f is strict in its argument, will be converted
-- into case (g x) of z -> f z by CorePrep, but only if f still
......@@ -146,9 +148,12 @@ tidyLetBndr env (id,rhs)
-- CorePrep to turn the let into a case.
--
-- Similarly arity info for eta expansion in CorePrep
--
-- CafInfo is NoCafRefs, because this is not a top-level Id.
--
final_id = new_id `setIdInfo` new_info
idinfo = idInfo id
new_info = vanillaIdInfo
new_info = noCafIdInfo -- NB. no CAF refs!
`setArityInfo` exprArity rhs
`setAllStrictnessInfo` newStrictnessInfo idinfo
`setNewDemandInfo` newDemandInfo idinfo
......@@ -168,11 +173,12 @@ tidyIdBndr env@(tidy_env, var_env) id
-- The SrcLoc isn't important now,
-- though we could extract it from the Id
--
-- All nested Ids now have the same IdInfo, namely none,
-- All nested Ids now have the same IdInfo, namely noCafIdInfo,
-- which should save some space.
-- But note that tidyLetBndr puts some of it back.
ty' = tidyType env (idType id)
id' = mkUserLocal occ' (idUnique id) ty' noSrcLoc
`setIdInfo` noCafIdInfo
var_env' = extendVarEnv var_env id id'
in
((tidy_env', var_env'), id')
......@@ -182,5 +188,3 @@ tidyIdBndr env@(tidy_env, var_env) id
\begin{code}
m =: k = m `seq` k m
\end{code}
......@@ -32,7 +32,13 @@ module CoreUtils (
hashExpr,
-- Equality
cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg
cheapEqExpr, eqExpr, applyTypeToArgs, applyTypeToArg,
-- CAF info
hasCafRefs, rhsIsNonUpd,
-- Cross-DLL references
isCrossDllConApp,
) where
#include "HsVersions.h"
......@@ -44,18 +50,22 @@ import CoreSyn
import PprCore ( pprCoreExpr )
import Var ( Var, isId, isTyVar )
import VarEnv
import Name ( hashName )
import Literal ( hashLiteral, literalType, litIsDupable, litIsTrivial, isZeroLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys, isExistentialDataCon, dataConTyCon )
import Name ( hashName, isDllName )
import Literal ( hashLiteral, literalType, litIsDupable,
litIsTrivial, isZeroLit, isLitLitLit )
import DataCon ( DataCon, dataConRepArity, dataConArgTys,
isExistentialDataCon, dataConTyCon, dataConName )
import PrimOp ( PrimOp(..), primOpOkForSpeculation, primOpIsCheap )
import Id ( Id, idType, globalIdDetails, idNewStrictness,
mkWildId, idArity, idName, idUnfolding, idInfo, isOneShotLambda,
isDataConWorkId_maybe, mkSysLocal, isDataConWorkId, isBottomingId
mkWildId, idArity, idName, idUnfolding, idInfo,
isOneShotLambda, isDataConWorkId_maybe, mkSysLocal,
isDataConWorkId, isBottomingId, idCafInfo
)
import IdInfo ( GlobalIdDetails(..),
megaSeqIdInfo )
import IdInfo ( GlobalIdDetails(..), megaSeqIdInfo,
CafInfo(..), mayHaveCafRefs )
import NewDemand ( appIsBottom )
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe, splitFunTy,
import Type ( Type, mkFunTy, mkForAllTy, splitFunTy_maybe,
splitFunTy,
applyTys, isUnLiftedType, seqType, mkTyVarTy,
splitForAllTy_maybe, isForAllTy, splitNewType_maybe,
splitTyConApp_maybe, eqType, funResultTy, applyTy,
......@@ -70,6 +80,7 @@ import Outputable
import TysPrim ( alphaTy ) -- Debugging only
import Util ( equalLength, lengthAtLeast )
import TysPrim ( statePrimTyCon )
import FastTypes hiding ( fastOr )
\end{code}
......@@ -1128,3 +1139,142 @@ fast_hash_expr other = 1
hashId :: Id -> Int
hashId id = hashName (idName id)
\end{code}
%************************************************************************
%* *
\subsection{Cross-DLL references}
%* *
%************************************************************************
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.
We also catch lit-lit arguments here, because those cannot be used in
static constructors either. (litlits are deprecated, so I'm not going
to bother cleaning up this infelicity --SDM).
\begin{code}
isCrossDllConApp :: DataCon -> [CoreExpr] -> Bool
isCrossDllConApp con args =
isDllName (dataConName con) || any isCrossDllArg args
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}
%************************************************************************
%* *
\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 :: (Var -> Bool) -> Arity -> CoreExpr -> CafInfo
hasCafRefs p arity expr
| is_caf || mentions_cafs = MayHaveCafRefs
| otherwise = NoCafRefs
where
mentions_cafs = isFastTrue (cafRefs p expr)
is_caf = not (arity > 0 || rhsIsNonUpd expr)
-- NB. we pass in the arity of the expression, which is expected
-- to be calculated by exprArity. This is because exprArity
-- knows how much eta expansion is going to be done by
-- CorePrep later on, and we don't want to duplicate that
-- knowledge in rhsIsNonUpd below.
cafRefs p (Var id)
| isId id && p id = fastBool (mayHaveCafRefs (idCafInfo id))
| otherwise = fastBool False
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 :: CoreExpr -> Bool
-- True => Value-lambda, saturated constructor
-- 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
--
-- c) don't look through unfolding of f in (f x).
--
-- 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
-- saturated constructors are not updatable
| Just con <- isDataConWorkId_maybe id,
n_val_args == dataConRepArity con,
not (isCrossDllConApp con args),
all exprIsAtom args
= True
-- NB. args sometimes not atomic. eg.
-- x = D# (1.0## /## 2.0##)
-- can't float because /## can fail.
| otherwise = False
-- Historical note: we used to make partial applications
-- non-updatable, so they behaved just like PAPs, but this
-- doesn't work too well with eval/apply so it is disabled
-- now.
\end{code}
......@@ -32,7 +32,7 @@ import IdInfo ( IdInfo, megaSeqIdInfo,
arityInfo, ppArityInfo,
specInfo, pprNewStrictness,
workerInfo, ppWorkerInfo,
newStrictnessInfo,
newStrictnessInfo, cafInfo, ppCafInfo,
#ifdef OLD_STRICTNESS
cprInfo, ppCprInfo,
strictnessInfo, ppStrictnessInfo,
......@@ -321,6 +321,7 @@ ppIdInfo :: Id -> IdInfo -> SDoc
ppIdInfo b info
= hsep [ ppArityInfo a,
ppWorkerInfo (workerInfo info),
ppCafInfo (cafInfo info),
#ifdef OLD_STRICTNESS
ppStrictnessInfo s,
ppCprInfo m,
......