X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=ghc%2Fcompiler%2FsimplStg%2FSRT.lhs;h=cd118d70922bf0957030cb44eab6682ad417fd55;hb=59c796f8e77325d35f29ddd3e724bfa780466d40;hp=c597baa1735602af8c36376729ace2418ce65016;hpb=05c41def95ec45bbe63d3c9ab0ba9e19648717e0;p=ghc-hetmet.git diff --git a/ghc/compiler/simplStg/SRT.lhs b/ghc/compiler/simplStg/SRT.lhs index c597baa..cd118d7 100644 --- a/ghc/compiler/simplStg/SRT.lhs +++ b/ghc/compiler/simplStg/SRT.lhs @@ -7,463 +7,159 @@ each let-binding. At the same time, we figure out which top-level bindings have no CAF references, and record the fact in their IdInfo. \begin{code} -module SRT where +module SRT( computeSRTs ) where #include "HsVersions.h" -import Id ( Id, idCafInfo ) -import IdInfo ( CafInfo(..) ) import StgSyn - -import UniqFM -import UniqSet -import Panic +import Id ( Id ) +import VarSet +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])] -computeSRTs binds = map srtTopBind binds -\end{code} - ------------------------------------------------------------------------------ -Algorithm for figuring out SRT layout. - -Our functions have type - - :: 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) 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), 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. - -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. +import List -\begin{code} -srtTopBind - :: StgBinding - -> (StgBinding, -- the new binding - [Id]) -- the SRT for this binding - -srtTopBind (StgNonRec binder rhs) = - - -- no need to use circularity for non-recursive bindings - srtRhs (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs - =: \(rhs, g, srt, off) -> - let - 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) - - -- don't output an SRT for the constructor - StgRhsCon _ _ _ -> (StgNonRec binder rhs, []) - - -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) ] - - (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) (uniqSetToList g) - extra_refs = filter (`notElem` srt) filtered_g - bind_srt = reverse (extra_refs ++ srt) - - doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off) - doBinds ((binder,rhs):binds) new_binds g srt off = - srtRhs (emptyUniqSet,emptyUFM) off rhs - =: \(rhs, rhs_g, rhs_srt, off) -> - let - g' = unionUniqSets rhs_g g - srt' = rhs_srt ++ srt - in - doBinds binds ((binder,rhs):new_binds) g' srt' off - -caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True -caf_rhs _ = False -\end{code} - ------------------------------------------------------------------------------ -Non-top-level bindings - -\begin{code} -srtBind :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int) - -srtBind cont_refs off (StgNonRec binder rhs) = - srtRhs cont_refs off rhs =: \(rhs, g, srt, off) -> - (StgNonRec binder rhs, g, srt, 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 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 :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int) - -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 cont off e@(StgRhsCon cc con args) = - (e, getGlobalRefs args, [], off) +import Util +import Outputable \end{code} ------------------------------------------------------------------------------ -Expressions - \begin{code} -srtExpr :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int) - -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 (cont,lne) off e@(StgLit l) = (e, cont, [], 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 - srt_info = case length this_srt of - 0 -> NoSRT - len -> SRT off len - in - (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_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) +computeSRTs :: [StgBinding] -> [(StgBinding,[(Id,[Id])])] + -- The incoming bindingd are filled with SRTEntries in their SRT slots + -- the outgoing ones have NoSRT/SRT values instead -#ifdef DEBUG -srtExpr cont off expr = pprPanic "srtExpr" (ppr expr) -#else -srtExpr cont off expr = panic "srtExpr" -#endif -\end{code} +computeSRTs binds = srtTopBinds emptyVarEnv binds ------------------------------------------------------------------------------ -Let-expressions +-- -------------------------------------------------------------------------- +-- Top-level Bindings -This is quite complicated stuff... +srtTopBinds :: IdEnv Id -> [StgBinding] -> [(StgBinding, [(Id,[Id])])] -\begin{code} -srtLet cont off bind body let_constr calc_cont +srtTopBinds env [] = [] +srtTopBinds env (StgNonRec b rhs : binds) = + (StgNonRec b rhs', [(b,srt')]) : srtTopBinds env' binds + where + (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 + elems = varSetElems cafs + table = mkVarEnv (zip elems [0..]) - -- If the bindings are all constructors, then we don't need to - -- buid an SRT at all... - | all_con_binds bind = - 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 - in - (let_constr bind body, g, srt, off) +-- ---- Binds: - -- we have some closure bindings... - | otherwise = +srtBind :: IdEnv Int -> StgBinding -> StgBinding - -- first, find the sub-SRTs in the binding - srtBind cont off bind =: \(bind, bind_g, bind_srt, bind_off) -> +srtBind table (StgNonRec binder rhs) = StgNonRec binder (srtRhs table rhs) +srtBind table (StgRec pairs) = StgRec [ (b, srtRhs table r) | (b,r) <- pairs ] - -- construct the SRT for this binding - let (this_srt, body_off) = construct_srt bind_g bind_srt bind_off in +-- ---- Right Hand Sides: - -- get the new continuation information (if a let-no-escape) - let new_cont = calc_cont bind_g cont in +srtRhs :: IdEnv Int -> StgRhs -> StgRhs - -- now find the SRTs in the body - srtExpr new_cont body_off body =: \(body, body_g, body_srt, let_off) -> +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) - let - -- union all the global references together - let_g = unionUniqSets bind_g body_g +-- --------------------------------------------------------------------------- +-- Expressions - -- concatenate the sub-SRTs - let_srt = body_srt ++ this_srt +srtExpr :: IdEnv Int -> StgExpr -> StgExpr - -- attach the SRT info to the binding - bind' = attach_srt_bind bind off (length this_srt) - in - (let_constr bind' body, let_g, let_srt, let_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 ------------------------------------------------------------------------------ -Construct an SRT. +srtExpr table (StgSCC cc expr) = StgSCC cc $! srtExpr table expr -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"). +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 -\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} +srtExpr table (StgLet bind body) + = srtBind table bind =: \ bind' -> + srtExpr table body =: \ body' -> + StgLet bind' body' + +srtExpr table (StgLetNoEscape live1 live2 bind body) + = srtBind table bind =: \ bind' -> + srtExpr table body =: \ body' -> + StgLetNoEscape live1 live2 bind' body' ------------------------------------------------------------------------------ -Case Alternatives +#ifdef DEBUG +srtExpr table expr = pprPanic "srtExpr" (ppr expr) +#endif -\begin{code} -srtCaseAlts :: (UniqSet Id, UniqFM (UniqSet Id)) - -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int) - -srtCaseAlts cont off (StgAlgAlts t alts dflt) = - srtAlgAlts cont off alts [] emptyUniqSet [] - =: \(alts, alts_g, alts_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 cont off (StgPrimAlts t alts dflt) = - srtPrimAlts cont off alts [] emptyUniqSet [] - =: \(alts, alts_g, alts_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 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 cont off alts ((con,args,used,rhs) : new_alts) g' srt' - -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 cont off alts ((lit,rhs) : new_alts) g' srt' - -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} +srtAlt :: IdEnv Int -> StgAlt -> StgAlt +srtAlt table (con,args,used,rhs) + = (,,,) con args used $! srtExpr table rhs ----------------------------------------------------------------------------- +-- Construct an SRT bitmap. -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 :: [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} - ------------------------------------------------------------------------------ -Misc stuff - -\begin{code} -attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding -attach_srt_bind (StgNonRec binder rhs) off len = - StgNonRec binder (attach_srt_rhs rhs off len) -attach_srt_bind (StgRec binds) off len = - StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ] - -attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs -attach_srt_rhs (StgRhsCon cc con args) off length - = StgRhsCon cc con args -attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length - = StgRhsClosure cc bi srt free upd args rhs +constructSRT :: IdEnv Int -> SRT -> SRT +constructSRT table (SRTEntries entries) + | isEmptyVarSet entries = NoSRT + | otherwise = SRT offset len bitmap where - srt | length == 0 = NoSRT - | otherwise = SRT off length - - -all_con_binds (StgNonRec x rhs) = con_rhs rhs -all_con_binds (StgRec bs) = all con_rhs (map snd bs) - -con_rhs (StgRhsCon _ _ _) = True -con_rhs _ = False + 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 a =: k = k a -\end{code} - ------------------------------------------------------------------------------ -Fix up the SRT's in a let-no-escape. - -(for a description of let-no-escapes, see CgLetNoEscape.lhs) -Here's the problem: a let-no-escape isn't represented by an activation -record on the stack. It seems either very difficult or impossible to -get the liveness bitmap right in the info table, so we don't do it -this way (the liveness mask isn't constant). - -So, the question is how does the garbage collector get access to the -SRT for the rhs of the let-no-escape? It can't see an info table, so -it must get the SRT from somewhere else. Here's an example: - - let-no-escape x = .... f .... - in case blah of - p -> .... x ... g .... - -(f and g are global). Suppose we garbage collect while evaluating -'blah'. The stack will contain an activation record for the case, -which will point to an SRT containing [g] (according to our SRT -algorithm above). But, since the case continuation can call x, and -hence f, the SRT should really be [f,g]. - -another example: - - let-no-escape {-rec-} z = \x -> case blah of - p1 -> .... f ... - p2 -> case blah2 of - p -> .... (z x') ... - in .... - -if we GC while evaluating blah2, then the case continuation on the -stack needs to refer to [f] in its SRT, because we can reach f by -calling z recursively. - -FIX: - -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 = - case lookupUFM lne_env f of - Nothing -> emptyUniqSet - Just refs -> refs \end{code}