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 )
13 import CoreUtils ( idAppIsBottom )
14 import IdInfo ( CafInfo(..) )
27 computeSRTs :: [StgBinding] -> [(StgBinding,[Id])]
28 computeSRTs binds = srtBinds emptyUFM binds
32 srtBinds :: UniqFM CafInfo -> [StgBinding] -> [(StgBinding,[Id])]
35 srtTopBind rho b =: \(b, srt, rho) ->
36 (b,srt) : srtBinds rho bs
39 -----------------------------------------------------------------------------
40 Circular algorithm for simultaneously figuring out CafInfo and SRT
43 Our functions have type
45 :: UniqFM CafInfo -- which top-level ids don't refer to any CAfs
46 -> SrtOffset -- next free offset within the SRT
47 -> (UniqSet Id, -- global refs in the continuation
48 UniqFM (UniqSet Id))-- global refs in let-no-escaped variables
49 {- * -} -> StgExpr -- expression to analyse
51 -> (StgExpr, -- (e) newly annotated expression
52 UniqSet Id, -- (g) set of *all* global references
53 [Id], -- (s) SRT required for this expression
54 SrtOffset) -- (o) new offset
56 (g) is a set containing all local top-level and imported ids referred
57 to by the expression (e).
59 The set of all global references is used to build the environment,
60 which is passed in again. The environment is used to build the final
63 We build a single SRT for a recursive binding group, which is why the
64 SRT building is done at the binding level rather than the
67 Hence, the only argument which we can look at before returning is the
68 expression (marked with {- * -} above).
70 The SRT is built up in reverse order, to avoid too many expensive
71 appends. We therefore reverse the SRT before returning it, so that
72 the offsets will be from the beginning of the SRT.
74 -----------------------------------------------------------------------------
77 The environment contains a mapping from local top-level bindings to
78 CafInfo. The CafInfo is either
80 NoCafRefs - indicating that the id is not a CAF and furthermore
81 that it doesn't refer, even indirectly, to any CAFs.
83 MayHaveCafRefs - everything else.
85 A function whose CafInfo is NoCafRefs will have an empty SRT, and its
86 closure will not appear in the SRT of any other function (unless we're
87 compiling without optimisation and the CafInfos haven't been emitted
88 in the interface files).
90 Top-Level recursive groups
92 This gets a bit complicated, but the general idea is that we want a
93 single SRT for the whole group, and we'd rather not have recursive
94 references in it if at all possible.
96 We collect all the global references for the group, and filter out
97 those that are binders in the group and not CAFs themselves. This set
98 of references is then used to infer the CafInfo for each of the
99 binders in the group. Why is it done this way?
101 - if all the bindings in the group just refer to each other,
102 and none of them are CAFs, we'd like to get an empty SRT.
104 - if any of the bindings in the group refer to a CAF, this will
107 Hmm, that probably makes no sense.
113 -> (StgBinding, -- the new binding
114 [Id], -- the SRT for this binding
115 UniqFM CafInfo) -- the new environment
117 srtTopBind rho (StgNonRec binder rhs) =
119 -- no need to use circularity for non-recursive bindings
120 srtRhs rho (emptyUniqSet,emptyUFM) 0{-initial offset-} rhs
121 =: \(rhs, g, srt, off) ->
123 filtered_g = filter (mayHaveCafRefs rho) (uniqSetToList g)
124 caf_info = mk_caf_info rhs filtered_g
125 binder' = setIdCafInfo binder caf_info
126 rho' = addToUFM rho binder' caf_info
127 extra_refs = filter (`notElem` srt) filtered_g
128 bind_srt = reverse (extra_refs ++ srt)
131 StgRhsClosure _ _ _ _ _ _ _ ->
132 (StgNonRec binder' (attach_srt_rhs rhs 0 (length bind_srt)),
135 -- don't output an SRT for the constructor, but just remember
136 -- whether it had any caf references or not.
137 StgRhsCon _ _ _ -> (StgNonRec binder' rhs, [], rho')
140 srtTopBind rho (StgRec bs) =
141 (attach_srt_bind (StgRec (reverse new_bs')) 0 (length bind_srt),
144 (binders,rhss) = unzip bs
146 non_caf_binders = [ b | (b, rhs) <- bs, not (caf_rhs rhs) ]
148 -- circular: rho' is calculated from g below
149 (new_bs, g, srt, _) = doBinds bs [] emptyUniqSet [] 0
151 -- filter out ourselves from the global references: it makes no
152 -- sense to refer recursively to our SRT unless the recursive
153 -- reference is required by a nested SRT.
154 filtered_g = filter (\id -> id `notElem` non_caf_binders &&
155 mayHaveCafRefs rho id) (uniqSetToList g)
156 extra_refs = filter (`notElem` srt) filtered_g
157 bind_srt = reverse (extra_refs ++ srt)
158 caf_infos = map (\rhs -> mk_caf_info rhs filtered_g) rhss
159 rho' = addListToUFM rho (zip binders caf_infos)
160 binders' = zipWith setIdCafInfo binders caf_infos
162 new_bs' = zip binders' (map snd new_bs)
164 doBinds [] new_binds g srt off = (reverse new_binds, g, srt, off)
165 doBinds ((binder,rhs):binds) new_binds g srt off =
166 srtRhs rho' (emptyUniqSet,emptyUFM) off rhs
167 =: \(rhs, rhs_g, rhs_srt, off) ->
169 g' = unionUniqSets rhs_g g
170 srt' = rhs_srt ++ srt
172 doBinds binds ((binder,rhs):new_binds) g' srt' off
174 caf_rhs (StgRhsClosure _ _ _ free_vars _ [] body) = True
178 -----------------------------------------------------------------------------
179 Non-top-level bindings
182 srtBind :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
183 -> Int -> StgBinding -> (StgBinding, UniqSet Id, [Id], Int)
185 srtBind rho cont_refs off (StgNonRec binder rhs) =
186 srtRhs rho cont_refs off rhs =: \(rhs, g, srt, off) ->
187 (StgNonRec binder rhs, g, srt, off)
189 srtBind rho cont_refs off (StgRec binds) =
190 (StgRec new_binds, g, srt, new_off)
192 -- process each binding
193 (new_binds, g, srt, new_off) = doBinds binds emptyUniqSet [] off []
195 doBinds [] g srt off new_binds = (reverse new_binds, g, srt, off)
196 doBinds ((binder,rhs):binds) g srt off new_binds =
197 srtRhs rho cont_refs off rhs =: \(rhs, g', srt', off) ->
198 doBinds binds (unionUniqSets g g') (srt'++srt) off
199 ((binder,rhs):new_binds)
202 -----------------------------------------------------------------------------
206 srtRhs :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
207 -> Int -> StgRhs -> (StgRhs, UniqSet Id, [Id], Int)
209 srtRhs rho cont off (StgRhsClosure cc bi old_srt free_vars u args body) =
210 srtExpr rho cont off body =: \(body, g, srt, off) ->
211 (StgRhsClosure cc bi old_srt free_vars u args body, g, srt, off)
213 srtRhs rho cont off e@(StgRhsCon cc con args) =
214 (e, getGlobalRefs rho args, [], off)
217 -----------------------------------------------------------------------------
221 srtExpr :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
222 -> Int -> StgExpr -> (StgExpr, UniqSet Id, [Id], Int)
224 srtExpr rho (cont,lne) off e@(StgApp f args) = (e, global_refs, [], off)
227 getGlobalRefs rho (StgVarArg f:args) `unionUniqSets`
228 lookupPossibleLNE lne f
230 srtExpr rho (cont,lne) off e@(StgLit l) = (e, cont, [], off)
232 srtExpr rho (cont,lne) off e@(StgConApp con args) =
233 (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
235 srtExpr rho (cont,lne) off e@(StgPrimApp op args ty) =
236 (e, cont `unionUniqSets` getGlobalRefs rho args, [], off)
238 srtExpr rho c@(cont,lne) off (StgCase scrut live1 live2 uniq _{-srt-} alts) =
239 srtCaseAlts rho c off alts =: \(alts, alts_g, alts_srt, alts_off) ->
241 -- construct the SRT for this case
242 let (this_srt, scrut_off) = construct_srt rho alts_g alts_srt alts_off in
244 -- global refs in the continuation is alts_g.
245 srtExpr rho (alts_g,lne) scrut_off scrut
246 =: \(scrut, scrut_g, scrut_srt, case_off) ->
248 g = unionUniqSets alts_g scrut_g
249 srt = scrut_srt ++ this_srt
250 srt_info = case length this_srt of
254 (StgCase scrut live1 live2 uniq srt_info alts, g, srt, case_off)
256 srtExpr rho cont off (StgLet bind body) =
257 srtLet rho cont off bind body StgLet (\_ cont -> cont)
259 srtExpr rho cont off (StgLetNoEscape live1 live2 b@(StgNonRec bndr rhs) body)
260 = srtLet rho cont off b body (StgLetNoEscape live1 live2) calc_cont
261 where calc_cont g (cont,lne) = (cont,addToUFM lne bndr g)
263 -- for recursive let-no-escapes, we do *two* passes, the first time
264 -- just to extract the list of global refs, and the second time we actually
265 -- construct the SRT now that we know what global refs should be in
266 -- the various let-no-escape continuations.
267 srtExpr rho conts@(cont,lne) off
268 (StgLetNoEscape live1 live2 bind@(StgRec pairs) body)
269 = srtBind rho conts off bind =: \(_, g, _, _) ->
271 lne' = addListToUFM lne [ (bndr,g) | (bndr,_) <- pairs ]
272 calc_cont _ conts = conts
274 srtLet rho (cont,lne') off bind body (StgLetNoEscape live1 live2) calc_cont
277 srtExpr rho cont off (StgSCC cc expr) =
278 srtExpr rho cont off expr =: \(expr, g, srt, off) ->
279 (StgSCC cc expr, g, srt, off)
282 srtExpr rho cont off expr = pprPanic "srtExpr" (ppr expr)
284 srtExpr rho cont off expr = panic "srtExpr"
288 -----------------------------------------------------------------------------
291 This is quite complicated stuff...
294 srtLet rho cont off bind body let_constr calc_cont
296 -- If the bindings are all constructors, then we don't need to
297 -- buid an SRT at all...
298 | all_con_binds bind =
299 srtBind rho cont off bind =: \(bind, bind_g, bind_srt, off) ->
300 srtExpr rho cont off body =: \(body, body_g, body_srt, off) ->
302 g = unionUniqSets bind_g body_g
303 srt = body_srt ++ bind_srt
305 (let_constr bind body, g, srt, off)
307 -- we have some closure bindings...
310 -- first, find the sub-SRTs in the binding
311 srtBind rho cont off bind =: \(bind, bind_g, bind_srt, bind_off) ->
313 -- construct the SRT for this binding
314 let (this_srt, body_off) = construct_srt rho bind_g bind_srt bind_off in
316 -- get the new continuation information (if a let-no-escape)
317 let new_cont = calc_cont bind_g cont in
319 -- now find the SRTs in the body
320 srtExpr rho new_cont body_off body =: \(body, body_g, body_srt, let_off) ->
323 -- union all the global references together
324 let_g = unionUniqSets bind_g body_g
326 -- concatenate the sub-SRTs
327 let_srt = body_srt ++ this_srt
329 -- attach the SRT info to the binding
330 bind' = attach_srt_bind bind off (length this_srt)
332 (let_constr bind' body, let_g, let_srt, let_off)
335 -----------------------------------------------------------------------------
338 Construct the SRT at this point from its sub-SRTs and any new global
339 references which aren't already contained in one of the sub-SRTs (and
343 construct_srt rho global_refs sub_srt current_offset
345 extra_refs = filter (`notElem` sub_srt)
346 (filter (mayHaveCafRefs rho) (uniqSetToList global_refs))
347 this_srt = extra_refs ++ sub_srt
349 -- Add the length of the new entries to the
350 -- current offset to get the next free offset in the global SRT.
351 new_offset = current_offset + length extra_refs
352 in (this_srt, new_offset)
355 -----------------------------------------------------------------------------
359 srtCaseAlts :: UniqFM CafInfo -> (UniqSet Id, UniqFM (UniqSet Id))
360 -> Int -> StgCaseAlts -> (StgCaseAlts, UniqSet Id, [Id], Int)
362 srtCaseAlts rho cont off (StgAlgAlts t alts dflt) =
363 srtAlgAlts 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 (StgAlgAlts t alts dflt, g, srt, off)
372 srtCaseAlts rho cont off (StgPrimAlts t alts dflt) =
373 srtPrimAlts rho cont off alts [] emptyUniqSet []
374 =: \(alts, alts_g, alts_srt, off) ->
375 srtDefault rho cont off dflt =: \(dflt, dflt_g, dflt_srt, off) ->
377 g = unionUniqSets alts_g dflt_g
378 srt = dflt_srt ++ alts_srt
380 (StgPrimAlts t alts dflt, g, srt, off)
382 srtAlgAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
383 srtAlgAlts rho cont off ((con,args,used,rhs):alts) new_alts g srt =
384 srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
386 g' = unionUniqSets rhs_g g
387 srt' = rhs_srt ++ srt
389 srtAlgAlts rho cont off alts ((con,args,used,rhs) : new_alts) g' srt'
391 srtPrimAlts rho cont off [] new_alts g srt = (reverse new_alts, g, srt, off)
392 srtPrimAlts rho cont off ((lit,rhs):alts) new_alts g srt =
393 srtExpr rho cont off rhs =: \(rhs, rhs_g, rhs_srt, off) ->
395 g' = unionUniqSets rhs_g g
396 srt' = rhs_srt ++ srt
398 srtPrimAlts rho cont off alts ((lit,rhs) : new_alts) g' srt'
400 srtDefault rho cont off StgNoDefault = (StgNoDefault,emptyUniqSet,[],off)
401 srtDefault rho cont off (StgBindDefault rhs) =
402 srtExpr rho cont off rhs =: \(rhs, g, srt, off) ->
403 (StgBindDefault rhs, g, srt, off)
406 -----------------------------------------------------------------------------
408 Decide whether a closure looks like a CAF or not. In an effort to
409 keep the number of CAFs (and hence the size of the SRTs) down, we
410 would also like to look at the expression and decide whether it
411 requires a small bounded amount of heap, so we can ignore it as a CAF.
412 In these cases, we need to use an additional CAF list to keep track of
413 non-collectable CAFs.
415 We mark real CAFs as `MayHaveCafRefs' because this information is used
416 to decide whether a particular closure needs to be referenced in an
421 :: StgRhs -- right-hand-side of the definition
422 -> [Id] -- static references
425 -- special case for expressions which are always bottom,
426 -- such as 'error "..."'. We don't need to record it as
427 -- a CAF, since it can only be entered once.
428 mk_caf_info (StgRhsClosure _ _ _ free_vars _ [] e) srt
429 | isBottomingExpr e && null srt = NoCafRefs
431 mk_caf_info (StgRhsClosure _ _ _ free_vars upd args body) srt
432 | isUpdatable upd = MayHaveCafRefs -- a real live CAF
433 | null srt = NoCafRefs -- function w/ no static references
434 | otherwise = MayHaveCafRefs -- function w/ some static references
436 mk_caf_info rcon@(StgRhsCon cc con args) srt
437 | null srt = NoCafRefs -- constructor w/ no static references
438 | otherwise = MayHaveCafRefs -- otherwise, treat as a CAF
441 isBottomingExpr (StgLet bind expr) = isBottomingExpr expr
442 isBottomingExpr (StgApp f args) = idAppIsBottom f (length args)
443 isBottomingExpr _ = False
446 -----------------------------------------------------------------------------
448 Here we decide which Id's to place in the static reference table. An
449 internal top-level id will be in the environment with the appropriate
450 CafInfo, so we use that if available. An imported top-level Id will
451 have the CafInfo attached. Otherwise, we just ignore the Id.
454 getGlobalRefs :: UniqFM CafInfo -> [StgArg] -> UniqSet Id
455 getGlobalRefs rho args = mkUniqSet (concat (map (globalRefArg rho) args))
457 globalRefArg :: UniqFM CafInfo -> StgArg -> [Id]
459 globalRefArg rho (StgVarArg id)
462 case lookupUFM rho id of {
463 Just _ -> [id]; -- Can't look at the caf_info yet...
464 Nothing -> -- but we will look it up and filter later
465 -- in maybeHaveCafRefs
467 if externallyVisibleId id
468 then case idCafInfo id of
469 MayHaveCafRefs -> [id]
474 globalRefArg rho _ = []
478 mayHaveCafRefs rho id =
479 case lookupUFM rho id of
480 Just MayHaveCafRefs -> True
481 Just NoCafRefs -> False
485 -----------------------------------------------------------------------------
489 attach_srt_bind :: StgBinding -> Int -> Int -> StgBinding
490 attach_srt_bind (StgNonRec binder rhs) off len =
491 StgNonRec binder (attach_srt_rhs rhs off len)
492 attach_srt_bind (StgRec binds) off len =
493 StgRec [ (v,attach_srt_rhs rhs off len) | (v,rhs) <- binds ]
495 attach_srt_rhs :: StgRhs -> Int -> Int -> StgRhs
496 attach_srt_rhs (StgRhsCon cc con args) off length
497 = StgRhsCon cc con args
498 attach_srt_rhs (StgRhsClosure cc bi _ free upd args rhs) off length
499 = StgRhsClosure cc bi srt free upd args rhs
501 srt | length == 0 = NoSRT
502 | otherwise = SRT off length
505 all_con_binds (StgNonRec x rhs) = con_rhs rhs
506 all_con_binds (StgRec bs) = all con_rhs (map snd bs)
508 con_rhs (StgRhsCon _ _ _) = True
515 -----------------------------------------------------------------------------
516 Fix up the SRT's in a let-no-escape.
518 (for a description of let-no-escapes, see CgLetNoEscape.lhs)
520 Here's the problem: a let-no-escape isn't represented by an activation
521 record on the stack. It seems either very difficult or impossible to
522 get the liveness bitmap right in the info table, so we don't do it
523 this way (the liveness mask isn't constant).
525 So, the question is how does the garbage collector get access to the
526 SRT for the rhs of the let-no-escape? It can't see an info table, so
527 it must get the SRT from somewhere else. Here's an example:
529 let-no-escape x = .... f ....
531 p -> .... x ... g ....
533 (f and g are global). Suppose we garbage collect while evaluating
534 'blah'. The stack will contain an activation record for the case,
535 which will point to an SRT containing [g] (according to our SRT
536 algorithm above). But, since the case continuation can call x, and
537 hence f, the SRT should really be [f,g].
541 let-no-escape {-rec-} z = \x -> case blah of
547 if we GC while evaluating blah2, then the case continuation on the
548 stack needs to refer to [f] in its SRT, because we can reach f by
549 calling z recursively.
553 The following code fixes up a let-no-escape expression after we've run
554 the SRT algorithm. It needs to know the SRT for the *whole*
555 expression (this is plugged in instead of the SRT for case exprsesions
556 in the body). The good news is that we only need to traverse nested
557 case expressions, since the let-no-escape bound variable can't occur
558 in the rhs of a let or in a case scrutinee.
560 For recursive let-no-escapes, the body is processed as for
561 non-recursive let-no-escapes, but case expressions in the rhs of each
562 binding have their SRTs replaced with the SRT for the binding group
563 (*not* the SRT of the whole let-no-escape expression).
566 lookupPossibleLNE lne_env f =
567 case lookupUFM lne_env f of
568 Nothing -> emptyUniqSet