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.
12 import Id ( Id, setIdCafInfo, idCafInfo, externallyVisibleId,
14 import CoreUtils( idAppIsBottom )
15 import IdInfo ( CafInfo(..) )
23 computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
24 computeSRTs binds = srtBinds emptyUFM binds
28 srtBinds :: UniqFM CafInfo -> [StgBinding] -> [(StgBinding,[Id])]
31 srtTopBind rho b =: \(b, srt, rho) ->
32 (b,srt) : srtBinds rho bs
35 -----------------------------------------------------------------------------
36 Circular algorithm for simultaneously figuring out CafInfo and SRT
39 Our functions have type
41 :: UniqFM CafInfo -- which top-level ids don't refer to any CAfs
42 -> SrtOffset -- next free offset within the SRT
43 -> (UniqSet Id, -- global refs in the continuation
44 UniqFM (UniqSet Id))-- global refs in let-no-escaped variables
45 {- * -} -> StgExpr -- expression to analyse
47 -> (StgExpr, -- (e) newly annotated expression
48 UniqSet Id, -- (g) set of *all* global references
49 [Id], -- (s) SRT required for this expression
50 SrtOffset) -- (o) new offset
52 (g) is a set containing all local top-level and imported ids referred
53 to by the expression (e).
55 The set of all global references is used to build the environment,
56 which is passed in again. The environment is used to build the final
59 We build a single SRT for a recursive binding group, which is why the
60 SRT building is done at the binding level rather than the
63 Hence, the only argument which we can look at before returning is the
64 expression (marked with {- * -} above).
66 The SRT is built up in reverse order, to avoid too many expensive
67 appends. We therefore reverse the SRT before returning it, so that
68 the offsets will be from the beginning of the SRT.
70 -----------------------------------------------------------------------------
73 The environment contains a mapping from local top-level bindings to
74 CafInfo. The CafInfo is either
76 NoCafRefs - indicating that the id is not a CAF and furthermore
77 that it doesn't refer, even indirectly, to any CAFs.
79 MayHaveCafRefs - everything else.
81 A function whose CafInfo is NoCafRefs will have an empty SRT, and its
82 closure will not appear in the SRT of any other function (unless we're
83 compiling without optimisation and the CafInfos haven't been emitted
84 in the interface files).
86 Top-Level recursive groups
88 This gets a bit complicated, but the general idea is that we want a
89 single SRT for the whole group, and we'd rather not have recursive
90 references in it if at all possible.
92 We collect all the global references for the group, and filter out
93 those that are binders in the group and not CAFs themselves. This set
94 of references is then used to infer the CafInfo for each of the
95 binders in the group. Why is it done this way?
97 - if all the bindings in the group just refer to each other,
98 and none of them are CAFs, we'd like to get an empty SRT.
100 - if any of the bindings in the group refer to a CAF, this will
103 Hmm, that probably makes no sense.
109 -> (StgBinding, -- the new binding
110 [Id], -- the SRT for this binding
111 UniqFM CafInfo) -- the new environment
113 srtTopBind rho (StgNonRec binder rhs) =
115 -- no need to use circularity for non-recursive bindings
116 srtRhs rho (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
117 =: \(rhs, g, srt, off) ->
119 filtered_g = filter (mayHaveCafRefs rho) (uniqSetToList g)
120 caf_info = mk_caf_info rhs filtered_g
121 binder' = setIdCafInfo binder caf_info
122 rho' = addToUFM rho binder' caf_info
123 extra_refs = filter (`notElem` srt) filtered_g
124 bind_srt = reverse (extra_refs ++ srt)
127 StgRhsClosure _ _ _ _ _ _ _ ->
128 (StgNonRec binder' (attach_srt_rhs rhs 0 (length bind_srt)),
131 -- don't output an SRT for the constructor, but just remember
132 -- whether it had any caf references or not.
133 StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
136 srtTopBind rho (StgRec bs) =
137 (attach_srt_bind (StgRec (reverse new_bs')) 0 (length bind_srt),
140 (binders,rhss) = unzip bs
142 non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
144 -- circular: rho' is calculated from g below
145 (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
147 -- filter out ourselves from the global references: it makes no
148 -- sense to refer recursively to our SRT unless the recursive
149 -- reference is required by a nested SRT.
150 filtered_g = filter (\id -> id `notElem` non_caf_binders &&
151 mayHaveCafRefs rho id) (uniqSetToList g)
152 extra_refs = filter (`notElem` srt) filtered_g
153 bind_srt = reverse (extra_refs ++ srt)
154 caf_infos = map (\rhs -> mk_caf_info rhs filtered_g) rhss
155 rho' = addListToUFM rho (zip binders caf_infos)
156 binders' = zipWith setIdCafInfo binders caf_infos
158 new_bs' = zip binders' (map snd new_bs)
160 doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
161 doBinds ((binder,rhs):binds) new_binds g srt off =
162 srtRhs rho' (emptyUniqSet,emptyUFM) off rhs
163 =: \(rhs, rhs_g, rhs_srt, off) ->
165 g' = unionUniqSets rhs_g g
166 srt' = rhs_srt ++ srt
168 doBinds binds ((binder,rhs):new_binds) g' srt' off
170 caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True
174 -----------------------------------------------------------------------------
175 Non-top-level bindings
178 srtBind :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
179 -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
181 srtBind rho cont_refs off (StgNonRec binder rhs) =
182 srtRhs rho cont_refs off rhs =: \(rhs, g, srt, off) ->
183 (StgNonRec binder rhs, g, srt, off)
185 srtBind rho cont_refs off (StgRec binds) =
186 (StgRec new_binds, g, srt, new_off)
188 -- process each binding
189 (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
191 doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
192 doBinds ((binder,rhs):binds) g srt off new_binds =
193 srtRhs rho cont_refs off rhs =: \(rhs, g', srt', off) ->
194 doBinds binds (unionUniqSets g g') (srt'++srt) off
195 ((binder,rhs):new_binds)
198 -----------------------------------------------------------------------------
202 srtRhs :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
203 -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
205 srtRhs rho cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
206 srtExpr rho cont off body =: \(body, g, srt, off) ->
207 (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
209 srtRhs rho cont off e@(StgRhsCon cc con args) =
210 (e, getGlobalRefs rho args, [], off)
213 -----------------------------------------------------------------------------
217 srtExpr :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
218 -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
220 srtExpr rho (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
223 getGlobalRefs rho (StgVarArg f:args) `unionUniqSets`
224 lookupPossibleLNE lne f
226 srtExpr rho (cont,lne) off e@(StgLit l) = (e, cont, [], off)
228 srtExpr rho (cont,lne) off e@(StgConApp con args) =
229 (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
231 srtExpr rho (cont,lne) off e@(StgPrimApp op args ty) =
232 (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
234 srtExpr rho c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
235 srtCaseAlts rho c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
237 -- construct the SRT for this case
238 let (this_srt, scrut_off) = construct_srt rho alts_g alts_srt alts_off in
240 -- global refs in the continuation is alts_g.
241 srtExpr rho (alts_g,lne) scrut_off scrut
242 =: \(scrut, scrut_g, scrut_srt, case_off) ->
244 g = unionUniqSets alts_g scrut_g
245 srt = scrut_srt ++ this_srt
246 srt_info = case length this_srt of
250 (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
252 srtExpr rho cont off (StgLet bind body) =
253 srtLet rho cont off bind body StgLet (\_ cont -> cont)
255 srtExpr rho cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
256 = srtLet rho cont off b body (StgLetNoEscape live1 live2) calc_cont
257 where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g)
259 -- for recursive let-no-escapes, we do *two* passes, the first time
260 -- just to extract the list of global refs, and the second time we actually
261 -- construct the SRT now that we know what global refs should be in
262 -- the various let-no-escape continuations.
263 srtExpr rho conts@(cont,lne) off
264 (StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
265 = srtBind rho conts off bind =: \(_, g, _, _) ->
267 lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
268 calc_cont _ conts = conts
270 srtLet rho (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
273 srtExpr rho cont off (StgSCC cc expr) =
274 srtExpr rho cont off expr =: \(expr, g, srt, off) ->
275 (StgSCC cc expr, g, srt, off)
278 -----------------------------------------------------------------------------
281 This is quite complicated stuff...
284 srtLet rho cont off bind body let_constr calc_cont
286 -- If the bindings are all constructors, then we don't need to
287 -- buid an SRT at all...
288 | all_con_binds bind =
289 srtBind rho cont off bind =: \(bind, bind_g, bind_srt, off) ->
290 srtExpr rho cont off body =: \(body, body_g, body_srt, off) ->
292 g = unionUniqSets bind_g body_g
293 srt = body_srt ++ bind_srt
295 (let_constr bind body, g, srt, off)
297 -- we have some closure bindings...
300 -- first, find the sub-SRTs in the binding
301 srtBind rho cont off bind =: \(bind, bind_g, bind_srt, bind_off) ->
303 -- construct the SRT for this binding
304 let (this_srt, body_off) = construct_srt rho bind_g bind_srt bind_off in
306 -- get the new continuation information (if a let-no-escape)
307 let new_cont = calc_cont bind_g cont in
309 -- now find the SRTs in the body
310 srtExpr rho new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
313 -- union all the global references together
314 let_g = unionUniqSets bind_g body_g
316 -- concatenate the sub-SRTs
317 let_srt = body_srt ++ this_srt
319 -- attach the SRT info to the binding
320 bind' = attach_srt_bind bind off (length this_srt)
322 (let_constr bind' body, let_g, let_srt, let_off)
325 -----------------------------------------------------------------------------
328 Construct the SRT at this point from its sub-SRTs and any new global
329 references which aren't already contained in one of the sub-SRTs (and
333 construct_srt rho global_refs sub_srt current_offset
335 extra_refs = filter (`notElem` sub_srt)
336 (filter (mayHaveCafRefs rho) (uniqSetToList global_refs))
337 this_srt = extra_refs ++ sub_srt
339 -- Add the length of the new entries to the
340 -- current offset to get the next free offset in the global SRT.
341 new_offset = current_offset + length extra_refs
342 in (this_srt, new_offset)
345 -----------------------------------------------------------------------------
349 srtCaseAlts :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
350 -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
352 srtCaseAlts rho cont off (StgAlgAlts t alts dflt) =
353 srtAlgAlts rho cont off alts [] emptyUniqSet []
354 =: \(alts, alts_g, alts_srt, off) ->
355 srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
357 g = unionUniqSets alts_g dflt_g
358 srt = dflt_srt ++ alts_srt
360 (StgAlgAlts t alts dflt, g, srt, off)
362 srtCaseAlts rho cont off (StgPrimAlts t alts dflt) =
363 srtPrimAlts rho cont off alts [] emptyUniqSet []
364 =: \(alts, alts_g, alts_srt, off) ->
365 srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
367 g = unionUniqSets alts_g dflt_g
368 srt = dflt_srt ++ alts_srt
370 (StgPrimAlts t alts dflt, g, srt, off)
372 srtAlgAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
373 srtAlgAlts rho cont off ((con,args,used,rhs):alts) new_alts g srt =
374 srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
376 g' = unionUniqSets rhs_g g
377 srt' = rhs_srt ++ srt
379 srtAlgAlts rho cont off alts ((con,args,used,rhs) : new_alts) g' srt'
381 srtPrimAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
382 srtPrimAlts rho cont off ((lit,rhs):alts) new_alts g srt =
383 srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
385 g' = unionUniqSets rhs_g g
386 srt' = rhs_srt ++ srt
388 srtPrimAlts rho cont off alts ((lit,rhs) : new_alts) g' srt'
390 srtDefault rho cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
391 srtDefault rho cont off (StgBindDefault rhs) =
392 srtExpr rho cont off rhs =: \(rhs, g, srt, off) ->
393 (StgBindDefault rhs, g, srt, off)
396 -----------------------------------------------------------------------------
398 Decide whether a closure looks like a CAF or not. In an effort to
399 keep the number of CAFs (and hence the size of the SRTs) down, we
400 would also like to look at the expression and decide whether it
401 requires a small bounded amount of heap, so we can ignore it as a CAF.
402 In these cases, we need to use an additional CAF list to keep track of
403 non-collectable CAFs.
405 We mark real CAFs as `MayHaveCafRefs' because this information is used
406 to decide whether a particular closure needs to be referenced in an
411 :: StgRhs -- right-hand-side of the definition
412 -> [Id] -- static references
415 -- special case for expressions which are always bottom,
416 -- such as 'error "..."'. We don't need to record it as
417 -- a CAF, since it can only be entered once.
418 mk_caf_info (StgRhsClosure _ _ _ free_vars _ [] e) srt
419 | isBottomingExpr e && null srt = NoCafRefs
421 mk_caf_info (StgRhsClosure _ _ _ free_vars upd args body) srt
422 | isUpdatable upd = MayHaveCafRefs -- a real live CAF
423 | null srt = NoCafRefs -- function w/ no static references
424 | otherwise = MayHaveCafRefs -- function w/ some static references
426 mk_caf_info rcon@(StgRhsCon cc con args) srt
427 | null srt = NoCafRefs -- constructor w/ no static references
428 | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
431 isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
432 isBottomingExpr (StgApp f args) = idAppIsBottom f (length args)
433 isBottomingExpr _ = False
436 -----------------------------------------------------------------------------
438 Here we decide which Id's to place in the static reference table. An
439 internal top-level id will be in the environment with the appropriate
440 CafInfo, so we use that if available. An imported top-level Id will
441 have the CafInfo attached. Otherwise, we just ignore the Id.
444 getGlobalRefs :: UniqFM CafInfo -> [StgArg] -> UniqSet Id
445 getGlobalRefs rho args = mkUniqSet (concat (map (globalRefArg rho) args))
447 globalRefArg :: UniqFM CafInfo -> StgArg -> [Id]
449 globalRefArg rho (StgVarArg id)
452 case lookupUFM rho id of {
453 Just _ -> [id]; -- Can't look at the caf_info yet...
454 Nothing -> -- but we will look it up and filter later
455 -- in maybeHaveCafRefs
457 if externallyVisibleId id
458 then case idCafInfo id of
459 MayHaveCafRefs -> [id]
464 globalRefArg rho _ = []
468 mayHaveCafRefs rho id =
469 case lookupUFM rho id of
470 Just MayHaveCafRefs -> True
471 Just NoCafRefs -> False
475 -----------------------------------------------------------------------------
479 attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding
480 attach_srt_bind (StgNonRec binder rhs) off len =
481 StgNonRec binder (attach_srt_rhs rhs off len)
482 attach_srt_bind (StgRec binds) off len =
483 StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ]
485 attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs
486 attach_srt_rhs (StgRhsCon cc con args) off length
487 = StgRhsCon cc con args
488 attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length
489 = StgRhsClosure cc bi srt free upd args rhs
491 srt | length == 0 = NoSRT
492 | otherwise = SRT off length
495 all_con_binds (StgNonRec x rhs) = con_rhs rhs
496 all_con_binds (StgRec bs) = all con_rhs (map snd bs)
498 con_rhs (StgRhsCon _ _ _) = True
505 -----------------------------------------------------------------------------
506 Fix up the SRT's in a let-no-escape.
508 (for a description of let-no-escapes, see CgLetNoEscape.lhs)
510 Here's the problem: a let-no-escape isn't represented by an activation
511 record on the stack. It seems either very difficult or impossible to
512 get the liveness bitmap right in the info table, so we don't do it
513 this way (the liveness mask isn't constant).
515 So, the question is how does the garbage collector get access to the
516 SRT for the rhs of the let-no-escape? It can't see an info table, so
517 it must get the SRT from somewhere else. Here's an example:
519 let-no-escape x = .... f ....
521 p -> .... x ... g ....
523 (f and g are global). Suppose we garbage collect while evaluating
524 'blah'. The stack will contain an activation record for the case,
525 which will point to an SRT containing [g] (according to our SRT
526 algorithm above). But, since the case continuation can call x, and
527 hence f, the SRT should really be [f,g].
531 let-no-escape {-rec-} z = \x -> case blah of
537 if we GC while evaluating blah2, then the case continuation on the
538 stack needs to refer to [f] in its SRT, because we can reach f by
539 calling z recursively.
543 The following code fixes up a let-no-escape expression after we've run
544 the SRT algorithm. It needs to know the SRT for the *whole*
545 expression (this is plugged in instead of the SRT for case exprsesions
546 in the body). The good news is that we only need to traverse nested
547 case expressions, since the let-no-escape bound variable can't occur
548 in the rhs of a let or in a case scrutinee.
550 For recursive let-no-escapes, the body is processed as for
551 non-recursive let-no-escapes, but case expressions in the rhs of each
552 binding have their SRTs replaced with the SRT for the binding group
553 (*not* the SRT of the whole let-no-escape expression).
556 lookupPossibleLNE lne_env f =
557 case lookupUFM lne_env f of
558 Nothing -> emptyUniqSet