2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[SCCfinal]{Modify and collect code generation for final StgProgram}
6 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
8 * Traverses the STG program collecting the cost centres. These are
9 required to declare the cost centres at the start of code
12 Note: because of cross-module unfolding, some of these cost centres
13 may be from other modules. But will still have to give them
14 "extern" declarations.
16 * Puts on CAF cost-centres if the user has asked for individual CAF
19 * Ditto for individual DICT cost-centres.
21 * Boxes top-level inherited functions passed as arguments.
23 * "Distributes" given cost-centres to all as-yet-unmarked RHSs.
26 #include "HsVersions.h"
28 module SCCfinal ( stgMassageForProfiling ) where
30 import Pretty -- ToDo: rm (debugging only)
32 import AbsUniType ( isDictTy, getUniDataTyCon_maybe,
33 isTupleTyCon, isFunType, getTauType,
38 import Id ( mkSysLocal, getIdUniType )
39 import SrcLoc ( mkUnknownSrcLoc )
42 import UniqSet ( emptyUniqSet
43 IF_ATTACK_PRAGMAS(COMMA emptyUFM)
48 infixr 9 `thenMM`, `thenMM_`
52 type CollectedCCs = ([CostCentre], -- locally defined ones
53 [CostCentre]) -- ones needing "extern" decls
55 stgMassageForProfiling
56 :: FAST_STRING -> FAST_STRING -- module name, group name
57 -> SplitUniqSupply -- unique supply
58 -> (GlobalSwitch -> Bool) -- command-line opts checker
59 -> [PlainStgBinding] -- input
60 -> (CollectedCCs, [PlainStgBinding])
62 stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
64 ((local_ccs, extern_ccs),
66 = initMM mod_name us (mapMM do_top_binding stg_binds)
69 = if do_auto_sccs_on_cafs || doing_prelude
70 then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
73 local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs)
74 extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
76 ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
78 do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use!
79 --UNUSED: do_auto_sccs_on_dicts = sw_chkr AutoSccsOnIndividualDicts -- only use! ** UNUSED really **
80 doing_prelude = sw_chkr CompilingPrelude
82 all_cafs_cc = if doing_prelude
83 then preludeCafsCostCentre
84 else mkAllCafsCC mod_name grp_name
87 do_top_binding :: PlainStgBinding -> MassageM PlainStgBinding
89 do_top_binding (StgNonRec b rhs)
90 = do_top_rhs b rhs `thenMM` \ rhs' ->
91 returnMM (StgNonRec b rhs')
93 do_top_binding (StgRec pairs)
94 = mapMM do_pair pairs `thenMM` \ pairs2 ->
95 returnMM (StgRec pairs2)
98 = do_top_rhs b rhs `thenMM` \ rhs2 ->
102 do_top_rhs :: Id -> PlainStgRhs -> MassageM PlainStgRhs
104 do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgConApp con args lvs)))
105 -- top-level _scc_ around nothing but static data; toss it -- it's pointless
106 = returnMM (StgRhsCon dontCareCostCentre con args)
108 do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
110 -- | noCostCentreAttached rhs_cc || currentOrSubsumedCosts rhs_cc
111 -- -- doubtful guard... ToDo?
112 -- Top level CAF with explicit scc expression. Attach CAF
113 -- cost centre to StgRhsClosure and collect.
115 calved_cc = cafifyCC cc
117 collectCC calved_cc `thenMM_`
118 set_prevailing_cc calved_cc (
120 ) `thenMM` \ expr' ->
121 returnMM (StgRhsClosure calved_cc bi fv u [] expr')
123 do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
124 | noCostCentreAttached cc || currentOrSubsumedCosts cc
125 -- Top level CAF without a cost centre attached: Collect
126 -- cost centre with binder name, if collecting CAFs.
129 = if do_auto_sccs_on_cafs then
130 (True, mkAutoCC binder mod_name grp_name IsCafCC)
136 else nopMM) `thenMM_`
137 set_prevailing_cc cc2 (
140 returnMM (StgRhsClosure cc2 bi fv u [] body2)
142 do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
143 -- We blindly use the cc off the _scc_
144 = set_prevailing_cc cc (
146 ) `thenMM` \ body2 ->
147 returnMM (StgRhsClosure cc bi fv u args body2)
149 do_top_rhs binder (StgRhsClosure cc bi fv u args body)
151 cc2 = if noCostCentreAttached cc
152 then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
155 set_prevailing_cc cc2 (
157 ) `thenMM` \ body' ->
158 returnMM (StgRhsClosure cc2 bi fv u args body')
160 do_top_rhs binder (StgRhsCon cc con args)
161 = returnMM (StgRhsCon dontCareCostCentre con args)
162 -- Top-level (static) data is not counted in heap
163 -- profiles; nor do we set CCC from it; so we
164 -- just slam in dontCareCostCentre
167 do_expr :: PlainStgExpr -> MassageM PlainStgExpr
169 do_expr (StgApp fn args lvs)
170 = boxHigherOrderArgs (StgApp fn) args lvs
172 do_expr (StgConApp con args lvs)
173 = boxHigherOrderArgs (StgConApp con) args lvs
175 do_expr (StgPrimApp op args lvs)
176 = boxHigherOrderArgs (StgPrimApp op) args lvs
178 do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
179 = collectCC cc `thenMM_`
180 set_prevailing_cc cc (
182 ) `thenMM` \ expr' ->
183 returnMM (StgSCC ty cc expr')
185 do_expr (StgCase expr fv1 fv2 uniq alts)
186 = do_expr expr `thenMM` \ expr' ->
187 do_alts alts `thenMM` \ alts' ->
188 returnMM (StgCase expr' fv1 fv2 uniq alts')
190 do_alts (StgAlgAlts ty alts def)
191 = mapMM do_alt alts `thenMM` \ alts' ->
192 do_deflt def `thenMM` \ def' ->
193 returnMM (StgAlgAlts ty alts' def')
195 do_alt (id, bs, use_mask, e)
196 = do_expr e `thenMM` \ e' ->
197 returnMM (id, bs, use_mask, e')
199 do_alts (StgPrimAlts ty alts def)
200 = mapMM do_alt alts `thenMM` \ alts' ->
201 do_deflt def `thenMM` \ def' ->
202 returnMM (StgPrimAlts ty alts' def')
205 = do_expr e `thenMM` \ e' ->
208 do_deflt StgNoDefault = returnMM StgNoDefault
209 do_deflt (StgBindDefault b is_used e)
210 = do_expr e `thenMM` \ e' ->
211 returnMM (StgBindDefault b is_used e')
214 = set_prevailing_cc_maybe useCurrentCostCentre (
215 do_binding b `thenMM` \ b' ->
216 do_expr e `thenMM` \ e' ->
217 returnMM (StgLet b' e') )
219 do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
220 = set_prevailing_cc_maybe useCurrentCostCentre (
221 do_binding rhs `thenMM` \ rhs' ->
222 do_expr body `thenMM` \ body' ->
223 returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
226 do_binding :: PlainStgBinding -> MassageM PlainStgBinding
228 do_binding (StgNonRec b rhs)
229 = do_rhs rhs `thenMM` \ rhs' ->
230 returnMM (StgNonRec b rhs')
232 do_binding (StgRec pairs)
233 = mapMM do_pair pairs `thenMM` \ new_pairs ->
234 returnMM (StgRec new_pairs)
237 = do_rhs rhs `thenMM` \ rhs' ->
240 do_rhs :: PlainStgRhs -> MassageM PlainStgRhs
241 -- We play much the same game as we did in do_top_rhs above;
242 -- but we don't have to worry about cafifying, etc.
243 -- (ToDo: consolidate??)
245 {- Patrick says NO: it will mess up our counts (WDP 95/07)
246 do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgConApp con args lvs)))
247 = collectCC cc `thenMM_`
248 returnMM (StgRhsCon cc con args)
251 do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _))
252 = set_prevailing_cc cc (
254 ) `thenMM` \ body' ->
255 returnMM (StgRhsClosure cc bi fv u args body')
257 do_rhs (StgRhsClosure cc bi fv u args body)
258 = use_prevailing_cc_maybe cc `thenMM` \ cc2 ->
259 set_prevailing_cc cc2 (
261 ) `thenMM` \ body' ->
262 returnMM (StgRhsClosure cc2 bi fv u args body')
264 do_rhs (StgRhsCon cc con args)
265 = use_prevailing_cc_maybe cc `thenMM` \ cc2 ->
266 returnMM (StgRhsCon cc2 con args)
267 -- ToDo: Box args (if lex) Pass back let binding???
268 -- Nope: maybe later? WDP 94/06
271 %************************************************************************
273 \subsection{Boxing higher-order args}
275 %************************************************************************
279 :: ([PlainStgAtom] -> PlainStgLiveVars -> PlainStgExpr)
280 -- An application lacking its arguments and live-var info
281 -> [PlainStgAtom] -- arguments which we might box
282 -> PlainStgLiveVars -- live var info, which we do *not* try
283 -- to maintain/update (setStgVarInfo will
285 -> MassageM PlainStgExpr
287 boxHigherOrderArgs almost_expr args live_vars
288 = mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) ->
289 get_prevailing_cc `thenMM` \ cc ->
290 returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
293 do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
295 do_arg bindings atom@(StgVarAtom old_var)
297 var_type = getIdUniType old_var
299 if not (is_fun_type var_type) then
300 returnMM (bindings, atom) -- easy
302 -- make a trivial let-binding for the higher-order guy
303 getUniqueMM `thenMM` \ uniq ->
305 new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
307 returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
309 is_fun_type ty = isFunType (getTauType ty)
312 mk_stg_let :: CostCentre -> (Id, Id) -> PlainStgExpr -> PlainStgExpr
314 mk_stg_let cc (new_var, old_var) body
316 rhs_body = StgApp (StgVarAtom old_var) [{-no args-}] bOGUS_LVs
318 rhs = StgRhsClosure cc
320 [{-junk-}] Updatable [{-no args-}] rhs_body
322 StgLet (StgNonRec new_var rhs) body
324 bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
327 %************************************************************************
329 \subsection{Boring monad stuff for this}
331 %************************************************************************
335 = FAST_STRING -- module name
336 -> CostCentre -- prevailing CostCentre
337 -- if none, subsumedCosts at top-level
338 -- useCurrentCostCentre at nested levels
341 -> (CollectedCCs, result)
343 -- the initUs function also returns the final UniqueSupply and CollectedCCs
345 initMM :: FAST_STRING -- module name, which we may consult
350 initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[])
352 thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b
353 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
355 thenMM expr cont mod scope_cc us ccs
356 = case splitUniqSupply us of { (s1, s2) ->
357 case (expr mod scope_cc s1 ccs) of { (ccs2, result) ->
358 cont result mod scope_cc s2 ccs2 }}
360 thenMM_ expr cont mod scope_cc us ccs
361 = case splitUniqSupply us of { (s1, s2) ->
362 case (expr mod scope_cc s1 ccs) of { (ccs2, _) ->
363 cont mod scope_cc s2 ccs2 }}
365 returnMM :: a -> MassageM a
366 returnMM result mod scope_cc us ccs = (ccs, result)
369 nopMM mod scope_cc us ccs = (ccs, ())
371 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
373 mapMM f [] = returnMM []
375 = f m `thenMM` \ r ->
376 mapMM f ms `thenMM` \ rs ->
379 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
381 mapAccumMM f b [] = returnMM (b, [])
382 mapAccumMM f b (m:ms)
383 = f b m `thenMM` \ (b2, r) ->
384 mapAccumMM f b2 ms `thenMM` \ (b3, rs) ->
387 getUniqueMM :: MassageM Unique
388 getUniqueMM mod scope_cc us ccs = (ccs, getSUnique us)
392 set_prevailing_cc, set_prevailing_cc_maybe
393 :: CostCentre -> MassageM a -> MassageM a
395 set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
396 = action mod cc_to_set_to us ccs
397 -- set unconditionally
399 set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs
401 -- used when switching from top-level to nested
402 -- scope; if we were chugging along as "subsumed",
403 -- we change to the new thing; otherwise we
407 = if (costsAreSubsumed scope_cc)
409 else scope_cc -- carry on as before
411 action mod cc_to_use us ccs
413 get_prevailing_cc :: MassageM CostCentre
414 get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
416 use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre
418 use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs
421 = if not (noCostCentreAttached cc_to_try
422 || currentOrSubsumedCosts cc_to_try) then
426 -- carry on as before, but be sure it
427 -- isn't marked as CAFish (we're
428 -- crossing a lambda...)
432 uncalved_scope_cc = unCafifyCC scope_cc
436 collectCC :: CostCentre -> MassageM ()
438 collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
439 = ASSERT(not (noCostCentreAttached cc))
440 ASSERT(not (currentOrSubsumedCosts cc))
441 if (cc `ccFromThisModule` mod_name) then
442 ((cc : local_ccs, extern_ccs), ())
443 else -- must declare it "extern"
444 ((local_ccs, cc : extern_ccs), ())