Renamer now preserves location for IEThingWith list items
[ghc.git] / compiler / profiling / SCCfinal.hs
1 -- (c) The GRASP/AQUA Project, Glasgow University, 1992-1998
2 {-# LANGUAGE CPP #-}
3
4 -----------------------------------------------------------------------------
5 -- Modify and collect code generation for final STG program
6
7 {-
8 This is now a sort-of-normal STG-to-STG pass (WDP 94/06), run by stg2stg.
9
10 - Traverses the STG program collecting the cost centres. These are required
11 to declare the cost centres at the start of code generation.
12
13 Note: because of cross-module unfolding, some of these cost centres may be
14 from other modules.
15
16 - Puts on CAF cost-centres if the user has asked for individual CAF
17 cost-centres.
18 -}
19
20 module SCCfinal ( stgMassageForProfiling ) where
21
22 #include "HsVersions.h"
23
24 import StgSyn
25
26 import CostCentre -- lots of things
27 import Id
28 import Name
29 import Module
30 import UniqSupply ( UniqSupply )
31 import ListSetOps ( removeDups )
32 import Outputable
33 import DynFlags
34 import CoreSyn ( Tickish(..) )
35 import FastString
36 import SrcLoc
37 import Util
38
39 import Control.Monad (liftM, ap)
40
41 stgMassageForProfiling
42 :: DynFlags
43 -> Module -- module name
44 -> UniqSupply -- unique supply
45 -> [StgTopBinding] -- input
46 -> (CollectedCCs, [StgTopBinding])
47
48 stgMassageForProfiling dflags mod_name _us stg_binds
49 = let
50 ((local_ccs, extern_ccs, cc_stacks),
51 stg_binds2)
52 = initMM mod_name (do_top_bindings stg_binds)
53
54 (fixed_ccs, fixed_cc_stacks)
55 = if gopt Opt_AutoSccsOnIndividualCafs dflags
56 then ([],[]) -- don't need "all CAFs" CC
57 else ([all_cafs_cc], [all_cafs_ccs])
58
59 local_ccs_no_dups = fst (removeDups cmpCostCentre local_ccs)
60 extern_ccs_no_dups = fst (removeDups cmpCostCentre extern_ccs)
61 in
62 ((fixed_ccs ++ local_ccs_no_dups,
63 extern_ccs_no_dups,
64 fixed_cc_stacks ++ cc_stacks), stg_binds2)
65 where
66
67 span = mkGeneralSrcSpan (mkFastString "<entire-module>") -- XXX do better
68 all_cafs_cc = mkAllCafsCC mod_name span
69 all_cafs_ccs = mkSingletonCCS all_cafs_cc
70
71 ----------
72 do_top_bindings :: [StgTopBinding] -> MassageM [StgTopBinding]
73
74 do_top_bindings [] = return []
75
76 do_top_bindings (StgTopLifted (StgNonRec b rhs) : bs) = do
77 rhs' <- do_top_rhs b rhs
78 bs' <- do_top_bindings bs
79 return (StgTopLifted (StgNonRec b rhs') : bs')
80
81 do_top_bindings (StgTopLifted (StgRec pairs) : bs) = do
82 pairs2 <- mapM do_pair pairs
83 bs' <- do_top_bindings bs
84 return (StgTopLifted (StgRec pairs2) : bs')
85 where
86 do_pair (b, rhs) = do
87 rhs2 <- do_top_rhs b rhs
88 return (b, rhs2)
89
90 do_top_bindings (b@StgTopStringLit{} : bs) = do
91 bs' <- do_top_bindings bs
92 return (b : bs')
93
94 ----------
95 do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
96
97 do_top_rhs _ (StgRhsClosure _ _ _ _ []
98 (StgTick (ProfNote _cc False{-not tick-} _push)
99 (StgConApp con args _)))
100 | not (isDllConApp dflags mod_name con args)
101 -- Trivial _scc_ around nothing but static data
102 -- Eliminate _scc_ ... and turn into StgRhsCon
103
104 -- isDllConApp checks for LitLit args too
105 = return (StgRhsCon dontCareCCS con args)
106
107 do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
108 = do
109 -- Top level CAF without a cost centre attached
110 -- Attach CAF cc (collect if individual CAF ccs)
111 caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
112 then let cc = mkAutoCC binder modl CafCC
113 ccs = mkSingletonCCS cc
114 -- careful: the binder might be :Main.main,
115 -- which doesn't belong to module mod_name.
116 -- bug #249, tests prof001, prof002
117 modl | Just m <- nameModule_maybe (idName binder) = m
118 | otherwise = mod_name
119 in do
120 collectNewCC cc
121 collectCCS ccs
122 return ccs
123 else
124 return all_cafs_ccs
125 body' <- do_expr body
126 return (StgRhsClosure caf_ccs bi fv u [] body')
127
128 do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
129 = do body' <- do_expr body
130 return (StgRhsClosure dontCareCCS bi fv u args body')
131
132 do_top_rhs _ (StgRhsCon _ con args)
133 -- Top-level (static) data is not counted in heap
134 -- profiles; nor do we set CCCS from it; so we
135 -- just slam in dontCareCostCentre
136 = return (StgRhsCon dontCareCCS con args)
137
138 ------
139 do_expr :: StgExpr -> MassageM StgExpr
140
141 do_expr (StgLit l) = return (StgLit l)
142
143 do_expr (StgApp fn args)
144 = return (StgApp fn args)
145
146 do_expr (StgConApp con args ty_args)
147 = return (StgConApp con args ty_args)
148
149 do_expr (StgOpApp con args res_ty)
150 = return (StgOpApp con args res_ty)
151
152 do_expr (StgTick note@(ProfNote cc _ _) expr) = do
153 -- Ha, we found a cost centre!
154 collectCC cc
155 expr' <- do_expr expr
156 return (StgTick note expr')
157
158 do_expr (StgTick ti expr) = do
159 expr' <- do_expr expr
160 return (StgTick ti expr')
161
162 do_expr (StgCase expr bndr alt_type alts) = do
163 expr' <- do_expr expr
164 alts' <- mapM do_alt alts
165 return (StgCase expr' bndr alt_type alts')
166 where
167 do_alt (id, bs, e) = do
168 e' <- do_expr e
169 return (id, bs, e')
170
171 do_expr (StgLet b e) = do
172 (b,e) <- do_let b e
173 return (StgLet b e)
174
175 do_expr (StgLetNoEscape b e) = do
176 (b,e) <- do_let b e
177 return (StgLetNoEscape b e)
178
179 do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
180
181 ----------------------------------
182
183 do_let (StgNonRec b rhs) e = do
184 rhs' <- do_rhs rhs
185 e' <- do_expr e
186 return (StgNonRec b rhs',e')
187
188 do_let (StgRec pairs) e = do
189 pairs' <- mapM do_pair pairs
190 e' <- do_expr e
191 return (StgRec pairs', e')
192 where
193 do_pair (b, rhs) = do
194 rhs2 <- do_rhs rhs
195 return (b, rhs2)
196
197 ----------------------------------
198 do_rhs :: StgRhs -> MassageM StgRhs
199 -- We play much the same game as we did in do_top_rhs above;
200 -- but we don't have to worry about cafs etc.
201
202 -- throw away the SCC if we don't have to count entries. This
203 -- is a little bit wrong, because we're attributing the
204 -- allocation of the constructor to the wrong place (XXX)
205 -- We should really attach (PushCC cc CurrentCCS) to the rhs,
206 -- but need to reinstate PushCC for that.
207 do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
208 (StgTick (ProfNote cc False{-not tick-} _push)
209 (StgConApp con args _)))
210 = do collectCC cc
211 return (StgRhsCon currentCCS con args)
212
213 do_rhs (StgRhsClosure _ bi fv u args expr) = do
214 expr' <- do_expr expr
215 return (StgRhsClosure currentCCS bi fv u args expr')
216
217 do_rhs (StgRhsCon _ con args)
218 = return (StgRhsCon currentCCS con args)
219
220
221 -- -----------------------------------------------------------------------------
222 -- Boring monad stuff for this
223
224 newtype MassageM result
225 = MassageM {
226 unMassageM :: Module -- module name
227 -> CollectedCCs
228 -> (CollectedCCs, result)
229 }
230
231 instance Functor MassageM where
232 fmap = liftM
233
234 instance Applicative MassageM where
235 pure x = MassageM (\_ ccs -> (ccs, x))
236 (<*>) = ap
237 (*>) = thenMM_
238
239 instance Monad MassageM where
240 (>>=) = thenMM
241 (>>) = (*>)
242
243 -- the initMM function also returns the final CollectedCCs
244
245 initMM :: Module -- module name, which we may consult
246 -> MassageM a
247 -> (CollectedCCs, a)
248
249 initMM mod_name (MassageM m) = m mod_name ([],[],[])
250
251 thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b
252 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
253
254 thenMM expr cont = MassageM $ \mod ccs ->
255 case unMassageM expr mod ccs of { (ccs2, result) ->
256 unMassageM (cont result) mod ccs2 }
257
258 thenMM_ expr cont = MassageM $ \mod ccs ->
259 case unMassageM expr mod ccs of { (ccs2, _) ->
260 unMassageM cont mod ccs2 }
261
262
263 collectCC :: CostCentre -> MassageM ()
264 collectCC cc
265 = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
266 -> if (cc `ccFromThisModule` mod_name) then
267 ((cc : local_ccs, extern_ccs, ccss), ())
268 else -- must declare it "extern"
269 ((local_ccs, cc : extern_ccs, ccss), ())
270
271 -- Version of collectCC used when we definitely want to declare this
272 -- CC as local, even if its module name is not the same as the current
273 -- module name (eg. the special :Main module) see bug #249, #1472,
274 -- test prof001,prof002.
275 collectNewCC :: CostCentre -> MassageM ()
276 collectNewCC cc
277 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
278 -> ((cc : local_ccs, extern_ccs, ccss), ())
279
280 collectCCS :: CostCentreStack -> MassageM ()
281
282 collectCCS ccs
283 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
284 -> ASSERT(not (noCCSAttached ccs))
285 ((local_ccs, extern_ccs, ccs : ccss), ())