Produce new-style Cmm from the Cmm parser
[ghc.git] / compiler / codeGen / StgCmmProf.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module StgCmmProf (
17 initCostCentres, ccType, ccsType,
18 mkCCostCentre, mkCCostCentreStack,
19
20 -- Cost-centre Profiling
21 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
22 enterCostCentreThunk, enterCostCentreFun,
23 costCentreFrom,
24 curCCS, storeCurCCS,
25 emitSetCCC,
26
27 saveCurrentCostCentre, restoreCurrentCostCentre,
28
29 -- Lag/drag/void stuff
30 ldvEnter, ldvEnterClosure, ldvRecordCreate
31 ) where
32
33 #include "HsVersions.h"
34
35 import StgCmmClosure
36 import StgCmmUtils
37 import StgCmmMonad
38 import SMRep
39
40 import MkGraph
41 import Cmm
42 import CmmUtils
43 import CLabel
44
45 import qualified Module
46 import CostCentre
47 import DynFlags
48 import FastString
49 import Module
50 import Outputable
51
52 import Control.Monad
53 import Data.Char (ord)
54
55 -----------------------------------------------------------------------------
56 --
57 -- Cost-centre-stack Profiling
58 --
59 -----------------------------------------------------------------------------
60
61 -- Expression representing the current cost centre stack
62 ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
63 ccsType = bWord
64
65 ccType :: DynFlags -> CmmType -- Type of a cost centre
66 ccType = bWord
67
68 curCCS :: CmmExpr
69 curCCS = CmmReg (CmmGlobal CCCS)
70
71 storeCurCCS :: CmmExpr -> CmmAGraph
72 storeCurCCS e = mkAssign (CmmGlobal CCCS) e
73
74 mkCCostCentre :: CostCentre -> CmmLit
75 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
76
77 mkCCostCentreStack :: CostCentreStack -> CmmLit
78 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
79
80 costCentreFrom :: DynFlags
81 -> CmmExpr -- A closure pointer
82 -> CmmExpr -- The cost centre from that closure
83 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
84
85 -- | The profiling header words in a static closure
86 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
87 staticProfHdr dflags ccs
88 = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
89
90 -- | Profiling header words in a dynamic closure
91 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
92 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
93
94 -- | Initialise the profiling field of an update frame
95 initUpdFrameProf :: CmmExpr -> FCode ()
96 initUpdFrameProf frame
97 = ifProfiling $ -- frame->header.prof.ccs = CCCS
98 do dflags <- getDynFlags
99 emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
100 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
101 -- is unnecessary because it is not used anyhow.
102
103 ---------------------------------------------------------------------------
104 -- Saving and restoring the current cost centre
105 ---------------------------------------------------------------------------
106
107 {- Note [Saving the current cost centre]
108 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
109 The current cost centre is like a global register. Like other
110 global registers, it's a caller-saves one. But consider
111 case (f x) of (p,q) -> rhs
112 Since 'f' may set the cost centre, we must restore it
113 before resuming rhs. So we want code like this:
114 local_cc = CCC -- save
115 r = f( x )
116 CCC = local_cc -- restore
117 That is, we explicitly "save" the current cost centre in
118 a LocalReg, local_cc; and restore it after the call. The
119 C-- infrastructure will arrange to save local_cc across the
120 call.
121
122 The same goes for join points;
123 let j x = join-stuff
124 in blah-blah
125 We want this kind of code:
126 local_cc = CCC -- save
127 blah-blah
128 J:
129 CCC = local_cc -- restore
130 -}
131
132 saveCurrentCostCentre :: FCode (Maybe LocalReg)
133 -- Returns Nothing if profiling is off
134 saveCurrentCostCentre
135 = do dflags <- getDynFlags
136 if not (dopt Opt_SccProfilingOn dflags)
137 then return Nothing
138 else do local_cc <- newTemp (ccType dflags)
139 emitAssign (CmmLocal local_cc) curCCS
140 return (Just local_cc)
141
142 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
143 restoreCurrentCostCentre Nothing
144 = return ()
145 restoreCurrentCostCentre (Just local_cc)
146 = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
147
148
149 -------------------------------------------------------------------------------
150 -- Recording allocation in a cost centre
151 -------------------------------------------------------------------------------
152
153 -- | Record the allocation of a closure. The CmmExpr is the cost
154 -- centre stack to which to attribute the allocation.
155 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
156 profDynAlloc rep ccs
157 = ifProfiling $
158 do dflags <- getDynFlags
159 profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs
160
161 -- | Record the allocation of a closure (size is given by a CmmExpr)
162 -- The size must be in words, because the allocation counter in a CCS counts
163 -- in words.
164 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
165 profAlloc words ccs
166 = ifProfiling $
167 do dflags <- getDynFlags
168 let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
169 emit (addToMemE alloc_rep
170 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
171 (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
172 [CmmMachOp (mo_wordSub dflags) [words,
173 mkIntExpr dflags (profHdrSize dflags)]]))
174 -- subtract the "profiling overhead", which is the
175 -- profiling header in a closure.
176
177 -- -----------------------------------------------------------------------
178 -- Setting the current cost centre on entry to a closure
179
180 enterCostCentreThunk :: CmmExpr -> FCode ()
181 enterCostCentreThunk closure =
182 ifProfiling $ do
183 dflags <- getDynFlags
184 emit $ storeCurCCS (costCentreFrom dflags closure)
185
186 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
187 enterCostCentreFun ccs closure =
188 ifProfiling $ do
189 if isCurrentCCS ccs
190 then do dflags <- getDynFlags
191 emitRtsCall rtsPackageId (fsLit "enterFunCCS")
192 [(CmmReg (CmmGlobal BaseReg), AddrHint),
193 (costCentreFrom dflags closure, AddrHint)] False
194 else return () -- top-level function, nothing to do
195
196 ifProfiling :: FCode () -> FCode ()
197 ifProfiling code
198 = do dflags <- getDynFlags
199 if dopt Opt_SccProfilingOn dflags
200 then code
201 else return ()
202
203 ifProfilingL :: DynFlags -> [a] -> [a]
204 ifProfilingL dflags xs
205 | dopt Opt_SccProfilingOn dflags = xs
206 | otherwise = []
207
208
209 ---------------------------------------------------------------
210 -- Initialising Cost Centres & CCSs
211 ---------------------------------------------------------------
212
213 initCostCentres :: CollectedCCs -> FCode ()
214 -- Emit the declarations
215 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
216 = do dflags <- getDynFlags
217 when (dopt Opt_SccProfilingOn dflags) $
218 do mapM_ emitCostCentreDecl local_CCs
219 mapM_ emitCostCentreStackDecl singleton_CCSs
220
221
222 emitCostCentreDecl :: CostCentre -> FCode ()
223 emitCostCentreDecl cc = do
224 { dflags <- getDynFlags
225 ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
226 | otherwise = zero dflags
227 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
228 ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
229 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
230 $ Module.moduleName
231 $ cc_mod cc)
232 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
233 showPpr dflags (costCentreSrcSpan cc)
234 -- XXX going via FastString to get UTF-8 encoding is silly
235 ; let
236 lits = [ zero dflags, -- StgInt ccID,
237 label, -- char *label,
238 modl, -- char *module,
239 loc, -- char *srcloc,
240 zero64, -- StgWord64 mem_alloc
241 zero dflags, -- StgWord time_ticks
242 is_caf, -- StgInt is_caf
243 zero dflags -- struct _CostCentre *link
244 ]
245 ; emitDataLits (mkCCLabel cc) lits
246 }
247
248 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
249 emitCostCentreStackDecl ccs
250 = case maybeSingletonCCS ccs of
251 Just cc ->
252 do dflags <- getDynFlags
253 let mk_lits cc = zero dflags :
254 mkCCostCentre cc :
255 replicate (sizeof_ccs_words dflags - 2) (zero dflags)
256 -- Note: to avoid making any assumptions about how the
257 -- C compiler (that compiles the RTS, in particular) does
258 -- layouts of structs containing long-longs, simply
259 -- pad out the struct with zero words until we hit the
260 -- size of the overall struct (which we get via DerivedConstants.h)
261 emitDataLits (mkCCSLabel ccs) (mk_lits cc)
262 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
263
264 zero :: DynFlags -> CmmLit
265 zero dflags = mkIntCLit dflags 0
266 zero64 :: CmmLit
267 zero64 = CmmInt 0 W64
268
269 sizeof_ccs_words :: DynFlags -> Int
270 sizeof_ccs_words dflags
271 -- round up to the next word.
272 | ms == 0 = ws
273 | otherwise = ws + 1
274 where
275 (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
276
277 -- ---------------------------------------------------------------------------
278 -- Set the current cost centre stack
279
280 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
281 emitSetCCC cc tick push
282 = do dflags <- getDynFlags
283 if not (dopt Opt_SccProfilingOn dflags)
284 then return ()
285 else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
286 pushCostCentre tmp curCCS cc
287 when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
288 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
289
290 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
291 pushCostCentre result ccs cc
292 = emitRtsCallWithResult result AddrHint
293 rtsPackageId
294 (fsLit "pushCostCentre") [(ccs,AddrHint),
295 (CmmLit (mkCCostCentre cc), AddrHint)]
296 False
297
298 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
299 bumpSccCount dflags ccs
300 = addToMem (rEP_CostCentreStack_scc_count dflags)
301 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
302
303 -----------------------------------------------------------------------------
304 --
305 -- Lag/drag/void stuff
306 --
307 -----------------------------------------------------------------------------
308
309 --
310 -- Initial value for the LDV field in a static closure
311 --
312 staticLdvInit :: DynFlags -> CmmLit
313 staticLdvInit = zeroCLit
314
315 --
316 -- Initial value of the LDV field in a dynamic closure
317 --
318 dynLdvInit :: DynFlags -> CmmExpr
319 dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
320 CmmMachOp (mo_wordOr dflags) [
321 CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
322 CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
323 ]
324
325 --
326 -- Initialise the LDV word of a new closure
327 --
328 ldvRecordCreate :: CmmExpr -> FCode ()
329 ldvRecordCreate closure = do dflags <- getDynFlags
330 emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
331
332 --
333 -- Called when a closure is entered, marks the closure as having been "used".
334 -- The closure is not an 'inherently used' one.
335 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
336 -- profiling.
337 --
338 ldvEnterClosure :: ClosureInfo -> FCode ()
339 ldvEnterClosure closure_info = do dflags <- getDynFlags
340 let tag = funTag dflags closure_info
341 ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
342 -- don't forget to substract node's tag
343
344 ldvEnter :: CmmExpr -> FCode ()
345 -- Argument is a closure pointer
346 ldvEnter cl_ptr = do
347 dflags <- getDynFlags
348 let -- don't forget to substract node's tag
349 ldv_wd = ldvWord dflags cl_ptr
350 new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
351 (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
352 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
353 ifProfiling $
354 -- if (era > 0) {
355 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
356 -- era | LDV_STATE_USE }
357 emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
358 (mkStore ldv_wd new_ldv_wd)
359 mkNop
360
361 loadEra :: DynFlags -> CmmExpr
362 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
363 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era")))
364 (cInt dflags)]
365
366 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
367 -- Takes the address of a closure, and returns
368 -- the address of the LDV word in the closure
369 ldvWord dflags closure_ptr
370 = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
371