Teach runghc about --help; fixes trac #2757
[ghc-hetmet.git] / compiler / profiling / SCCfinal.lhs
1 %
2 % (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
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 required
9    to declare the cost centres at the start of code generation.
10
11    Note: because of cross-module unfolding, some of these cost centres may be
12    from other modules.  But will still have to give them "extern"
13    declarations.
14
15  - Puts on CAF cost-centres if the user has asked for individual CAF
16    cost-centres.
17
18  - Ditto for individual DICT cost-centres.
19
20  - Boxes top-level inherited functions passed as arguments.
21
22  - "Distributes" given cost-centres to all as-yet-unmarked RHSs.
23
24 \begin{code}
25 module SCCfinal ( stgMassageForProfiling ) where
26
27 #include "HsVersions.h"
28
29 import StgSyn
30
31 import StaticFlags      ( opt_AutoSccsOnIndividualCafs )
32 import CostCentre       -- lots of things
33 import Id
34 import Name
35 import Module
36 import UniqSupply       ( splitUniqSupply, UniqSupply )
37 #ifdef PROF_DO_BOXING
38 import UniqSupply       ( uniqFromSupply )
39 #endif
40 import VarSet
41 import ListSetOps       ( removeDups )
42 import Outputable
43 \end{code}
44
45 \begin{code}
46 stgMassageForProfiling
47         :: PackageId
48         -> Module                       -- module name
49         -> UniqSupply                   -- unique supply
50         -> [StgBinding]                 -- input
51         -> (CollectedCCs, [StgBinding])
52
53 stgMassageForProfiling this_pkg mod_name us stg_binds
54   = let
55         ((local_ccs, extern_ccs, cc_stacks),
56          stg_binds2)
57           = initMM mod_name us (do_top_bindings stg_binds)
58
59         (fixed_ccs, fixed_cc_stacks)
60           = if opt_AutoSccsOnIndividualCafs
61             then ([],[])  -- don't need "all CAFs" CC
62                           -- (for Prelude, we use PreludeCC)
63             else ([all_cafs_cc], [all_cafs_ccs])
64
65         local_ccs_no_dups  = fst (removeDups cmpCostCentre local_ccs)
66         extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
67     in
68     ((fixed_ccs ++ local_ccs_no_dups,
69       extern_ccs_no_dups,
70       fixed_cc_stacks ++ cc_stacks), stg_binds2)
71   where
72
73     all_cafs_cc  = mkAllCafsCC mod_name
74     all_cafs_ccs = mkSingletonCCS all_cafs_cc
75
76     ----------
77     do_top_bindings :: [StgBinding] -> MassageM [StgBinding]
78
79     do_top_bindings [] = return []
80
81     do_top_bindings (StgNonRec b rhs : bs) = do
82         rhs' <- do_top_rhs b rhs
83         addTopLevelIshId b $ do
84            bs' <- do_top_bindings bs
85            return (StgNonRec b rhs' : bs')
86
87     do_top_bindings (StgRec pairs : bs)
88       = addTopLevelIshIds binders $ do
89            pairs2 <- mapM do_pair pairs
90            bs' <- do_top_bindings bs
91            return (StgRec pairs2 : bs')
92       where
93         binders = map fst pairs
94         do_pair (b, rhs) = do
95              rhs2 <- do_top_rhs b rhs
96              return (b, rhs2)
97
98     ----------
99     do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
100
101     do_top_rhs _ (StgRhsClosure _ _ _ _ _ [] (StgSCC cc (StgConApp con args)))
102       | not (isSccCountCostCentre cc) && not (isDllConApp this_pkg con args)
103         -- Trivial _scc_ around nothing but static data
104         -- Eliminate _scc_ ... and turn into StgRhsCon
105
106         -- isDllConApp checks for LitLit args too
107       = return (StgRhsCon dontCareCCS con args)
108
109 {- Can't do this one with cost-centre stacks:  --SDM
110     do_top_rhs binder (StgRhsClosure no_cc bi fv u [] (StgSCC ty cc expr))
111       | (noCCSAttached no_cc || currentOrSubsumedCCS no_cc)
112         && not (isSccCountCostCentre cc)
113         -- Top level CAF without a cost centre attached
114         -- Attach and collect cc of trivial _scc_ in body
115       = do collectCC cc
116            expr' <- set_prevailing_cc cc (do_expr expr)
117            return (StgRhsClosure cc bi fv u [] expr')
118 -}
119
120     do_top_rhs binder (StgRhsClosure no_cc bi fv u srt [] body)
121       | noCCSAttached no_cc || currentOrSubsumedCCS no_cc = do
122         -- Top level CAF without a cost centre attached
123         -- Attach CAF cc (collect if individual CAF ccs)
124         caf_ccs <- if opt_AutoSccsOnIndividualCafs
125                    then let cc = mkAutoCC binder modl CafCC
126                             ccs = mkSingletonCCS cc
127                                    -- careful: the binder might be :Main.main,
128                                    -- which doesn't belong to module mod_name.
129                                    -- bug #249, tests prof001, prof002
130                             modl | Just m <- nameModule_maybe (idName binder) = m
131                                  | otherwise = mod_name
132                         in do
133                         collectNewCC  cc
134                         collectCCS ccs
135                         return ccs
136                    else
137                         return all_cafs_ccs
138         body' <- set_prevailing_cc caf_ccs (do_expr body)
139         return (StgRhsClosure caf_ccs bi fv u srt [] body')
140
141     do_top_rhs _ (StgRhsClosure cc _ _ _ _ [] _)
142         -- Top level CAF with cost centre attached
143         -- Should this be a CAF cc ??? Does this ever occur ???
144       = pprPanic "SCCfinal: CAF with cc:" (ppr cc)
145
146     do_top_rhs _ (StgRhsClosure no_ccs bi fv u srt args body)
147         -- Top level function, probably subsumed
148       | noCCSAttached no_ccs
149       = do body' <- set_lambda_cc (do_expr body)
150            return (StgRhsClosure subsumedCCS bi fv u srt args body')
151
152       | otherwise
153       = pprPanic "SCCfinal: CAF with cc:" (ppr no_ccs)
154
155     do_top_rhs _ (StgRhsCon _ con args)
156         -- Top-level (static) data is not counted in heap
157         -- profiles; nor do we set CCCS from it; so we
158         -- just slam in dontCareCostCentre
159       = return (StgRhsCon dontCareCCS con args)
160
161     ------
162     do_expr :: StgExpr -> MassageM StgExpr
163
164     do_expr (StgLit l) = return (StgLit l)
165
166     do_expr (StgApp fn args)
167       = boxHigherOrderArgs (StgApp fn) args
168
169     do_expr (StgConApp con args)
170       = boxHigherOrderArgs (\args -> StgConApp con args) args
171
172     do_expr (StgOpApp con args res_ty)
173       = boxHigherOrderArgs (\args -> StgOpApp con args res_ty) args
174
175     do_expr (StgSCC cc expr) = do -- Ha, we found a cost centre!
176         collectCC cc
177         expr' <- do_expr expr
178         return (StgSCC cc expr')
179
180     do_expr (StgCase expr fv1 fv2 bndr srt alt_type alts) = do
181         expr' <- do_expr expr
182         alts' <- mapM do_alt alts
183         return (StgCase expr' fv1 fv2 bndr srt alt_type alts')
184       where
185         do_alt (id, bs, use_mask, e) = do
186             e' <- do_expr e
187             return (id, bs, use_mask, e')
188
189     do_expr (StgLet b e) = do
190           (b,e) <- do_let b e
191           return (StgLet b e)
192
193     do_expr (StgLetNoEscape lvs1 lvs2 b e) = do
194           (b,e) <- do_let b e
195           return (StgLetNoEscape lvs1 lvs2 b e)
196
197     do_expr (StgTick m n expr) = do
198           expr' <- do_expr expr
199           return (StgTick m n expr')
200
201     do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
202
203     ----------------------------------
204
205     do_let (StgNonRec b rhs) e = do
206         rhs' <- do_rhs rhs
207         addTopLevelIshId b $ do
208           e' <- do_expr e
209           return (StgNonRec b rhs',e')
210
211     do_let (StgRec pairs) e
212       = addTopLevelIshIds binders $ do
213            pairs' <- mapM do_pair pairs
214            e' <- do_expr e
215            return (StgRec pairs', e')
216       where
217         binders = map fst pairs
218         do_pair (b, rhs) = do
219              rhs2 <- do_rhs rhs
220              return (b, rhs2)
221
222     ----------------------------------
223     do_rhs :: StgRhs -> MassageM StgRhs
224         -- We play much the same game as we did in do_top_rhs above;
225         -- but we don't have to worry about cafs etc.
226
227 {-
228     do_rhs (StgRhsClosure closure_cc bi fv u [] (StgSCC ty cc (StgCon (DataCon con) args _)))
229       | not (isSccCountCostCentre cc)
230       = do collectCC cc
231            return (StgRhsCon cc con args)
232 -}
233
234     do_rhs (StgRhsClosure _ bi fv u srt args expr) = do
235         (expr', ccs) <- slurpSCCs currentCCS expr
236         expr'' <- do_expr expr'
237         return (StgRhsClosure ccs bi fv u srt args expr'')
238       where
239         slurpSCCs ccs (StgSCC cc e)
240              = do collectCC cc
241                   slurpSCCs (cc `pushCCOnCCS` ccs) e
242         slurpSCCs ccs e
243              = return (e, ccs)
244
245     do_rhs (StgRhsCon _ con args)
246       = return (StgRhsCon currentCCS con args)
247 \end{code}
248
249 %************************************************************************
250 %*                                                                      *
251 \subsection{Boxing higher-order args}
252 %*                                                                      *
253 %************************************************************************
254
255 Boxing is *turned off* at the moment, until we can figure out how to
256 do it properly in general.
257
258 \begin{code}
259 boxHigherOrderArgs
260     :: ([StgArg] -> StgExpr)
261                         -- An application lacking its arguments
262     -> [StgArg]         -- arguments which we might box
263     -> MassageM StgExpr
264
265 #ifndef PROF_DO_BOXING
266 boxHigherOrderArgs almost_expr args
267    = return (almost_expr args)
268 #else
269 boxHigherOrderArgs almost_expr args = do
270     ids <- getTopLevelIshIds
271     (let_bindings, new_args) <- mapAccumLM (do_arg ids) [] args
272     return (foldr (mk_stg_let currentCCS) (almost_expr new_args) let_bindings)
273   where
274     ---------------
275
276     do_arg ids bindings arg@(StgVarArg old_var)
277         |  (not (isLocalVar old_var) || elemVarSet old_var ids)
278         && isFunTy (dropForAlls var_type)
279       = do    -- make a trivial let-binding for the top-level function
280         uniq <- getUniqueMM
281         let
282             new_var = mkSysLocal (fsLit "sf") uniq var_type
283         return ( (new_var, old_var) : bindings, StgVarArg new_var )
284       where
285         var_type = idType old_var
286
287     do_arg ids bindings arg = return (bindings, arg)
288
289     ---------------
290     mk_stg_let :: CostCentreStack -> (Id, Id) -> StgExpr -> StgExpr
291
292     mk_stg_let cc (new_var, old_var) body
293       = let
294             rhs_body    = StgApp old_var [{-args-}]
295             rhs_closure = StgRhsClosure cc stgArgOcc [{-fvs-}] ReEntrant NoSRT{-eeek!!!-} [{-args-}] rhs_body
296         in
297         StgLet (StgNonRec new_var rhs_closure) body
298       where
299         bOGUS_LVs = emptyUniqSet -- easier to print than: panic "mk_stg_let: LVs"
300 #endif
301 \end{code}
302
303 %************************************************************************
304 %*                                                                      *
305 \subsection{Boring monad stuff for this}
306 %*                                                                      *
307 %************************************************************************
308
309 \begin{code}
310 newtype MassageM result
311   = MassageM {
312       unMassageM :: Module              -- module name
313                  -> CostCentreStack     -- prevailing CostCentre
314                                         -- if none, subsumedCosts at top-level
315                                         -- currentCostCentre at nested levels
316                  -> UniqSupply
317                  -> VarSet              -- toplevel-ish Ids for boxing
318                  -> CollectedCCs
319                  -> (CollectedCCs, result)
320     }
321
322 instance Monad MassageM where
323     return x = MassageM (\_ _ _ _ ccs -> (ccs, x))
324     (>>=) = thenMM
325     (>>)  = thenMM_
326
327 -- the initMM function also returns the final CollectedCCs
328
329 initMM :: Module        -- module name, which we may consult
330        -> UniqSupply
331        -> MassageM a
332        -> (CollectedCCs, a)
333
334 initMM mod_name init_us (MassageM m) = m mod_name noCCS init_us emptyVarSet ([],[],[])
335
336 thenMM  :: MassageM a -> (a -> MassageM b) -> MassageM b
337 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
338
339 thenMM expr cont = MassageM $ \mod scope_cc us ids ccs ->
340     case splitUniqSupply us of { (s1, s2) ->
341     case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, result) ->
342     unMassageM (cont result) mod scope_cc s2 ids ccs2 }}
343
344 thenMM_ expr cont = MassageM $ \mod scope_cc us ids ccs ->
345     case splitUniqSupply us of { (s1, s2) ->
346     case unMassageM expr mod scope_cc s1 ids ccs of { (ccs2, _) ->
347     unMassageM cont mod scope_cc s2 ids ccs2 }}
348
349 #ifdef PROF_DO_BOXING
350 getUniqueMM :: MassageM Unique
351 getUniqueMM = MassageM \mod scope_cc us ids ccs -> (ccs, uniqFromSupply us)
352 #endif
353
354 addTopLevelIshId :: Id -> MassageM a -> MassageM a
355 addTopLevelIshId id scope
356    = MassageM $ \mod scope_cc us ids ccs ->
357       if isCurrentCCS scope_cc then unMassageM scope mod scope_cc us ids ccs
358                                else unMassageM scope mod scope_cc us (extendVarSet ids id) ccs
359
360 addTopLevelIshIds :: [Id] -> MassageM a -> MassageM a
361 addTopLevelIshIds [] cont = cont
362 addTopLevelIshIds (id:ids) cont
363   = addTopLevelIshId id (addTopLevelIshIds ids cont)
364
365 #ifdef PROF_DO_BOXING
366 getTopLevelIshIds :: MassageM VarSet
367 getTopLevelIshIds = MassageM $ \_mod _scope_cc _us ids ccs -> (ccs, ids)
368 #endif
369 \end{code}
370
371 The prevailing CCS is used to tell whether we're in a top-levelish
372 position, where top-levelish is defined as "not inside a lambda".
373 Prevailing CCs used to be used for something much more complicated,
374 I'm sure --SDM
375
376 \begin{code}
377 set_lambda_cc :: MassageM a -> MassageM a
378 set_lambda_cc action
379    =    MassageM $     \mod _scope_cc  us ids ccs
380    -> unMassageM action mod currentCCS us ids ccs
381
382 set_prevailing_cc :: CostCentreStack -> MassageM a -> MassageM a
383 set_prevailing_cc cc_to_set_to action
384    =    MassageM $     \mod _scope_cc    us ids ccs
385    -> unMassageM action mod cc_to_set_to us ids ccs
386 \end{code}
387
388 \begin{code}
389 collectCC :: CostCentre -> MassageM ()
390 collectCC cc
391  = MassageM $ \mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
392   -> ASSERT(not (noCCAttached cc))
393      if (cc `ccFromThisModule` mod_name) then
394         ((cc : local_ccs, extern_ccs, ccss), ())
395      else -- must declare it "extern"
396         ((local_ccs, cc : extern_ccs, ccss), ())
397
398 -- Version of collectCC used when we definitely want to declare this
399 -- CC as local, even if its module name is not the same as the current
400 -- module name (eg. the special :Main module) see bug #249, #1472,
401 -- test prof001,prof002.
402 collectNewCC :: CostCentre -> MassageM ()
403 collectNewCC cc
404  = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
405               -> ((cc : local_ccs, extern_ccs, ccss), ())
406
407 collectCCS :: CostCentreStack -> MassageM ()
408
409 collectCCS ccs
410  = MassageM $ \_mod_name _scope_cc _us _ids (local_ccs, extern_ccs, ccss)
411               -> ASSERT(not (noCCSAttached ccs))
412                        ((local_ccs, extern_ccs, ccs : ccss), ())
413 \end{code}