2 % (c) The GRASP/AQUA Project, Glasgow University, 1998
5 Run through the STG code and compute the Static Reference Table for
6 each let-binding. At the same time, we figure out which top-level
7 bindings have no CAF references, and record the fact in their IdInfo.
10 module SRT( computeSRTs ) where
12 #include "HsVersions.h"
17 import BasicTypes ( TopLevelFlag(..), isTopLevel )
18 import Util ( mapAccumL )
21 import Util ( lengthIs )
27 computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
28 -- The incoming bindingd are filled with SRTEntries in their SRT slots
29 -- the outgoing ones have NoSRT/SRT values instead
31 computeSRTs binds = map srtTopBind binds
34 -----------------------------------------------------------------------------
35 Algorithm for figuring out SRT layout.
37 Our functions have type
39 srtExpr :: SrtOffset -- Next free offset within the SRT
40 -> StgExpr -- Expression to analyse
41 -> (StgExpr, -- (e) newly annotated expression
42 SrtIds, -- (s) SRT required for this expression (reversed)
43 SrtOffset) -- (o) new offset
45 We build a single SRT for a recursive binding group, which is why the
46 SRT building is done at the binding level rather than the
49 The SRT is built up in reverse order, to avoid too many expensive
50 appends. We therefore reverse the SRT before returning it, so that
51 the offsets will be from the beginning of the SRT.
53 -----------------------------------------------------------------------------
56 A function whose CafInfo is NoCafRefs will have an empty SRT, and its
57 closure will not appear in the SRT of any other function (unless we're
58 compiling without optimisation and the CafInfos haven't been emitted
59 in the interface files).
61 Top-Level recursive groups
63 This gets a bit complicated, but the general idea is that we want a
64 single SRT for the whole group, and we'd rather not have recursive
65 references in it if at all possible.
67 We collect all the global references for the group, and filter out
68 those that are binders in the group and not CAFs themselves. Why is
71 - if all the bindings in the group just refer to each other,
72 and none of them are CAFs, we'd like to get an empty SRT.
74 - if any of the bindings in the group refer to a CAF, this will
77 Hmm, that probably makes no sense.
81 type SrtIds = [Id] -- An *reverse-ordered* list of the Ids needed in the SRT
83 srtTopBind :: StgBinding -> (StgBinding, SrtIds)
86 = srtBind TopLevel 0 bind =: \ (bind', srt, off) ->
88 then (bind', []) -- Don't need an SRT for a static constructor
89 else (bind', reverse srt) -- The 'reverse' is because the SRT is
90 -- built up reversed, for efficiency's sake
92 isConBind (StgNonRec _ _ r) = isConRhs r
93 isConBind (StgRec _ bs) = all isConRhs (map snd bs)
95 isConRhs (StgRhsCon _ _ _) = True
98 srtBind :: TopLevelFlag -> SrtOffset -> StgBinding
99 -> (StgBinding, SrtIds, SrtOffset)
101 srtBind top off (StgNonRec (SRTEntries rhs_cafs) binder rhs)
102 = (StgNonRec srt_info binder new_rhs, this_srt, body_off)
104 (new_rhs, rhs_srt, rhs_off) = srtRhs off rhs
105 (srt_info, this_srt, body_off) = constructSRT rhs_cafs rhs_srt off rhs_off
108 srtBind top off (StgRec (SRTEntries rhss_cafs) pairs)
109 = (StgRec srt_info new_pairs, this_srt, body_off)
111 ((rhss_off, rhss_srt), new_pairs) = mapAccumL do_bind (off, []) pairs
113 do_bind (off,srt) (bndr,rhs)
114 = srtRhs off rhs =: \(rhs', srt', off') ->
115 ((off', srt'++srt), (bndr, rhs'))
117 non_caf_binders = [ b | (b, rhs) <- pairs, not (caf_rhs rhs) ]
120 | isTopLevel top = filterVarSet (`notElem` non_caf_binders) rhss_cafs
121 | otherwise = rhss_cafs
123 (srt_info, this_srt, body_off)
124 = constructSRT filtered_rhss_cafs rhss_srt off rhss_off
126 caf_rhs (StgRhsClosure _ _ free_vars _ [] body) = True
130 -----------------------------------------------------------------------------
134 srtRhs :: SrtOffset -> StgRhs -> (StgRhs, SrtIds, SrtOffset)
136 srtRhs off (StgRhsClosure cc bi free_vars u args body)
137 = srtExpr off body =: \(body, srt, off) ->
138 (StgRhsClosure cc bi free_vars u args body, srt, off)
140 srtRhs off e@(StgRhsCon cc con args) = (e, [], off)
143 -----------------------------------------------------------------------------
147 srtExpr :: SrtOffset -> StgExpr -> (StgExpr, SrtIds, SrtOffset)
149 srtExpr off e@(StgApp f args) = (e, [], off)
150 srtExpr off e@(StgLit l) = (e, [], off)
151 srtExpr off e@(StgConApp con args) = (e, [], off)
152 srtExpr off e@(StgOpApp op args ty) = (e, [], off)
154 srtExpr off (StgSCC cc expr) =
155 srtExpr off expr =: \(expr, srt, off) ->
156 (StgSCC cc expr, srt, off)
158 srtExpr off (StgCase scrut live1 live2 uniq (SRTEntries cafs_in_alts) alts)
159 = srtCaseAlts off alts =: \(alts, alts_srt, alts_off) ->
161 (srt_info, this_srt, scrut_off)
162 = constructSRT cafs_in_alts alts_srt off alts_off
164 srtExpr scrut_off scrut =: \(scrut, scrut_srt, case_off) ->
166 (StgCase scrut live1 live2 uniq srt_info alts,
167 scrut_srt ++ this_srt,
170 srtExpr off (StgLet bind body)
171 = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
172 srtExpr body_off body =: \ (body', expr_srt, let_off) ->
173 (StgLet bind' body', expr_srt ++ bind_srt, let_off)
175 srtExpr off (StgLetNoEscape live1 live2 bind body)
176 = srtBind NotTopLevel off bind =: \ (bind', bind_srt, body_off) ->
177 srtExpr body_off body =: \ (body', expr_srt, let_off) ->
178 (StgLetNoEscape live1 live2 bind' body', expr_srt ++ bind_srt, let_off)
181 srtExpr off expr = pprPanic "srtExpr" (ppr expr)
185 -----------------------------------------------------------------------------
188 Construct the SRT at this point from its sub-SRTs and any new global
189 references which aren't already contained in one of the sub-SRTs (and
193 constructSRT caf_refs sub_srt initial_offset current_offset
195 extra_refs = filter (`notElem` sub_srt) (varSetElems caf_refs)
196 this_srt = extra_refs ++ sub_srt
198 -- Add the length of the new entries to the
199 -- current offset to get the next free offset in the global SRT.
200 new_offset = current_offset + length extra_refs
201 srt_length = new_offset - initial_offset
203 srt_info | srt_length == 0 = NoSRT
204 | otherwise = SRT initial_offset srt_length
206 in ASSERT( this_srt `lengthIs` srt_length )
207 (srt_info, this_srt, new_offset)
210 -----------------------------------------------------------------------------
214 srtCaseAlts :: SrtOffset -> StgCaseAlts -> (StgCaseAlts, SrtIds, SrtOffset)
216 srtCaseAlts off (StgAlgAlts t alts dflt)
217 = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
218 mapAccumL srtAlgAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
219 (StgAlgAlts t alts' dflt', alts_srt, alts_off)
221 srtCaseAlts off (StgPrimAlts t alts dflt)
222 = srtDefault off dflt =: \ ((dflt_off, dflt_srt), dflt') ->
223 mapAccumL srtPrimAlt (dflt_off, dflt_srt) alts =: \ ((alts_off, alts_srt), alts') ->
224 (StgPrimAlts t alts' dflt', alts_srt, alts_off)
226 srtAlgAlt (off,srt) (con,args,used,rhs)
227 = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
228 ((rhs_off, rhs_srt ++ srt), (con,args,used,rhs'))
230 srtPrimAlt (off,srt) (lit,rhs)
231 = srtExpr off rhs =: \(rhs', rhs_srt, rhs_off) ->
232 ((rhs_off, rhs_srt ++ srt), (lit, rhs'))
234 srtDefault off StgNoDefault
235 = ((off,[]), StgNoDefault)
236 srtDefault off (StgBindDefault rhs)
237 = srtExpr off rhs =: \(rhs', srt, off) ->
238 ((off,srt), StgBindDefault rhs')
241 -----------------------------------------------------------------------------