Implement unboxed sum primitive type
[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 -> [StgBinding] -- input
46 -> (CollectedCCs, [StgBinding])
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 :: [StgBinding] -> MassageM [StgBinding]
73
74 do_top_bindings [] = return []
75
76 do_top_bindings (StgNonRec b rhs : bs) = do
77 rhs' <- do_top_rhs b rhs
78 bs' <- do_top_bindings bs
79 return (StgNonRec b rhs' : bs')
80
81 do_top_bindings (StgRec pairs : bs) = do
82 pairs2 <- mapM do_pair pairs
83 bs' <- do_top_bindings bs
84 return (StgRec pairs2 : bs')
85 where
86 do_pair (b, rhs) = do
87 rhs2 <- do_top_rhs b rhs
88 return (b, rhs2)
89
90 ----------
91 do_top_rhs :: Id -> StgRhs -> MassageM StgRhs
92
93 do_top_rhs _ (StgRhsClosure _ _ _ _ []
94 (StgTick (ProfNote _cc False{-not tick-} _push)
95 (StgConApp con args _)))
96 | not (isDllConApp dflags mod_name con args)
97 -- Trivial _scc_ around nothing but static data
98 -- Eliminate _scc_ ... and turn into StgRhsCon
99
100 -- isDllConApp checks for LitLit args too
101 = return (StgRhsCon dontCareCCS con args)
102
103 do_top_rhs binder (StgRhsClosure _ bi fv u [] body)
104 = do
105 -- Top level CAF without a cost centre attached
106 -- Attach CAF cc (collect if individual CAF ccs)
107 caf_ccs <- if gopt Opt_AutoSccsOnIndividualCafs dflags
108 then let cc = mkAutoCC binder modl CafCC
109 ccs = mkSingletonCCS cc
110 -- careful: the binder might be :Main.main,
111 -- which doesn't belong to module mod_name.
112 -- bug #249, tests prof001, prof002
113 modl | Just m <- nameModule_maybe (idName binder) = m
114 | otherwise = mod_name
115 in do
116 collectNewCC cc
117 collectCCS ccs
118 return ccs
119 else
120 return all_cafs_ccs
121 body' <- do_expr body
122 return (StgRhsClosure caf_ccs bi fv u [] body')
123
124 do_top_rhs _ (StgRhsClosure _no_ccs bi fv u args body)
125 = do body' <- do_expr body
126 return (StgRhsClosure dontCareCCS bi fv u args body')
127
128 do_top_rhs _ (StgRhsCon _ con args)
129 -- Top-level (static) data is not counted in heap
130 -- profiles; nor do we set CCCS from it; so we
131 -- just slam in dontCareCostCentre
132 = return (StgRhsCon dontCareCCS con args)
133
134 ------
135 do_expr :: StgExpr -> MassageM StgExpr
136
137 do_expr (StgLit l) = return (StgLit l)
138
139 do_expr (StgApp fn args)
140 = return (StgApp fn args)
141
142 do_expr (StgConApp con args ty_args)
143 = return (StgConApp con args ty_args)
144
145 do_expr (StgOpApp con args res_ty)
146 = return (StgOpApp con args res_ty)
147
148 do_expr (StgTick note@(ProfNote cc _ _) expr) = do
149 -- Ha, we found a cost centre!
150 collectCC cc
151 expr' <- do_expr expr
152 return (StgTick note expr')
153
154 do_expr (StgTick ti expr) = do
155 expr' <- do_expr expr
156 return (StgTick ti expr')
157
158 do_expr (StgCase expr bndr alt_type alts) = do
159 expr' <- do_expr expr
160 alts' <- mapM do_alt alts
161 return (StgCase expr' bndr alt_type alts')
162 where
163 do_alt (id, bs, e) = do
164 e' <- do_expr e
165 return (id, bs, e')
166
167 do_expr (StgLet b e) = do
168 (b,e) <- do_let b e
169 return (StgLet b e)
170
171 do_expr (StgLetNoEscape b e) = do
172 (b,e) <- do_let b e
173 return (StgLetNoEscape b e)
174
175 do_expr other = pprPanic "SCCfinal.do_expr" (ppr other)
176
177 ----------------------------------
178
179 do_let (StgNonRec b rhs) e = do
180 rhs' <- do_rhs rhs
181 e' <- do_expr e
182 return (StgNonRec b rhs',e')
183
184 do_let (StgRec pairs) e = do
185 pairs' <- mapM do_pair pairs
186 e' <- do_expr e
187 return (StgRec pairs', e')
188 where
189 do_pair (b, rhs) = do
190 rhs2 <- do_rhs rhs
191 return (b, rhs2)
192
193 ----------------------------------
194 do_rhs :: StgRhs -> MassageM StgRhs
195 -- We play much the same game as we did in do_top_rhs above;
196 -- but we don't have to worry about cafs etc.
197
198 -- throw away the SCC if we don't have to count entries. This
199 -- is a little bit wrong, because we're attributing the
200 -- allocation of the constructor to the wrong place (XXX)
201 -- We should really attach (PushCC cc CurrentCCS) to the rhs,
202 -- but need to reinstate PushCC for that.
203 do_rhs (StgRhsClosure _closure_cc _bi _fv _u []
204 (StgTick (ProfNote cc False{-not tick-} _push)
205 (StgConApp con args _)))
206 = do collectCC cc
207 return (StgRhsCon currentCCS con args)
208
209 do_rhs (StgRhsClosure _ bi fv u args expr) = do
210 expr' <- do_expr expr
211 return (StgRhsClosure currentCCS bi fv u args expr')
212
213 do_rhs (StgRhsCon _ con args)
214 = return (StgRhsCon currentCCS con args)
215
216
217 -- -----------------------------------------------------------------------------
218 -- Boring monad stuff for this
219
220 newtype MassageM result
221 = MassageM {
222 unMassageM :: Module -- module name
223 -> CollectedCCs
224 -> (CollectedCCs, result)
225 }
226
227 instance Functor MassageM where
228 fmap = liftM
229
230 instance Applicative MassageM where
231 pure x = MassageM (\_ ccs -> (ccs, x))
232 (<*>) = ap
233 (*>) = thenMM_
234
235 instance Monad MassageM where
236 (>>=) = thenMM
237 (>>) = (*>)
238
239 -- the initMM function also returns the final CollectedCCs
240
241 initMM :: Module -- module name, which we may consult
242 -> MassageM a
243 -> (CollectedCCs, a)
244
245 initMM mod_name (MassageM m) = m mod_name ([],[],[])
246
247 thenMM :: MassageM a -> (a -> MassageM b) -> MassageM b
248 thenMM_ :: MassageM a -> (MassageM b) -> MassageM b
249
250 thenMM expr cont = MassageM $ \mod ccs ->
251 case unMassageM expr mod ccs of { (ccs2, result) ->
252 unMassageM (cont result) mod ccs2 }
253
254 thenMM_ expr cont = MassageM $ \mod ccs ->
255 case unMassageM expr mod ccs of { (ccs2, _) ->
256 unMassageM cont mod ccs2 }
257
258
259 collectCC :: CostCentre -> MassageM ()
260 collectCC cc
261 = MassageM $ \mod_name (local_ccs, extern_ccs, ccss)
262 -> if (cc `ccFromThisModule` mod_name) then
263 ((cc : local_ccs, extern_ccs, ccss), ())
264 else -- must declare it "extern"
265 ((local_ccs, cc : extern_ccs, ccss), ())
266
267 -- Version of collectCC used when we definitely want to declare this
268 -- CC as local, even if its module name is not the same as the current
269 -- module name (eg. the special :Main module) see bug #249, #1472,
270 -- test prof001,prof002.
271 collectNewCC :: CostCentre -> MassageM ()
272 collectNewCC cc
273 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
274 -> ((cc : local_ccs, extern_ccs, ccss), ())
275
276 collectCCS :: CostCentreStack -> MassageM ()
277
278 collectCCS ccs
279 = MassageM $ \_mod_name (local_ccs, extern_ccs, ccss)
280 -> ASSERT(not (noCCSAttached ccs))
281 ((local_ccs, extern_ccs, ccs : ccss), ())