[project @ 1997-05-19 00:12:10 by sof]
[ghc-hetmet.git] / ghc / compiler / profiling / SCCfinal.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1996
3 %
4 \section[SCCfinal]{Modify and collect code generation for final STG program}
5
6 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
7
8 * Traverses the STG program collecting the cost centres. These are
9   required to declare the cost centres at the start of code
10   generation.
11
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.
15
16 * Puts on CAF cost-centres if the user has asked for individual CAF
17   cost-centres.
18
19 * Ditto for individual DICT cost-centres.
20
21 * Boxes top-level inherited functions passed as arguments.
22
23 * "Distributes" given cost-centres to all as-yet-unmarked RHSs.
24
25 \begin{code}
26 #include "HsVersions.h"
27
28 module SCCfinal ( stgMassageForProfiling ) where
29
30 IMP_Ubiq(){-uitous-}
31
32 import StgSyn
33
34 import CmdLineOpts      ( opt_AutoSccsOnIndividualCafs,
35                           opt_CompilingGhcInternals
36                         )
37 import CostCentre       -- lots of things
38 import Id               ( idType, mkSysLocal, emptyIdSet, SYN_IE(Id) )
39 import Maybes           ( maybeToBool )
40 import PprStyle         -- ToDo: rm
41 import SrcLoc           ( noSrcLoc )
42 import Type             ( splitSigmaTy, getFunTy_maybe )
43 import UniqSupply       ( getUnique, splitUniqSupply, UniqSupply )
44 import Unique           ( Unique )
45 import Util             ( removeDups, assertPanic )
46
47 infixr 9 `thenMM`, `thenMM_`
48 \end{code}
49
50 \begin{code}
51 type CollectedCCs = ([CostCentre],      -- locally defined ones
52                      [CostCentre])      -- ones needing "extern" decls
53
54 stgMassageForProfiling
55         :: FAST_STRING -> FAST_STRING   -- module name, group name
56         -> UniqSupply                   -- unique supply
57         -> [StgBinding]                 -- input
58         -> (CollectedCCs, [StgBinding])
59
60 stgMassageForProfiling mod_name grp_name us stg_binds
61   = let
62         ((local_ccs, extern_ccs),
63          stg_binds2)
64           = initMM mod_name us (mapMM do_top_binding stg_binds)
65
66         fixed_ccs
67           = if do_auto_sccs_on_cafs || doing_prelude
68             then [] -- don't need "all CAFs" CC (for Prelude, we use PreludeCC)
69             else [all_cafs_cc]
70
71         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
72         extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
73     in
74     ((fixed_ccs ++ local_ccs_no_dups, extern_ccs_no_dups), stg_binds2)
75   where
76     do_auto_sccs_on_cafs  = opt_AutoSccsOnIndividualCafs  -- only use!
77     doing_prelude         = opt_CompilingGhcInternals
78
79     all_cafs_cc = if doing_prelude
80                   then preludeCafsCostCentre
81                   else mkAllCafsCC mod_name grp_name
82
83     ----------
84     do_top_binding :: StgBinding -> MassageM StgBinding
85
86     do_top_binding (StgNonRec b rhs) 
87       = do_top_rhs b rhs                `thenMM` \ rhs' ->
88         returnMM (StgNonRec b rhs')
89
90     do_top_binding (StgRec pairs)
91       = mapMM do_pair pairs             `thenMM` \ pairs2 ->
92         returnMM (StgRec pairs2)
93       where
94         do_pair (b, rhs) 
95            = do_top_rhs b rhs   `thenMM` \ rhs2 ->
96              returnMM (b, rhs2)
97
98     ----------
99     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
100
101     do_top_rhs binder (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
102       | not (isSccCountCostCentre cc)
103         -- Trivial _scc_ around nothing but static data
104         -- Eliminate _scc_ ... and turn into StgRhsCon
105       = returnMM (StgRhsCon dontCareCostCentre con args)
106
107     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
108       | (noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc)
109         && not (isSccCountCostCentre cc)
110         -- Top level CAF without a cost centre attached
111         -- Attach and collect cc of trivial _scc_ in body
112       = collectCC cc                                    `thenMM_`
113         set_prevailing_cc cc (do_expr expr)             `thenMM`  \ expr' ->
114         returnMM (StgRhsClosure cc bi fv u [] expr')
115
116     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] body)
117       | noCostCentreAttached no_cc || currentOrSubsumedCosts no_cc
118         -- Top level CAF without a cost centre attached
119         -- Attach CAF cc (collect if individual CAF ccs)
120       = let
121             (collect, caf_cc)
122               = if do_auto_sccs_on_cafs then
123                    (True, mkAutoCC binder mod_name grp_name IsCafCC)
124                 else
125                    (False, all_cafs_cc)
126         in
127         (if collect then collectCC caf_cc else nopMM)   `thenMM_`
128         set_prevailing_cc caf_cc (do_expr body)         `thenMM`  \ body' ->
129         returnMM (StgRhsClosure caf_cc bi fv u [] body')
130
131     do_top_rhs binder (StgRhsClosure cc bi fv u [] body)
132         -- Top level CAF with cost centre attached
133         -- Should this be a CAF cc ??? Does this ever occur ???
134       = trace ("SCCfinal: CAF with cc: " ++ showCostCentre PprDebug False cc) $
135         collectCC cc                                    `thenMM_`
136         set_prevailing_cc cc (do_expr body)             `thenMM` \ body' ->
137         returnMM (StgRhsClosure cc bi fv u [] body')
138
139     do_top_rhs binder (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
140       | not (isSccCountCostCentre cc)
141         -- Top level function with trivial _scc_ in body
142         -- Attach and collect cc of trivial _scc_
143       = collectCC cc                                    `thenMM_`
144         set_prevailing_cc cc (do_expr expr)             `thenMM` \ expr' ->
145         returnMM (StgRhsClosure cc bi fv u args expr')
146
147     do_top_rhs binder (StgRhsClosure cc bi fv u args body)
148         -- Top level function, probably subsumed
149       = let
150             (cc_closure, cc_body)
151               = if noCostCentreAttached cc
152                 then (subsumedCosts, useCurrentCostCentre)
153                 else (cc, cc)
154         in
155         set_prevailing_cc cc_body (do_expr body)        `thenMM` \ body' ->
156         returnMM (StgRhsClosure cc_closure bi fv u args body')
157
158     do_top_rhs binder (StgRhsCon cc con args)
159         -- Top-level (static) data is not counted in heap
160         -- profiles; nor do we set CCC from it; so we
161         -- just slam in dontCareCostCentre
162       = returnMM (StgRhsCon dontCareCostCentre con args)
163
164     ------
165     do_expr :: StgExpr -> MassageM StgExpr
166
167     do_expr (StgApp fn args lvs)
168       = boxHigherOrderArgs (StgApp fn) args lvs
169
170     do_expr (StgCon con args lvs)
171       = boxHigherOrderArgs (StgCon con) args lvs
172
173     do_expr (StgPrim op args lvs)
174       = boxHigherOrderArgs (StgPrim op) args lvs
175
176     do_expr (StgSCC ty cc expr) -- Ha, we found a cost centre!
177       = collectCC cc                            `thenMM_`
178         set_prevailing_cc cc (do_expr expr)     `thenMM`  \ expr' ->
179         returnMM (StgSCC ty cc expr')
180
181     do_expr (StgCase expr fv1 fv2 uniq alts)
182       = do_expr expr            `thenMM` \ expr' ->
183         do_alts alts            `thenMM` \ alts' ->
184         returnMM (StgCase expr' fv1 fv2 uniq alts')
185       where
186         do_alts (StgAlgAlts ty alts def) 
187           = mapMM do_alt alts   `thenMM` \ alts' ->
188             do_deflt def        `thenMM` \ def' ->
189             returnMM (StgAlgAlts ty alts' def')
190           where
191             do_alt (id, bs, use_mask, e)
192               = do_expr e `thenMM` \ e' ->
193                 returnMM (id, bs, use_mask, e')
194
195         do_alts (StgPrimAlts ty alts def) 
196           = mapMM do_alt alts   `thenMM` \ alts' ->
197             do_deflt def        `thenMM` \ def' ->
198             returnMM (StgPrimAlts ty alts' def')
199           where
200             do_alt (l,e)
201               = do_expr e `thenMM` \ e' ->
202                 returnMM (l,e')
203
204         do_deflt StgNoDefault = returnMM StgNoDefault
205         do_deflt (StgBindDefault b is_used e) 
206           = do_expr e                   `thenMM` \ e' ->
207             returnMM (StgBindDefault b is_used e')
208
209     do_expr (StgLet b e)
210       = do_binding b                    `thenMM` \ b' ->
211         do_expr e                       `thenMM` \ e' ->
212         returnMM (StgLet b' e')
213
214     do_expr (StgLetNoEscape lvs1 lvs2 rhs body)
215       = do_binding rhs                  `thenMM` \ rhs' ->
216         do_expr body                    `thenMM` \ body' ->
217         returnMM (StgLetNoEscape lvs1 lvs2 rhs' body')
218
219     ----------
220     do_binding :: StgBinding -> MassageM StgBinding
221
222     do_binding (StgNonRec b rhs) 
223       = do_rhs rhs                      `thenMM` \ rhs' ->
224         returnMM (StgNonRec b rhs')
225
226     do_binding (StgRec pairs)
227       = mapMM do_pair pairs `thenMM` \ new_pairs ->
228         returnMM (StgRec new_pairs)
229       where
230         do_pair (b, rhs)
231           = do_rhs rhs  `thenMM` \ rhs' ->
232             returnMM (b, rhs')
233
234     do_rhs :: StgRhs -> MassageM StgRhs
235         -- We play much the same game as we did in do_top_rhs above;
236         -- but we don't have to worry about cafs etc.
237
238     do_rhs (StgRhsClosure _ bi fv u [] (StgSCC ty cc (StgCon con args lvs)))
239       | not (isSccCountCostCentre cc)
240       = collectCC cc `thenMM_`
241         returnMM (StgRhsCon cc con args)
242
243     do_rhs (StgRhsClosure _ bi fv u args (StgSCC ty cc expr))
244       | not (isSccCountCostCentre cc)
245       = collectCC cc                            `thenMM_`
246         set_prevailing_cc cc (do_expr expr)     `thenMM` \ expr' ->
247         returnMM (StgRhsClosure cc bi fv u args expr')
248
249     do_rhs (StgRhsClosure cc bi fv u args body)
250       = set_prevailing_cc_maybe cc              $ \ cc' ->
251         set_lambda_cc (do_expr body)            `thenMM` \ body' ->
252         returnMM (StgRhsClosure cc' bi fv u args body')
253
254     do_rhs (StgRhsCon cc con args)
255       = set_prevailing_cc_maybe cc              $ \ cc' ->
256         returnMM (StgRhsCon cc' con args)
257
258         -- ToDo: Box args and sort out any let bindings ???
259         -- Nope: maybe later? WDP 94/06
260 \end{code}
261
262 %************************************************************************
263 %*                                                                      *
264 \subsection{Boxing higher-order args}
265 %*                                                                      *
266 %************************************************************************
267
268 \begin{code}
269 boxHigherOrderArgs
270     :: ([StgArg] -> StgLiveVars -> StgExpr)
271                         -- An application lacking its arguments and live-var info
272     -> [StgArg]         -- arguments which we might box
273     -> StgLiveVars      -- live var info, which we do *not* try
274                         -- to maintain/update (setStgVarInfo will
275                         -- do that)
276     -> MassageM StgExpr
277
278 boxHigherOrderArgs almost_expr args live_vars
279   = returnMM (almost_expr args live_vars)
280
281 {- No boxing for now ... should be moved to desugarer and preserved ... 
282
283 boxHigherOrderArgs almost_expr args live_vars
284   = get_prevailing_cc                   `thenMM` \ cc ->
285     if (isCafCC cc || isDictCC cc) then
286         -- no boxing required inside CAF/DICT cc
287         -- since CAF/DICT functions are subsumed anyway
288         returnMM (almost_expr args live_vars)
289     else
290         mapAccumMM do_arg [] args       `thenMM` \ (let_bindings, new_args) ->
291         returnMM (foldr (mk_stg_let cc) (almost_expr new_args live_vars) let_bindings)
292   where
293     ---------------
294     do_arg bindings atom@(StgLitAtom _) = returnMM (bindings, atom)
295
296     do_arg bindings atom@(StgVarAtom old_var)
297       = let
298             var_type = getIdUniType old_var
299         in
300         if toplevelishId old_var && isFunType (getTauType var_type)
301         then
302             -- make a trivial let-binding for the top-level function
303             getUniqueMM         `thenMM` \ uniq ->
304             let
305                 new_var = mkSysLocal SLIT("ho") uniq var_type noSrcLoc
306             in
307             returnMM ( (new_var, old_var) : bindings, StgVarAtom new_var )
308         else
309             returnMM (bindings, atom)
310
311     ---------------
312     mk_stg_let :: CostCentre -> (Id, Id) -> StgExpr -> StgExpr
313
314     mk_stg_let cc (new_var, old_var) body
315       = let
316             rhs_body    = StgApp (StgVarAtom old_var) [{-args-}] bOGUS_LVs
317             rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant [{-args-}] rhs_body
318         in
319         StgLet (StgNonRec new_var rhs_closure) body
320       where
321         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
322 -}
323 \end{code}
324
325 %************************************************************************
326 %*                                                                      *
327 \subsection{Boring monad stuff for this}
328 %*                                                                      *
329 %************************************************************************
330
331 \begin{code}
332 type MassageM result
333   =  FAST_STRING        -- module name
334   -> CostCentre         -- prevailing CostCentre
335                         -- if none, subsumedCosts at top-level
336                         -- useCurrentCostCentre at nested levels
337   -> UniqSupply
338   -> CollectedCCs
339   -> (CollectedCCs, result)
340
341 -- the initUs function also returns the final UniqueSupply and CollectedCCs
342
343 initMM :: FAST_STRING   -- module name, which we may consult
344        -> UniqSupply
345        -> MassageM a
346        -> (CollectedCCs, a)
347
348 initMM mod_name init_us m = m mod_name noCostCentre init_us ([],[])
349
350 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
351 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
352
353 thenMM expr cont mod scope_cc us ccs
354   = case splitUniqSupply us     of { (s1, s2) ->
355     case (expr mod scope_cc s1 ccs)     of { (ccs2, result) ->
356     cont result mod scope_cc s2 ccs2 }}
357
358 thenMM_ expr cont mod scope_cc us ccs
359   = case splitUniqSupply us     of { (s1, s2) ->
360     case (expr mod scope_cc s1 ccs)     of { (ccs2, _) ->
361     cont mod scope_cc s2 ccs2 }}
362
363 returnMM :: a -> MassageM a
364 returnMM result mod scope_cc us ccs = (ccs, result)
365
366 nopMM :: MassageM ()
367 nopMM mod scope_cc us ccs = (ccs, ())
368
369 mapMM :: (a -> MassageM b) -> [a] -> MassageM [b]
370
371 mapMM f [] = returnMM []
372 mapMM f (m:ms)
373   = f m         `thenMM` \ r  ->
374     mapMM f ms  `thenMM` \ rs ->
375     returnMM (r:rs)
376
377 mapAccumMM :: (acc -> x -> MassageM (acc, y)) -> acc -> [x] -> MassageM (acc, [y])
378
379 mapAccumMM f b [] = returnMM (b, [])
380 mapAccumMM f b (m:ms)
381   = f b m               `thenMM` \ (b2, r)  ->
382     mapAccumMM f b2 ms  `thenMM` \ (b3, rs) ->
383     returnMM (b3, r:rs)
384
385 getUniqueMM :: MassageM Unique
386 getUniqueMM mod scope_cc us ccs = (ccs, getUnique us)
387 \end{code}
388
389 \begin{code}
390 set_prevailing_cc :: CostCentre -> MassageM a -> MassageM a
391 set_prevailing_cc cc_to_set_to action mod scope_cc us ccs
392         -- set unconditionally
393   = action mod cc_to_set_to us ccs
394
395 set_prevailing_cc_maybe :: CostCentre -> (CostCentre -> MassageM a) -> MassageM a
396 set_prevailing_cc_maybe cc_to_try action mod scope_cc us ccs
397         -- set only if a real cost centre
398   = let
399         cc_to_use
400           = if noCostCentreAttached cc_to_try || currentOrSubsumedCosts cc_to_try
401             then scope_cc    -- carry on as before
402             else cc_to_try   -- use new cost centre
403     in
404     action cc_to_use mod cc_to_use us ccs
405
406 set_lambda_cc :: MassageM a -> MassageM a
407 set_lambda_cc action mod scope_cc us ccs
408         -- used when moving inside a lambda;
409         -- if we were chugging along as "caf/dict" we change to "ccc"
410   = let
411         cc_to_use
412           = if isCafCC scope_cc || isDictCC scope_cc
413             then useCurrentCostCentre
414             else scope_cc
415     in
416     action mod cc_to_use us ccs
417
418
419 get_prevailing_cc :: MassageM CostCentre
420 get_prevailing_cc mod scope_cc us ccs = (ccs, scope_cc)
421
422 \end{code}
423
424 \begin{code}
425 collectCC :: CostCentre -> MassageM ()
426
427 collectCC cc mod_name scope_cc us (local_ccs, extern_ccs)
428   = ASSERT(not (noCostCentreAttached cc))
429     ASSERT(not (currentOrSubsumedCosts cc))
430     if (cc `ccFromThisModule` mod_name) then
431         ((cc : local_ccs, extern_ccs), ())
432     else -- must declare it "extern"
433         ((local_ccs, cc : extern_ccs), ())
434 \end{code}