import CmdLineOpts ( DynFlags, DynFlag(..), opt_OmitInterfacePragmas )
import CoreSyn
import CoreUnfold ( noUnfolding, mkTopUnfolding, okToUnfoldInHiFile )
-import CoreUtils ( exprArity )
+import CoreUtils ( exprArity, exprIsBottom )
import CoreFVs ( ruleSomeFreeVars, exprSomeFreeVars )
import CoreLint ( showPass, endPass )
import VarEnv
import VarSet
import Var ( Id, Var )
import Id ( idType, idInfo, idName, isExportedId,
- mkId, isLocalId, omitIfaceSigForId
+ idCafInfo, mkId, isLocalId, omitIfaceSigForId,
+ idFlavour, modifyIdInfo
)
-import IdInfo ( IdInfo, mkIdInfo, vanillaIdInfo,
- IdFlavour(..), flavourInfo, ppFlavourInfo,
- specInfo, setSpecInfo,
- cprInfo, setCprInfo,
- inlinePragInfo, setInlinePragInfo, isNeverInlinePrag,
- strictnessInfo, setStrictnessInfo,
- isBottomingStrictness,
- unfoldingInfo, setUnfoldingInfo,
- occInfo, isLoopBreaker,
- workerInfo, setWorkerInfo, WorkerInfo(..),
- ArityInfo(..), setArityInfo
- )
+import IdInfo {- loads of stuff -}
import Name ( getOccName, nameOccName, globaliseName, setNameOcc,
localiseName, mkLocalName, isGlobalName
)
import OccName ( TidyOccEnv, initTidyOccEnv, tidyOccName )
import Type ( tidyTopType, tidyType, tidyTyVar )
import Module ( Module, moduleName )
-import HscTypes ( PersistentCompilerState( pcs_PRS ), PersistentRenamerState( prsOrig ),
+import PrimOp ( PrimOp(..), setCCallUnique )
+import HscTypes ( PersistentCompilerState( pcs_PRS ),
+ PersistentRenamerState( prsOrig ),
OrigNameEnv( origNames ), OrigNameNameEnv
)
import UniqSupply
import SrcLoc ( noSrcLoc )
import UniqFM ( mapUFM )
import Outputable
+import FastTypes
import List ( partition )
import Util ( mapAccumL )
\end{code}
tidyTopBind mod ext_ids env (NonRec bndr rhs)
= ((us2,orig,occ,subst) , NonRec bndr' rhs')
where
- tidy_env = (occ,subst)
- ((us1,orig,occ,subst), bndr') = tidyTopBinder mod ext_ids tidy_env rhs' env bndr
- (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
+ ((us1,orig,occ,subst), bndr')
+ = tidyTopBinder mod ext_ids tidy_env rhs' caf_info env bndr
+ tidy_env = (occ,subst)
+ caf_info = hasCafRefs (const True) rhs'
+ (rhs',us2) = initUs us1 (tidyExpr tidy_env rhs)
tidyTopBind mod ext_ids env (Rec prs)
= (final_env, Rec prs')
do_one env (bndr,rhs)
= ((us',orig,occ,subst), (bndr',rhs'))
where
- ((us,orig,occ,subst), bndr') = tidyTopBinder mod ext_ids final_tidy_env rhs' env bndr
- (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
+ ((us,orig,occ,subst), bndr')
+ = tidyTopBinder mod ext_ids final_tidy_env rhs' caf_info env bndr
+ (rhs', us') = initUs us (tidyExpr final_tidy_env rhs)
+
+ -- the CafInfo for a recursive group says whether *any* rhs in
+ -- the group may refer indirectly to a CAF (because then, they all do).
+ (bndrs, rhss) = unzip prs'
+ caf_info = hasCafRefss pred rhss
+ pred v = v `notElem` bndrs
+
tidyTopBinder :: Module -> IdEnv Bool
- -> TidyEnv -> CoreExpr -- The TidyEnv is used to tidy the IdInfo
- -- The expr is the already-tided RHS
- -- Both are knot-tied: don't look at them!
+ -> TidyEnv -> CoreExpr -> CafInfo
+ -- The TidyEnv is used to tidy the IdInfo
+ -- The expr is the already-tided RHS
+ -- Both are knot-tied: don't look at them!
-> TopTidyEnv -> Id -> (TopTidyEnv, Id)
-tidyTopBinder mod ext_ids tidy_env rhs
+
+tidyTopBinder mod ext_ids tidy_env rhs caf_info
env@(us, orig_env2, occ_env2, subst_env2) id
| omitIfaceSigForId id -- Don't mess with constructors,
(idName id)
ty' = tidyTopType (idType id)
idinfo' = tidyIdInfo us_l tidy_env
- is_external unfold_info arity_info id
+ is_external unfold_info arity_info caf_info id
id' = mkId name' ty' idinfo'
subst_env' = extendVarEnv subst_env2 id id'
arity_info = exprArity rhs
-tidyIdInfo us tidy_env is_external unfold_info arity_info id
+tidyIdInfo us tidy_env is_external unfold_info arity_info caf_info id
| opt_OmitInterfacePragmas || not is_external
-- No IdInfo if the Id isn't external, or if we don't have -O
= mkIdInfo new_flavour
`setStrictnessInfo` strictnessInfo core_idinfo
`setArityInfo` ArityExactly arity_info
- -- Keep strictness and arity info; it's used by the code generator
+ `setCafInfo` caf_info
+ -- Keep strictness, arity and CAF info; it's used by the code generator
| otherwise
= let (rules', _) = initUs us (tidyRules tidy_env (specInfo core_idinfo))
`setWorkerInfo` tidyWorker tidy_env (workerInfo core_idinfo)
`setSpecInfo` rules'
`setArityInfo` ArityExactly arity_info
+ `setCafInfo` caf_info
-- this is the final IdInfo, it must agree with the
-- code finally generated (i.e. NO more transformations
-- after this!).
mapUs (tidyExpr env') (map snd prs) `thenUs` \ rhss' ->
returnUs (env', Rec (zip bndrs' rhss'))
-tidyExpr env (Var v) = returnUs (Var (tidyVarOcc env v))
+tidyExpr env (Var v)
+ = fiddleCCall v `thenUs` \ v ->
+ returnUs (Var (tidyVarOcc env v))
+
tidyExpr env (Type ty) = returnUs (Type (tidyType env ty))
tidyExpr env (Lit lit) = returnUs (Lit lit)
tidyBndr :: TidyEnv -> Var -> UniqSM (TidyEnv, Var)
tidyBndr env var
| isTyVar var = returnUs (tidyTyVar env var)
- | otherwise = tidyId env var vanillaIdInfo
+ | otherwise = tidyId env var (vanillaIdInfo `setCafInfo` NoCafRefs)
tidyBndrs :: TidyEnv -> [Var] -> UniqSM (TidyEnv, [Var])
tidyBndrs env vars = mapAccumLUs tidyBndr env vars
= tidyId env id idinfo
where
idinfo = vanillaIdInfo `setArityInfo` ArityExactly (exprArity rhs)
+ `setCafInfo` NoCafRefs
-- NB: This throws away the IdInfo of the Id, which we
-- no longer need. That means we don't need to
-- run over it with env, nor renumber it.
var_env' = extendVarEnv var_env id id'
in
returnUs ((tidy_env', var_env'), id')
+
+
+fiddleCCall id
+ = case idFlavour id of
+ PrimOpId (CCallOp ccall) ->
+ -- Make a guaranteed unique name for a dynamic ccall.
+ getUniqueUs `thenUs` \ uniq ->
+ returnUs (modifyIdInfo (`setFlavourInfo`
+ PrimOpId (CCallOp (setCCallUnique ccall uniq))) id)
+ other_flavour ->
+ returnUs id
+\end{code}
+
+%************************************************************************
+%* *
+\subsection{Figuring out CafInfo for an expression}
+%* *
+%************************************************************************
+
+\begin{code}
+hasCafRefs :: (Id -> Bool) -> CoreExpr -> CafInfo
+hasCafRefss :: (Id -> Bool) -> [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 = if isCAF expr || isFastTrue (cafRefs p expr)
+ then MayHaveCafRefs
+ else NoCafRefs
+
+hasCafRefss p exprs = if any isCAF exprs || isFastTrue (cafRefss p exprs)
+ then MayHaveCafRefs
+ else NoCafRefs
+
+cafRefs p (Var id)
+ | p id
+ = case idCafInfo id of
+ NoCafRefs -> fastBool False
+ MayHaveCafRefs -> fastBool True
+ | otherwise
+ = fastBool False
+
+cafRefs p (Lit l) = fastBool False
+cafRefs p (App f a) = cafRefs p f `fastOr` cafRefs p a
+cafRefs p (Lam x e) = cafRefs p e
+cafRefs p (Let b e) = cafRefss p (rhssOfBind b) `fastOr` cafRefs p e
+cafRefs p (Case e bndr alts) = cafRefs p e `fastOr` 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) = cafRefs p e `fastOr` cafRefss p es
+
+-- Decide whether a closure looks like a CAF or not. In an effort to
+-- keep the number of CAFs (and hence the size of the SRTs) down, we
+-- would also like to 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, we need to use an additional CAF list to keep track of
+-- non-collectable CAFs.
+--
+-- We mark real CAFs as `MayHaveCafRefs' because this information is used
+-- to decide whether a particular closure needs to be referenced in an
+-- SRT or not.
+
+isCAF :: CoreExpr -> Bool
+ -- special case for expressions which are always bottom,
+ -- such as 'error "..."'. We don't need to record it as
+ -- a CAF, since it can only be entered once.
+isCAF e
+ | not_function && is_bottom = False
+ | not_function && updatable = True
+ | otherwise = False
+ where
+ not_function = exprArity e == 0
+ is_bottom = exprIsBottom e
+ updatable = True {- ToDo: check type for onceness? -}
\end{code}
\begin{code}
module SRT where
-import Id ( Id, setIdCafInfo, idCafInfo, externallyVisibleId )
-import CoreUtils ( idAppIsBottom )
+#include "HsVersions.h"
+
+import Id ( Id, idCafInfo )
import IdInfo ( CafInfo(..) )
import StgSyn
\begin{code}
computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
-computeSRTs binds = srtBinds emptyUFM binds
-\end{code}
-
-\begin{code}
-srtBinds :: UniqFM CafInfo -> [StgBinding] -> [(StgBinding,[Id])]
-srtBinds rho [] = []
-srtBinds rho (b:bs) =
- srtTopBind rho b =: \(b, srt, rho) ->
- (b,srt) : srtBinds rho bs
+computeSRTs binds = map srtTopBind binds
\end{code}
-----------------------------------------------------------------------------
-Circular algorithm for simultaneously figuring out CafInfo and SRT
-layout.
+Algorithm for figuring out SRT layout.
Our functions have type
- :: UniqFM CafInfo -- which top-level ids don't refer to any CAfs
- -> SrtOffset -- next free offset within the SRT
+ :: SrtOffset -- next free offset within the SRT
-> (UniqSet Id, -- global refs in the continuation
UniqFM (UniqSet Id))-- global refs in let-no-escaped variables
{- * -} -> StgExpr -- expression to analyse
-> (StgExpr, -- (e) newly annotated expression
- UniqSet Id, -- (g) set of *all* global references
+ UniqSet Id, -- (g) global refs from this expression
[Id], -- (s) SRT required for this expression
SrtOffset) -- (o) new offset
(g) is a set containing all local top-level and imported ids referred
-to by the expression (e).
-
-The set of all global references is used to build the environment,
-which is passed in again. The environment is used to build the final
-SRT.
+to by the expression (e), which have MayHaveCafRefs in their CafInfo.
We build a single SRT for a recursive binding group, which is why the
SRT building is done at the binding level rather than the
StgRhsClosure level.
-Hence, the only argument which we can look at before returning is the
-expression (marked with {- * -} above).
-
The SRT is built up in reverse order, to avoid too many expensive
appends. We therefore reverse the SRT before returning it, so that
the offsets will be from the beginning of the SRT.
-----------------------------------------------------------------------------
Top-level Bindings
-The environment contains a mapping from local top-level bindings to
-CafInfo. The CafInfo is either
-
- NoCafRefs - indicating that the id is not a CAF and furthermore
- that it doesn't refer, even indirectly, to any CAFs.
-
- MayHaveCafRefs - everything else.
-
A function whose CafInfo is NoCafRefs will have an empty SRT, and its
closure will not appear in the SRT of any other function (unless we're
compiling without optimisation and the CafInfos haven't been emitted
references in it if at all possible.
We collect all the global references for the group, and filter out
-those that are binders in the group and not CAFs themselves. This set
-of references is then used to infer the CafInfo for each of the
-binders in the group. Why is it done this way?
+those that are binders in the group and not CAFs themselves. Why is
+it done this way?
- if all the bindings in the group just refer to each other,
and none of them are CAFs, we'd like to get an empty SRT.
\begin{code}
srtTopBind
- :: UniqFM CafInfo
- -> StgBinding
+ :: StgBinding
-> (StgBinding, -- the new binding
- [Id], -- the SRT for this binding
- UniqFM CafInfo) -- the new environment
+ [Id]) -- the SRT for this binding
-srtTopBind rho (StgNonRec binder rhs) =
+srtTopBind (StgNonRec binder rhs) =
-- no need to use circularity for non-recursive bindings
- srtRhs rho (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
+ srtRhs (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
=: \(rhs, g, srt, off) ->
let
- filtered_g = filter (mayHaveCafRefs rho) (uniqSetToList g)
- caf_info = mk_caf_info rhs filtered_g
- binder' = setIdCafInfo binder caf_info
- rho' = addToUFM rho binder' caf_info
+ filtered_g = uniqSetToList g
extra_refs = filter (`notElem` srt) filtered_g
bind_srt = reverse (extra_refs ++ srt)
in
+ ASSERT2(null bind_srt || mayHaveCafRefs binder, ppr binder)
+
case rhs of
StgRhsClosure _ _ _ _ _ _ _ ->
- (StgNonRec binder' (attach_srt_rhs rhs 0 (length bind_srt)),
- bind_srt, rho')
+ (StgNonRec binder (attach_srt_rhs rhs 0 (length bind_srt)),
+ bind_srt)
- -- don't output an SRT for the constructor, but just remember
- -- whether it had any caf references or not.
- StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
+ -- don't output an SRT for the constructor
+ StgRhsCon _ _ _ -> (StgNonRec binder rhs, [])
-srtTopBind rho (StgRec bs) =
- (attach_srt_bind (StgRec (reverse new_bs')) 0 (length bind_srt),
- bind_srt, rho')
+srtTopBind (StgRec bs) =
+ ASSERT(null bind_srt || all mayHaveCafRefs binders)
+ (attach_srt_bind (StgRec new_bs) 0 (length bind_srt), bind_srt)
where
(binders,rhss) = unzip bs
non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
- -- circular: rho' is calculated from g below
(new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
-- filter out ourselves from the global references: it makes no
-- sense to refer recursively to our SRT unless the recursive
-- reference is required by a nested SRT.
- filtered_g = filter (\id -> id `notElem` non_caf_binders &&
- mayHaveCafRefs rho id) (uniqSetToList g)
+ filtered_g = filter (\id -> id `notElem` non_caf_binders) (uniqSetToList g)
extra_refs = filter (`notElem` srt) filtered_g
bind_srt = reverse (extra_refs ++ srt)
- caf_infos = map (\rhs -> mk_caf_info rhs filtered_g) rhss
- rho' = addListToUFM rho (zip binders caf_infos)
- binders' = zipWith setIdCafInfo binders caf_infos
-
- new_bs' = zip binders' (map snd new_bs)
doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
doBinds ((binder,rhs):binds) new_binds g srt off =
- srtRhs rho' (emptyUniqSet,emptyUFM) off rhs
+ srtRhs (emptyUniqSet,emptyUFM) off rhs
=: \(rhs, rhs_g, rhs_srt, off) ->
let
g' = unionUniqSets rhs_g g
Non-top-level bindings
\begin{code}
-srtBind :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
+srtBind :: (UniqSet Id, UniqFM (UniqSet Id))
-> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
-srtBind rho cont_refs off (StgNonRec binder rhs) =
- srtRhs rho cont_refs off rhs =: \(rhs, g, srt, off) ->
+srtBind cont_refs off (StgNonRec binder rhs) =
+ srtRhs cont_refs off rhs =: \(rhs, g, srt, off) ->
(StgNonRec binder rhs, g, srt, off)
-srtBind rho cont_refs off (StgRec binds) =
- (StgRec new_binds, g, srt, new_off)
+srtBind cont_refs off (StgRec binds) =
+ (StgRec new_binds, g, srt, new_off)
where
-- process each binding
(new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
doBinds ((binder,rhs):binds) g srt off new_binds =
- srtRhs rho cont_refs off rhs =: \(rhs, g', srt', off) ->
+ srtRhs cont_refs off rhs =: \(rhs, g', srt', off) ->
doBinds binds (unionUniqSets g g') (srt'++srt) off
((binder,rhs):new_binds)
\end{code}
Right Hand Sides
\begin{code}
-srtRhs :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
+srtRhs :: (UniqSet Id, UniqFM (UniqSet Id))
-> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
-srtRhs rho cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
- srtExpr rho cont off body =: \(body, g, srt, off) ->
+srtRhs cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
+ srtExpr cont off body =: \(body, g, srt, off) ->
(StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
-srtRhs rho cont off e@(StgRhsCon cc con args) =
- (e, getGlobalRefs rho args, [], off)
+srtRhs cont off e@(StgRhsCon cc con args) =
+ (e, getGlobalRefs args, [], off)
\end{code}
-----------------------------------------------------------------------------
Expressions
\begin{code}
-srtExpr :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
+srtExpr :: (UniqSet Id, UniqFM (UniqSet Id))
-> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
-srtExpr rho (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
+srtExpr (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
where global_refs =
cont `unionUniqSets`
- getGlobalRefs rho (StgVarArg f:args) `unionUniqSets`
+ getGlobalRefs (StgVarArg f:args) `unionUniqSets`
lookupPossibleLNE lne f
-srtExpr rho (cont,lne) off e@(StgLit l) = (e, cont, [], off)
+srtExpr (cont,lne) off e@(StgLit l) = (e, cont, [], off)
-srtExpr rho (cont,lne) off e@(StgConApp con args) =
- (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
+srtExpr (cont,lne) off e@(StgConApp con args) =
+ (e, cont `unionUniqSets` getGlobalRefs args, [], off)
-srtExpr rho (cont,lne) off e@(StgPrimApp op args ty) =
- (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
+srtExpr (cont,lne) off e@(StgPrimApp op args ty) =
+ (e, cont `unionUniqSets` getGlobalRefs args, [], off)
-srtExpr rho c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
- srtCaseAlts rho c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
+srtExpr c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
+ srtCaseAlts c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
-- construct the SRT for this case
- let (this_srt, scrut_off) = construct_srt rho alts_g alts_srt alts_off in
+ let (this_srt, scrut_off) = construct_srt alts_g alts_srt alts_off in
-- global refs in the continuation is alts_g.
- srtExpr rho (alts_g,lne) scrut_off scrut
+ srtExpr (alts_g,lne) scrut_off scrut
=: \(scrut, scrut_g, scrut_srt, case_off) ->
let
g = unionUniqSets alts_g scrut_g
in
(StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
-srtExpr rho cont off (StgLet bind body) =
- srtLet rho cont off bind body StgLet (\_ cont -> cont)
+srtExpr cont off (StgLet bind body) =
+ srtLet cont off bind body StgLet (\_ cont -> cont)
-srtExpr rho cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
- = srtLet rho cont off b body (StgLetNoEscape live1 live2) calc_cont
+srtExpr cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
+ = srtLet cont off b body (StgLetNoEscape live1 live2) calc_cont
where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g)
-- for recursive let-no-escapes, we do *two* passes, the first time
-- just to extract the list of global refs, and the second time we actually
-- construct the SRT now that we know what global refs should be in
-- the various let-no-escape continuations.
-srtExpr rho conts@(cont,lne) off
+srtExpr conts@(cont,lne) off
(StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
- = srtBind rho conts off bind =: \(_, g, _, _) ->
+ = srtBind conts off bind =: \(_, g, _, _) ->
let
lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
calc_cont _ conts = conts
in
- srtLet rho (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
+ srtLet (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
-srtExpr rho cont off (StgSCC cc expr) =
- srtExpr rho cont off expr =: \(expr, g, srt, off) ->
+srtExpr cont off (StgSCC cc expr) =
+ srtExpr cont off expr =: \(expr, g, srt, off) ->
(StgSCC cc expr, g, srt, off)
#ifdef DEBUG
-srtExpr rho cont off expr = pprPanic "srtExpr" (ppr expr)
+srtExpr cont off expr = pprPanic "srtExpr" (ppr expr)
#else
-srtExpr rho cont off expr = panic "srtExpr"
+srtExpr cont off expr = panic "srtExpr"
#endif
\end{code}
This is quite complicated stuff...
\begin{code}
-srtLet rho cont off bind body let_constr calc_cont
+srtLet cont off bind body let_constr calc_cont
-- If the bindings are all constructors, then we don't need to
-- buid an SRT at all...
| all_con_binds bind =
- srtBind rho cont off bind =: \(bind, bind_g, bind_srt, off) ->
- srtExpr rho cont off body =: \(body, body_g, body_srt, off) ->
+ srtBind cont off bind =: \(bind, bind_g, bind_srt, off) ->
+ srtExpr cont off body =: \(body, body_g, body_srt, off) ->
let
g = unionUniqSets bind_g body_g
srt = body_srt ++ bind_srt
| otherwise =
-- first, find the sub-SRTs in the binding
- srtBind rho cont off bind =: \(bind, bind_g, bind_srt, bind_off) ->
+ srtBind cont off bind =: \(bind, bind_g, bind_srt, bind_off) ->
-- construct the SRT for this binding
- let (this_srt, body_off) = construct_srt rho bind_g bind_srt bind_off in
+ let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in
-- get the new continuation information (if a let-no-escape)
let new_cont = calc_cont bind_g cont in
-- now find the SRTs in the body
- srtExpr rho new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
+ srtExpr new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
let
-- union all the global references together
which are "live").
\begin{code}
-construct_srt rho global_refs sub_srt current_offset
+construct_srt global_refs sub_srt current_offset
= let
- extra_refs = filter (`notElem` sub_srt)
- (filter (mayHaveCafRefs rho) (uniqSetToList global_refs))
+ extra_refs = filter (`notElem` sub_srt) (uniqSetToList global_refs)
this_srt = extra_refs ++ sub_srt
-- Add the length of the new entries to the
Case Alternatives
\begin{code}
-srtCaseAlts :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
+srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id))
-> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
-srtCaseAlts rho cont off (StgAlgAlts t alts dflt) =
- srtAlgAlts rho cont off alts [] emptyUniqSet []
+srtCaseAlts cont off (StgAlgAlts t alts dflt) =
+ srtAlgAlts cont off alts [] emptyUniqSet []
=: \(alts, alts_g, alts_srt, off) ->
- srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
+ srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
let
g = unionUniqSets alts_g dflt_g
srt = dflt_srt ++ alts_srt
in
(StgAlgAlts t alts dflt, g, srt, off)
-srtCaseAlts rho cont off (StgPrimAlts t alts dflt) =
- srtPrimAlts rho cont off alts [] emptyUniqSet []
+srtCaseAlts cont off (StgPrimAlts t alts dflt) =
+ srtPrimAlts cont off alts [] emptyUniqSet []
=: \(alts, alts_g, alts_srt, off) ->
- srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
+ srtDefault cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
let
g = unionUniqSets alts_g dflt_g
srt = dflt_srt ++ alts_srt
in
(StgPrimAlts t alts dflt, g, srt, off)
-srtAlgAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtAlgAlts rho cont off ((con,args,used,rhs):alts) new_alts g srt =
- srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+srtAlgAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
+srtAlgAlts cont off ((con,args,used,rhs):alts) new_alts g srt =
+ srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
let
g' = unionUniqSets rhs_g g
srt' = rhs_srt ++ srt
in
- srtAlgAlts rho cont off alts ((con,args,used,rhs) : new_alts) g' srt'
+ srtAlgAlts cont off alts ((con,args,used,rhs) : new_alts) g' srt'
-srtPrimAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtPrimAlts rho cont off ((lit,rhs):alts) new_alts g srt =
- srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+srtPrimAlts cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
+srtPrimAlts cont off ((lit,rhs):alts) new_alts g srt =
+ srtExpr cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
let
g' = unionUniqSets rhs_g g
srt' = rhs_srt ++ srt
in
- srtPrimAlts rho cont off alts ((lit,rhs) : new_alts) g' srt'
+ srtPrimAlts cont off alts ((lit,rhs) : new_alts) g' srt'
-srtDefault rho cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
-srtDefault rho cont off (StgBindDefault rhs) =
- srtExpr rho cont off rhs =: \(rhs, g, srt, off) ->
+srtDefault cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
+srtDefault cont off (StgBindDefault rhs) =
+ srtExpr cont off rhs =: \(rhs, g, srt, off) ->
(StgBindDefault rhs, g, srt, off)
\end{code}
-----------------------------------------------------------------------------
-Decide whether a closure looks like a CAF or not. In an effort to
-keep the number of CAFs (and hence the size of the SRTs) down, we
-would also like to 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, we need to use an additional CAF list to keep track of
-non-collectable CAFs.
-
-We mark real CAFs as `MayHaveCafRefs' because this information is used
-to decide whether a particular closure needs to be referenced in an
-SRT or not.
-
-\begin{code}
-mk_caf_info
- :: StgRhs -- right-hand-side of the definition
- -> [Id] -- static references
- -> CafInfo
-
--- special case for expressions which are always bottom,
--- such as 'error "..."'. We don't need to record it as
--- a CAF, since it can only be entered once.
-mk_caf_info (StgRhsClosure _ _ _ free_vars _ [] e) srt
- | isBottomingExpr e && null srt = NoCafRefs
-
-mk_caf_info (StgRhsClosure _ _ _ free_vars upd args body) srt
- | isUpdatable upd = MayHaveCafRefs -- a real live CAF
- | null srt = NoCafRefs -- function w/ no static references
- | otherwise = MayHaveCafRefs -- function w/ some static references
-
-mk_caf_info rcon@(StgRhsCon cc con args) srt
- | null srt = NoCafRefs -- constructor w/ no static references
- | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
-
-
-isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
-isBottomingExpr (StgApp f args) = idAppIsBottom f (length args)
-isBottomingExpr _ = False
-\end{code}
-
------------------------------------------------------------------------------
-
Here we decide which Id's to place in the static reference table. An
internal top-level id will be in the environment with the appropriate
CafInfo, so we use that if available. An imported top-level Id will
have the CafInfo attached. Otherwise, we just ignore the Id.
\begin{code}
-getGlobalRefs :: UniqFM CafInfo -> [StgArg] -> UniqSet Id
-getGlobalRefs rho args = mkUniqSet (concat (map (globalRefArg rho) args))
-
-globalRefArg :: UniqFM CafInfo -> StgArg -> [Id]
-
-globalRefArg rho (StgVarArg id)
-
- | otherwise =
- case lookupUFM rho id of {
- Just _ -> [id]; -- Can't look at the caf_info yet...
- Nothing -> -- but we will look it up and filter later
- -- in maybeHaveCafRefs
-
- if externallyVisibleId id
- then case idCafInfo id of
- MayHaveCafRefs -> [id]
- NoCafRefs -> []
- else []
- }
-
-globalRefArg rho _ = []
-\end{code}
-
-\begin{code}
-mayHaveCafRefs rho id =
- case lookupUFM rho id of
- Just MayHaveCafRefs -> True
- Just NoCafRefs -> False
- Nothing -> True
+getGlobalRefs :: [StgArg] -> UniqSet Id
+getGlobalRefs args = mkUniqSet (concat (map globalRefArg args))
+
+globalRefArg :: StgArg -> [Id]
+globalRefArg (StgVarArg id)
+ | mayHaveCafRefs id = [id]
+ | otherwise = []
+globalRefArg _ = []
+
+mayHaveCafRefs id
+ = case idCafInfo id of
+ MayHaveCafRefs -> True
+ NoCafRefs -> False
\end{code}
-----------------------------------------------------------------------------
FIX:
-The following code fixes up a let-no-escape expression after we've run
-the SRT algorithm. It needs to know the SRT for the *whole*
-expression (this is plugged in instead of the SRT for case exprsesions
-in the body). The good news is that we only need to traverse nested
-case expressions, since the let-no-escape bound variable can't occur
-in the rhs of a let or in a case scrutinee.
-
-For recursive let-no-escapes, the body is processed as for
-non-recursive let-no-escapes, but case expressions in the rhs of each
-binding have their SRTs replaced with the SRT for the binding group
-(*not* the SRT of the whole let-no-escape expression).
+We keep track of the global references made by each let-no-escape in
+scope, so we can expand them every time the let-no-escape is
+referenced.
\begin{code}
lookupPossibleLNE lne_env f =
projects / ghc-hetmet.git / commitdiff