\begin{code}
module SRT where
-import Id ( Id, setIdCafInfo, getIdCafInfo, externallyVisibleId,
- isBottomingId )
-import IdInfo ( CafInfo(..) )
+#include "HsVersions.h"
+
+import Id ( Id, idCafInfo )
+import IdInfo ( CafInfo(..) )
import StgSyn
import UniqFM
import UniqSet
-\end{code}
+import Panic
-\begin{code}
-computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
-computeSRTs binds = srtBinds emptyUFM binds
+#ifdef DEBUG
+import Outputable
+#endif
\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 :: [StgBinding] -> [(StgBinding,[Id])]
+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 0{-initial offset-} rhs =: \(rhs, g, srt, off) ->
+ 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' off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
+ srtRhs (emptyUniqSet,emptyUFM) off rhs
+ =: \(rhs, rhs_g, rhs_srt, off) ->
let
g' = unionUniqSets rhs_g g
srt' = rhs_srt ++ srt
Non-top-level bindings
\begin{code}
-srtBind :: UniqFM CafInfo -> Int -> StgBinding
- -> (StgBinding, UniqSet Id, [Id], Int)
+srtBind :: (UniqSet Id, UniqFM (UniqSet Id))
+ -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
-srtBind rho off (StgNonRec binder rhs) =
- srtRhs rho 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 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 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 -> Int -> StgRhs
- -> (StgRhs, UniqSet Id, [Id], Int)
+srtRhs :: (UniqSet Id, UniqFM (UniqSet Id))
+ -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
-srtRhs rho off (StgRhsClosure cc bi old_srt free_vars u args body) =
- srtExpr rho 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 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 -> Int -> StgExpr
- -> (StgExpr, UniqSet Id, [Id], Int)
+srtExpr :: (UniqSet Id, UniqFM (UniqSet Id))
+ -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
-srtExpr rho off e@(StgApp f args) =
- (e, getGlobalRefs rho (StgVarArg f:args), [], off)
+srtExpr (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
+ where global_refs =
+ cont `unionUniqSets`
+ getGlobalRefs (StgVarArg f:args) `unionUniqSets`
+ lookupPossibleLNE lne f
-srtExpr rho off e@(StgCon con args ty) =
- (e, getGlobalRefs rho args, [], off)
+srtExpr (cont,lne) off e@(StgLit l) = (e, cont, [], off)
-srtExpr rho off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
- srtCaseAlts rho off alts =: \(alts, alts_g, alts_srt, alts_off) ->
- let
- extra_refs = filter (`notElem` alts_srt)
- (filter (mayHaveCafRefs rho) (uniqSetToList alts_g))
- this_srt = extra_refs ++ alts_srt
- scrut_off = alts_off + length extra_refs
- in
- srtExpr rho scrut_off scrut =: \(scrut, scrut_g, scrut_srt, case_off) ->
+srtExpr (cont,lne) off e@(StgConApp con args) =
+ (e, cont `unionUniqSets` getGlobalRefs args, [], off)
+
+srtExpr (cont,lne) off e@(StgPrimApp op args ty) =
+ (e, cont `unionUniqSets` getGlobalRefs args, [], 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 alts_g alts_srt alts_off in
+
+ -- global refs in the continuation is alts_g.
+ srtExpr (alts_g,lne) scrut_off scrut
+ =: \(scrut, scrut_g, scrut_srt, case_off) ->
let
g = unionUniqSets alts_g scrut_g
srt = scrut_srt ++ this_srt
in
(StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
-srtExpr rho off (StgLet bind body) =
- srtLet rho off bind body StgLet
-
- -- let-no-escapes are delicate, see below
-srtExpr rho off (StgLetNoEscape live1 live2 bind body) =
- srtLet rho off bind body (StgLetNoEscape live1 live2)
- =: \(expr, g, srt, off') ->
- let
- -- find the SRT for the *whole* expression
- length = off' - off
- all_srt | length == 0 = NoSRT
- | otherwise = SRT off length
- in
- (fixLNE_srt all_srt expr, g, srt, off')
-
-srtExpr rho off (StgSCC cc expr) =
- srtExpr rho off expr =: \(expr, g, srt, off) ->
+srtExpr cont off (StgLet bind body) =
+ srtLet cont off bind body StgLet (\_ cont -> 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 conts@(cont,lne) off
+ (StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
+ = srtBind conts off bind =: \(_, g, _, _) ->
+ let
+ lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
+ calc_cont _ conts = conts
+ in
+ srtLet (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
+
+
+srtExpr cont off (StgSCC cc expr) =
+ srtExpr cont off expr =: \(expr, g, srt, off) ->
(StgSCC cc expr, g, srt, off)
+
+#ifdef DEBUG
+srtExpr cont off expr = pprPanic "srtExpr" (ppr expr)
+#else
+srtExpr cont off expr = panic "srtExpr"
+#endif
\end{code}
-----------------------------------------------------------------------------
This is quite complicated stuff...
\begin{code}
-srtLet rho off bind body let_constr
+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 off bind =: \(bind, bind_g, bind_srt, off) ->
- srtExpr rho 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 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 from its sub-SRTs and any new global
- -- references which aren't already contained in one of the sub-SRTs (and
- -- which are "live").
- let
- extra_refs = filter (`notElem` bind_srt)
- (filter (mayHaveCafRefs rho) (uniqSetToList bind_g))
- this_srt = extra_refs ++ bind_srt
+ -- construct the SRT for this binding
+ let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in
- -- Add the length of the new entries to the
- -- current offset to get the next free offset in the global SRT.
- body_off = bind_off + length extra_refs
- 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 body_off body =: \(body, body_g, body_srt, let_off) ->
+ -- now find the SRTs in the body
+ srtExpr new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
let
-- union all the global references together
\end{code}
-----------------------------------------------------------------------------
+Construct an SRT.
+
+Construct the SRT at this point from its sub-SRTs and any new global
+references which aren't already contained in one of the sub-SRTs (and
+which are "live").
+
+\begin{code}
+construct_srt global_refs sub_srt current_offset
+ = let
+ extra_refs = filter (`notElem` sub_srt) (uniqSetToList global_refs)
+ this_srt = extra_refs ++ sub_srt
+
+ -- Add the length of the new entries to the
+ -- current offset to get the next free offset in the global SRT.
+ new_offset = current_offset + length extra_refs
+ in (this_srt, new_offset)
+\end{code}
+
+-----------------------------------------------------------------------------
Case Alternatives
\begin{code}
-srtCaseAlts :: UniqFM CafInfo -> Int -> StgCaseAlts ->
- (StgCaseAlts, UniqSet Id, [Id], Int)
+srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id))
+ -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
-srtCaseAlts rho off (StgAlgAlts t alts dflt) =
- srtAlgAlts rho off alts [] emptyUniqSet []
+srtCaseAlts cont off (StgAlgAlts t alts dflt) =
+ srtAlgAlts cont off alts [] emptyUniqSet []
=: \(alts, alts_g, alts_srt, off) ->
- srtDefault rho 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 off (StgPrimAlts t alts dflt) =
- srtPrimAlts rho off alts [] emptyUniqSet []
+srtCaseAlts cont off (StgPrimAlts t alts dflt) =
+ srtPrimAlts cont off alts [] emptyUniqSet []
=: \(alts, alts_g, alts_srt, off) ->
- srtDefault rho 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 off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtAlgAlts rho off ((con,args,used,rhs):alts) new_alts g srt =
- srtExpr rho 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 off alts ((con,args,used,rhs) : new_alts) g' srt'
+ srtAlgAlts cont off alts ((con,args,used,rhs) : new_alts) g' srt'
-srtPrimAlts rho off [] new_alts g srt = (reverse new_alts, g, srt, off)
-srtPrimAlts rho off ((lit,rhs):alts) new_alts g srt =
- srtExpr rho 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 off alts ((lit,rhs) : new_alts) g' srt'
+ srtPrimAlts cont off alts ((lit,rhs) : new_alts) g' srt'
-srtDefault rho off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
-srtDefault rho off (StgBindDefault rhs) =
- srtExpr rho 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 (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) = isBottomingId f
-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 ->
-
- if externallyVisibleId id
- then case getIdCafInfo 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}
-fixLNE_srt :: SRT -> StgExpr -> StgExpr
-fixLNE_srt all_srt (StgLetNoEscape live1 live2 (StgNonRec id rhs) body)
- = StgLetNoEscape live1 live2 (StgNonRec id rhs) (fixLNE [id] all_srt body)
-
-fixLNE_srt all_srt (StgLetNoEscape live1 live2 (StgRec pairs) body)
- = StgLetNoEscape live1 live2
- (StgRec (map fixLNE_rec pairs)) (fixLNE binders all_srt body)
- where
- binders = map fst pairs
- fixLNE_rec (id,StgRhsClosure cc bi srt fvs uf args e) =
- (id, StgRhsClosure cc bi srt fvs uf args (fixLNE binders srt e))
- fixLNE_rec (id,con) = (id,con)
-
-fixLNE :: [Id] -> SRT -> StgExpr -> StgExpr
-
-fixLNE ids srt expr@(StgCase scrut live rhs_live bndr old_srt alts)
- | any (`elementOfUniqSet` rhs_live) ids
- = StgCase scrut live rhs_live bndr srt (fixLNE_alts ids srt alts)
- | otherwise = expr
- -- can't be in the scrutinee, because it's a let-no-escape!
-
-fixLNE ids srt expr@(StgLetNoEscape live rhs_live bind body)
- | any (`elementOfUniqSet` rhs_live) ids =
- StgLetNoEscape live rhs_live (fixLNE_bind ids srt bind)
- (fixLNE ids srt body)
- | any (`elementOfUniqSet` live) ids =
- StgLetNoEscape live rhs_live bind (fixLNE ids srt body)
- | otherwise = expr
-
-fixLNE ids srt (StgLet bind body) = StgLet bind (fixLNE ids srt body)
-fixLNE ids srt (StgSCC cc expr) = StgSCC cc (fixLNE ids srt expr)
-fixLNE ids srt expr = expr
-
-fixLNE_alts ids srt (StgAlgAlts t alts dflt)
- = StgAlgAlts t (map (fixLNE_algalt ids srt) alts) (fixLNE_dflt ids srt dflt)
-
-fixLNE_alts ids srt (StgPrimAlts t alts dflt)
- = StgPrimAlts t (map (fixLNE_primalt ids srt) alts) (fixLNE_dflt ids srt dflt)
-
-fixLNE_algalt ids srt (con,args,used,rhs) = (con,args,used, fixLNE ids srt rhs)
-fixLNE_primalt ids srt (lit,rhs) = (lit, fixLNE ids srt rhs)
-
-fixLNE_dflt ids srt (StgNoDefault) = StgNoDefault
-fixLNE_dflt ids srt (StgBindDefault rhs) = StgBindDefault (fixLNE ids srt rhs)
-
-fixLNE_bind ids srt (StgNonRec bndr rhs)
- = StgNonRec bndr (fixLNE_rhs ids srt rhs)
-fixLNE_bind ids srt (StgRec pairs)
- = StgRec [ (bndr, fixLNE_rhs ids srt rhs) | (bndr,rhs) <- pairs ]
-
-fixLNE_rhs ids srt rhs@(StgRhsClosure cc bi old_srt fvs uf args expr)
- | any (`elem` fvs) ids
- = StgRhsClosure cc bi srt fvs uf args (fixLNE ids srt expr)
- | otherwise = rhs
-fixLNE_rhs ids srt rhs@(StgRhsCon cc con args) = rhs
-
+lookupPossibleLNE lne_env f =
+ case lookupUFM lne_env f of
+ Nothing -> emptyUniqSet
+ Just refs -> refs
\end{code}
projects / ghc-hetmet.git / blobdiff