2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1995
4 \section[SCCfinal]{Modify and collect code generation for final STG program}
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 Type ( isFunType, getTauType )
35 import Id ( mkSysLocal, idType )
36 import SrcLoc ( mkUnknownSrcLoc )
39 import UniqSet ( emptyUniqSet
40 IF_ATTACK_PRAGMAS(COMMA emptyUFM)
44 infixr 9 `thenMM`, `thenMM_`
48 type CollectedCCs = ([CostCentre], -- locally defined ones
49 [CostCentre]) -- ones needing "extern" decls
51 stgMassageForProfiling
52 :: FAST_STRING -> FAST_STRING -- module name, group name
53 -> UniqSupply -- unique supply
54 -> (GlobalSwitch -> Bool) -- command-line opts checker
55 -> [StgBinding] -- input
56 -> (CollectedCCs, [StgBinding])
58 stgMassageForProfiling mod_name grp_name us sw_chkr stg_binds
60 ((local_ccs, extern_ccs),
62 = initMM mod_name us (mapMM do_top_binding stg_binds)
65 = if do_auto_sccs_on_cafs || doing_prelude
66 then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
69 local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs)
70 extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
72 ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
74 do_auto_sccs_on_cafs = sw_chkr AutoSccsOnIndividualCafs -- only use!
75 doing_prelude = sw_chkr CompilingPrelude
77 all_cafs_cc = if doing_prelude
78 then preludeCafsCostCentre
79 else mkAllCafsCC mod_name grp_name
82 do_top_binding :: StgBinding -> MassageM StgBinding
84 do_top_binding (StgNonRec b rhs)
85 = do_top_rhs b rhs `thenMM` \ rhs' ->
86 returnMM (StgNonRec b rhs')
88 do_top_binding (StgRec pairs)
89 = mapMM do_pair pairs `thenMM` \ pairs2 ->
90 returnMM (StgRec pairs2)
93 = do_top_rhs b rhs `thenMM` \ rhs2 ->
97 do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
99 do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
100 -- top-level _scc_ around nothing but static data; toss it -- it's pointless
101 = returnMM (StgRhsCon dontCareCostCentre con args)
103 do_top_rhs binder (StgRhsClosure rhs_cc bi fv u [] (StgSCC ty cc expr))
104 -- Top level CAF with explicit scc expression. Attach CAF
105 -- cost centre to StgRhsClosure and collect.
107 calved_cc = cafifyCC cc
109 collectCC calved_cc `thenMM_`
110 set_prevailing_cc calved_cc (
112 ) `thenMM` \ expr' ->
113 returnMM (StgRhsClosure calved_cc bi fv u [] expr')
115 do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
116 | noCostCentreAttached cc || currentOrSubsumedCosts cc
117 -- Top level CAF without a cost centre attached: Collect
118 -- cost centre with binder name, if collecting CAFs.
121 = if do_auto_sccs_on_cafs then
122 (True, mkAutoCC binder mod_name grp_name IsCafCC)
128 else nopMM) `thenMM_`
129 set_prevailing_cc cc2 (
132 returnMM (StgRhsClosure cc2 bi fv u [] body2)
134 do_top_rhs binder (StgRhsClosure _ bi fv u args body@(StgSCC ty cc expr))
135 -- We blindly use the cc off the _scc_
136 = set_prevailing_cc cc (
138 ) `thenMM` \ body2 ->
139 returnMM (StgRhsClosure cc bi fv u args body2)
141 do_top_rhs binder (StgRhsClosure cc bi fv u args body)
143 cc2 = if noCostCentreAttached cc
144 then subsumedCosts -- it's not a thunk; it is top-level & arity > 0
147 set_prevailing_cc cc2 (
149 ) `thenMM` \ body' ->
150 returnMM (StgRhsClosure cc2 bi fv u args body')
152 do_top_rhs binder (StgRhsCon cc con args)
153 = returnMM (StgRhsCon dontCareCostCentre con args)
154 -- Top-level (static) data is not counted in heap
155 -- profiles; nor do we set CCC from it; so we
156 -- just slam in dontCareCostCentre
159 do_expr :: StgExpr -> MassageM StgExpr
161 do_expr (StgApp fn args lvs)
162 = boxHigherOrderArgs (StgApp fn) args lvs
164 do_expr (StgCon con args lvs)
165 = boxHigherOrderArgs (StgCon con) args lvs
167 do_expr (StgPrim op args lvs)
168 = boxHigherOrderArgs (StgPrim op) args lvs
170 do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
171 = collectCC cc `thenMM_`
172 set_prevailing_cc cc (
174 ) `thenMM` \ expr' ->
175 returnMM (StgSCC ty cc expr')
177 do_expr (StgCase expr fv1 fv2 uniq alts)
178 = do_expr expr `thenMM` \ expr' ->
179 do_alts alts `thenMM` \ alts' ->
180 returnMM (StgCase expr' fv1 fv2 uniq alts')
182 do_alts (StgAlgAlts ty alts def)
183 = mapMM do_alt alts `thenMM` \ alts' ->
184 do_deflt def `thenMM` \ def' ->
185 returnMM (StgAlgAlts ty alts' def')
187 do_alt (id, bs, use_mask, e)
188 = do_expr e `thenMM` \ e' ->
189 returnMM (id, bs, use_mask, e')
191 do_alts (StgPrimAlts ty alts def)
192 = mapMM do_alt alts `thenMM` \ alts' ->
193 do_deflt def `thenMM` \ def' ->
194 returnMM (StgPrimAlts ty alts' def')
197 = do_expr e `thenMM` \ e' ->
200 do_deflt StgNoDefault = returnMM StgNoDefault
201 do_deflt (StgBindDefault b is_used e)
202 = do_expr e `thenMM` \ e' ->
203 returnMM (StgBindDefault b is_used e')
206 = set_prevailing_cc_maybe useCurrentCostCentre (
207 do_binding b `thenMM` \ b' ->
208 do_expr e `thenMM` \ e' ->
209 returnMM (StgLet b' e') )
211 do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
212 = set_prevailing_cc_maybe useCurrentCostCentre (
213 do_binding rhs `thenMM` \ rhs' ->
214 do_expr body `thenMM` \ body' ->
215 returnMM (StgLetNoEscape lvs1 lvs2 rhs' body') )
218 do_binding :: StgBinding -> MassageM StgBinding
220 do_binding (StgNonRec b rhs)
221 = do_rhs rhs `thenMM` \ rhs' ->
222 returnMM (StgNonRec b rhs')
224 do_binding (StgRec pairs)
225 = mapMM do_pair pairs `thenMM` \ new_pairs ->
226 returnMM (StgRec new_pairs)
229 = do_rhs rhs `thenMM` \ rhs' ->
232 do_rhs :: StgRhs -> MassageM StgRhs
233 -- We play much the same game as we did in do_top_rhs above;
234 -- but we don't have to worry about cafifying, etc.
235 -- (ToDo: consolidate??)
237 {- Patrick says NO: it will mess up our counts (WDP 95/07)
238 do_rhs (StgRhsClosure _ bi fv u [] (StgSCC _ cc (StgCon con args lvs)))
239 = collectCC cc `thenMM_`
240 returnMM (StgRhsCon cc con args)
243 do_rhs (StgRhsClosure _ bi fv u args body@(StgSCC _ cc _))
244 = set_prevailing_cc cc (
246 ) `thenMM` \ body' ->
247 returnMM (StgRhsClosure cc bi fv u args body')
249 do_rhs (StgRhsClosure cc bi fv u args body)
250 = use_prevailing_cc_maybe cc `thenMM` \ cc2 ->
251 set_prevailing_cc cc2 (
253 ) `thenMM` \ body' ->
254 returnMM (StgRhsClosure cc2 bi fv u args body')
256 do_rhs (StgRhsCon cc con args)
257 = use_prevailing_cc_maybe cc `thenMM` \ cc2 ->
258 returnMM (StgRhsCon cc2 con args)
259 -- ToDo: Box args (if lex) Pass back let binding???
260 -- Nope: maybe later? WDP 94/06
263 %************************************************************************
265 \subsection{Boxing higher-order args}
267 %************************************************************************
271 :: ([StgArg] -> StgLiveVars -> StgExpr)
272 -- An application lacking its arguments and live-var info
273 -> [StgArg] -- arguments which we might box
274 -> StgLiveVars -- live var info, which we do *not* try
275 -- to maintain/update (setStgVarInfo will
279 boxHigherOrderArgs almost_expr args live_vars
280 = mapAccumMM do_arg [] args `thenMM` \ (let_bindings, new_args) ->
281 get_prevailing_cc `thenMM` \ cc ->
282 returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
285 do_arg bindings atom@(StgLitArg _) = returnMM (bindings, atom)
287 do_arg bindings atom@(StgVarArg old_var)
289 var_type = idType old_var
291 if not (is_fun_type var_type) then
292 returnMM (bindings, atom) -- easy
294 -- make a trivial let-binding for the higher-order guy
295 getUniqueMM `thenMM` \ uniq ->
297 new_var = mkSysLocal SLIT("ho") uniq var_type mkUnknownSrcLoc
299 returnMM ( (new_var, old_var) : bindings, StgVarArg new_var )
301 is_fun_type ty = isFunType (getTauType ty)
304 mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
306 mk_stg_let cc (new_var, old_var) body
308 rhs_body = StgApp (StgVarArg old_var) [{-no args-}] bOGUS_LVs
310 rhs = StgRhsClosure cc
312 [{-junk-}] Updatable [{-no args-}] rhs_body
314 StgLet (StgNonRec new_var rhs) body
316 bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
319 %************************************************************************
321 \subsection{Boring monad stuff for this}
323 %************************************************************************
327 = FAST_STRING -- module name
328 -> CostCentre -- prevailing CostCentre
329 -- if none, subsumedCosts at top-level
330 -- useCurrentCostCentre at nested levels
333 -> (CollectedCCs, result)
335 -- the initUs function also returns the final UniqueSupply and CollectedCCs
337 initMM :: FAST_STRING -- module name, which we may consult
342 initMM mod_name init_us m = m mod_name subsumedCosts{-top-level-} init_us ([],[])
344 thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b
345 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
347 thenMM expr cont mod scope_cc us ccs
348 = case splitUniqSupply us of { (s1, s2) ->
349 case (expr mod scope_cc s1 ccs) of { (ccs2, result) ->
350 cont result mod scope_cc s2 ccs2 }}
352 thenMM_ expr cont mod scope_cc us ccs
353 = case splitUniqSupply us of { (s1, s2) ->
354 case (expr mod scope_cc s1 ccs) of { (ccs2, _) ->
355 cont mod scope_cc s2 ccs2 }}
357 returnMM :: a -> MassageM a
358 returnMM result mod scope_cc us ccs = (ccs, result)
361 nopMM mod scope_cc us ccs = (ccs, ())
363 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
365 mapMM f [] = returnMM []
367 = f m `thenMM` \ r ->
368 mapMM f ms `thenMM` \ rs ->
371 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
373 mapAccumMM f b [] = returnMM (b, [])
374 mapAccumMM f b (m:ms)
375 = f b m `thenMM` \ (b2, r) ->
376 mapAccumMM f b2 ms `thenMM` \ (b3, rs) ->
379 getUniqueMM :: MassageM Unique
380 getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
384 set_prevailing_cc, set_prevailing_cc_maybe
385 :: CostCentre -> MassageM a -> MassageM a
387 set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
388 = action mod cc_to_set_to us ccs
389 -- set unconditionally
391 set_prevailing_cc_maybe cc_to_set_to action mod scope_cc us ccs
393 -- used when switching from top-level to nested
394 -- scope; if we were chugging along as "subsumed",
395 -- we change to the new thing; otherwise we
399 = if (costsAreSubsumed scope_cc)
401 else scope_cc -- carry on as before
403 action mod cc_to_use us ccs
405 get_prevailing_cc :: MassageM CostCentre
406 get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
408 use_prevailing_cc_maybe :: CostCentre -> MassageM CostCentre
410 use_prevailing_cc_maybe cc_to_try mod scope_cc us ccs
413 = if not (noCostCentreAttached cc_to_try
414 || currentOrSubsumedCosts cc_to_try) then
418 -- carry on as before, but be sure it
419 -- isn't marked as CAFish (we're
420 -- crossing a lambda...)
424 uncalved_scope_cc = unCafifyCC scope_cc
428 collectCC :: CostCentre -> MassageM ()
430 collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
431 = ASSERT(not (noCostCentreAttached cc))
432 ASSERT(not (currentOrSubsumedCosts cc))
433 if (cc `ccFromThisModule` mod_name) then
434 ((cc : local_ccs, extern_ccs), ())
435 else -- must declare it "extern"
436 ((local_ccs, cc : extern_ccs), ())