import StgSyn
import Id ( Id )
import VarSet
-import BasicTypes ( TopLevelFlag(..), isTopLevel )
-import Util ( mapAccumL )
+import VarEnv
+import Util ( sortLe )
+import Maybes ( orElse )
+import Maybes ( expectJust )
+import Bitmap ( intsToBitmap )
#ifdef DEBUG
import Outputable
#endif
-\end{code}
-\begin{code}
-computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
- -- The incoming bindingd are filled with SRTEntries in their SRT slots
- -- the outgoing ones have NoSRT/SRT values instead
+import List
-computeSRTs binds = map srtTopBind binds
+import Util
+import Outputable
\end{code}
------------------------------------------------------------------------------
-Algorithm for figuring out SRT layout.
-
-Our functions have type
-
-srtExpr :: SrtOffset -- Next free offset within the SRT
- -> StgExpr -- Expression to analyse
- -> (StgExpr, -- (e) newly annotated expression
- SrtIds, -- (s) SRT required for this expression (reversed)
- SrtOffset) -- (o) new offset
-
-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.
-
-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
-
-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
-in the interface files).
-
-Top-Level recursive groups
-
-This gets a bit complicated, but the general idea is that we want a
-single SRT for the whole group, and we'd rather not have recursive
-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. 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.
-
- - if any of the bindings in the group refer to a CAF, this will
- appear in the SRT.
-
-Hmm, that probably makes no sense.
-
\begin{code}
-type SrtOffset = Int
-type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT
-
-srtTopBind :: StgBinding -> (StgBinding, SrtIds)
-
-srtTopBind bind
- = srtBind TopLevel 0 bind =: \ (bind', srt, off) ->
- if isConBind bind'
- then (bind', []) -- Don't need an SRT for a static constructor
- else (bind', reverse srt) -- The 'reverse' is because the SRT is
- -- built up reversed, for efficiency's sake
+computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])]
+ -- The incoming bindingd are filled with SRTEntries in their SRT slots
+ -- the outgoing ones have NoSRT/SRT values instead
-isConBind (StgNonRec _ _ r) = isConRhs r
-isConBind (StgRec _ bs) = all isConRhs (map snd bs)
+computeSRTs binds = srtTopBinds emptyVarEnv binds
-isConRhs (StgRhsCon _ _ _) = True
-isConRhs _ = False
+-- --------------------------------------------------------------------------
+-- Top-level Bindings
-srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
- -> (StgBinding, SrtIds, SrtOffset)
+srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])]
-srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs)
- = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
+srtTopBinds env [] = []
+srtTopBinds env (StgNonRec b rhs : binds) =
+ (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds
where
- (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs
- (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
-
-
-srtBind top off (StgRec (SRTEntries rhss_cafs) pairs)
- = (StgRec srt_info new_pairs, this_srt, body_off)
+ (rhs', srt) = srtTopRhs b rhs
+ env' = maybeExtendEnv env b rhs
+ srt' = applyEnvList env srt
+srtTopBinds env (StgRec bs : binds) =
+ (StgRec (zip bndrs rhss), zip bndrs srts') : srtTopBinds env binds
+ where
+ (rhss, srts) = unzip [ srtTopRhs b r | (b,r) <- bs ]
+ bndrs = map fst bs
+ srts' = map (applyEnvList env) srts
+
+-- Shorting out indirections in SRTs: if a binding has an SRT with a single
+-- element in it, we just inline it with that element everywhere it occurs
+-- in other SRTs.
+--
+-- This is in a way a generalisation of the CafInfo. CafInfo says
+-- whether a top-level binding has *zero* CAF references, allowing us
+-- to omit it from SRTs. Here, we pick up bindings with *one* CAF
+-- reference, and inline its SRT everywhere it occurs. We could pass
+-- this information across module boundaries too, but we currently
+-- don't.
+
+maybeExtendEnv env bndr (StgRhsClosure _ _ _ ReEntrant (SRTEntries cafs) _ _)
+ | [one] <- varSetElems cafs
+ = extendVarEnv env bndr (applyEnv env one)
+maybeExtendEnv env bndr _ = env
+
+applyEnvList :: IdEnv Id -> [Id] -> [Id]
+applyEnvList env = map (applyEnv env)
+
+applyEnv env id = lookupVarEnv env id `orElse` id
+
+-- ---- Top-level right hand sides:
+
+srtTopRhs :: Id -> StgRhs -> (StgRhs, [Id])
+
+srtTopRhs binder rhs@(StgRhsCon _ _ _) = (rhs, [])
+srtTopRhs binder rhs@(StgRhsClosure _ _ _ _ (SRTEntries cafs) _ _)
+ = (srtRhs table rhs, elems)
where
- ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
+ elems = varSetElems cafs
+ table = mkVarEnv (zip elems [0..])
- do_bind (off,srt) (bndr,rhs)
- = srtRhs off rhs =: \(rhs', srt', off') ->
- ((off', srt'++srt), (bndr, rhs'))
+-- ---- Binds:
- non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
+srtBind :: IdEnv Int -> StgBinding -> StgBinding
- filtered_rhss_cafs
- | isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
- | otherwise = rhss_cafs
+srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs)
+srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ]
- (srt_info, this_srt, body_off)
- = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
+-- ---- Right Hand Sides:
-caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
-caf_rhs _ = False
-\end{code}
+srtRhs :: IdEnv Int -> StgRhs -> StgRhs
------------------------------------------------------------------------------
-Right Hand Sides
+srtRhs table e@(StgRhsCon cc con args) = e
+srtRhs table (StgRhsClosure cc bi free_vars u srt args body)
+ = StgRhsClosure cc bi free_vars u (constructSRT table srt) args
+ $! (srtExpr table body)
-\begin{code}
-srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
+-- ---------------------------------------------------------------------------
+-- Expressions
-srtRhs off (StgRhsClosure cc bi free_vars u args body)
- = srtExpr off body =: \(body, srt, off) ->
- (StgRhsClosure cc bi free_vars u args body, srt, off)
+srtExpr :: IdEnv Int -> StgExpr -> StgExpr
-srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
-\end{code}
+srtExpr table e@(StgApp f args) = e
+srtExpr table e@(StgLit l) = e
+srtExpr table e@(StgConApp con args) = e
+srtExpr table e@(StgOpApp op args ty) = e
------------------------------------------------------------------------------
-Expressions
+srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr
-\begin{code}
-srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
-
-srtExpr off e@(StgApp f args) = (e, [], off)
-srtExpr off e@(StgLit l) = (e, [], off)
-srtExpr off e@(StgConApp con args) = (e, [], off)
-srtExpr off e@(StgOpApp op args ty) = (e, [], off)
-
-srtExpr off (StgSCC cc expr) =
- srtExpr off expr =: \(expr, srt, off) ->
- (StgSCC cc expr, srt, off)
-
-srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
- = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) ->
- let
- (srt_info, this_srt, scrut_off)
- = constructSRT cafs_in_alts alts_srt off alts_off
- in
- srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) ->
-
- (StgCase scrut live1 live2 uniq srt_info alts,
- scrut_srt ++ this_srt,
- case_off)
-
-srtExpr off (StgLet bind body)
- = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
- srtExpr body_off body =: \ (body', expr_srt, let_off) ->
- (StgLet bind' body', expr_srt ++ bind_srt, let_off)
+srtExpr table (StgCase scrut live1 live2 uniq srt alt_type alts)
+ = StgCase expr' live1 live2 uniq srt' alt_type alts'
+ where
+ expr' = srtExpr table scrut
+ srt' = constructSRT table srt
+ alts' = map (srtAlt table) alts
+
+srtExpr table (StgLet bind body)
+ = srtBind table bind =: \ bind' ->
+ srtExpr table body =: \ body' ->
+ StgLet bind' body'
-srtExpr off (StgLetNoEscape live1 live2 bind body)
- = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
- srtExpr body_off body =: \ (body', expr_srt, let_off) ->
- (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)
+srtExpr table (StgLetNoEscape live1 live2 bind body)
+ = srtBind table bind =: \ bind' ->
+ srtExpr table body =: \ body' ->
+ StgLetNoEscape live1 live2 bind' body'
#ifdef DEBUG
-srtExpr off expr = pprPanic "srtExpr" (ppr expr)
+srtExpr table expr = pprPanic "srtExpr" (ppr expr)
#endif
-\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}
-constructSRT caf_refs sub_srt initial_offset current_offset
- = let
- extra_refs = filter (`notElem` sub_srt) (varSetElems caf_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
- srt_length = new_offset - initial_offset
-
- srt_info | srt_length == 0 = NoSRT
- | otherwise = SRT initial_offset srt_length
-
- in ASSERT( srt_length == length this_srt )
- (srt_info, this_srt, new_offset)
-\end{code}
+srtAlt :: IdEnv Int -> StgAlt -> StgAlt
+srtAlt table (con,args,used,rhs)
+ = (,,,) con args used $! srtExpr table rhs
-----------------------------------------------------------------------------
-Case Alternatives
+-- Construct an SRT bitmap.
-\begin{code}
-srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
-
-srtCaseAlts off (StgAlgAlts t alts dflt)
- = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
- mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
- (StgAlgAlts t alts' dflt', alts_srt, alts_off)
-
-srtCaseAlts off (StgPrimAlts t alts dflt)
- = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
- mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
- (StgPrimAlts t alts' dflt', alts_srt, alts_off)
-
-srtAlgAlt (off,srt) (con,args,used,rhs)
- = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
- ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
-
-srtPrimAlt (off,srt) (lit,rhs)
- = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
- ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
-
-srtDefault off StgNoDefault
- = ((off,[]), StgNoDefault)
-srtDefault off (StgBindDefault rhs)
- = srtExpr off rhs =: \(rhs', srt, off) ->
- ((off,srt), StgBindDefault rhs')
-\end{code}
+constructSRT :: IdEnv Int -> SRT -> SRT
+constructSRT table (SRTEntries entries)
+ | isEmptyVarSet entries = NoSRT
+ | otherwise = SRT offset len bitmap
+ where
+ ints = map (expectJust "constructSRT" . lookupVarEnv table)
+ (varSetElems entries)
+ sorted_ints = sortLe (<=) ints
+ offset = head sorted_ints
+ bitmap_entries = map (subtract offset) sorted_ints
+ len = last bitmap_entries + 1
+ bitmap = intsToBitmap len bitmap_entries
------------------------------------------------------------------------------
-Misc stuff
+-- ---------------------------------------------------------------------------
+-- Misc stuff
-\begin{code}
a =: k = k a
+
\end{code}
projects / ghc-hetmet.git / blobdiff