b6665544036f2488563d5930071fe31b8c36e853
[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 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
86 -- The profiling header words in a static closure
87 -- Was SET_STATIC_PROF_HDR
88 staticProfHdr dflags ccs
89 = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
90
91 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
92 -- Profiling header words in a dynamic closure
93 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
94
95 initUpdFrameProf :: ByteOff -> FCode ()
96 -- Initialise the profiling field of an update frame
97 initUpdFrameProf frame_off
98 = ifProfiling $ -- frame->header.prof.ccs = CCCS
99 do dflags <- getDynFlags
100 emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs dflags))
101 curCCS
102 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
103 -- is unnecessary because it is not used anyhow.
104
105 ---------------------------------------------------------------------------
106 -- Saving and restoring the current cost centre
107 ---------------------------------------------------------------------------
108
109 {- Note [Saving the current cost centre]
110 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
111 The current cost centre is like a global register. Like other
112 global registers, it's a caller-saves one. But consider
113 case (f x) of (p,q) -> rhs
114 Since 'f' may set the cost centre, we must restore it
115 before resuming rhs. So we want code like this:
116 local_cc = CCC -- save
117 r = f( x )
118 CCC = local_cc -- restore
119 That is, we explicitly "save" the current cost centre in
120 a LocalReg, local_cc; and restore it after the call. The
121 C-- infrastructure will arrange to save local_cc across the
122 call.
123
124 The same goes for join points;
125 let j x = join-stuff
126 in blah-blah
127 We want this kind of code:
128 local_cc = CCC -- save
129 blah-blah
130 J:
131 CCC = local_cc -- restore
132 -}
133
134 saveCurrentCostCentre :: FCode (Maybe LocalReg)
135 -- Returns Nothing if profiling is off
136 saveCurrentCostCentre
137 = do dflags <- getDynFlags
138 if not (dopt Opt_SccProfilingOn dflags)
139 then return Nothing
140 else do local_cc <- newTemp (ccType dflags)
141 emitAssign (CmmLocal local_cc) curCCS
142 return (Just local_cc)
143
144 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
145 restoreCurrentCostCentre Nothing
146 = return ()
147 restoreCurrentCostCentre (Just local_cc)
148 = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
149
150
151 -------------------------------------------------------------------------------
152 -- Recording allocation in a cost centre
153 -------------------------------------------------------------------------------
154
155 -- | Record the allocation of a closure. The CmmExpr is the cost
156 -- centre stack to which to attribute the allocation.
157 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
158 profDynAlloc rep ccs
159 = ifProfiling $
160 do dflags <- getDynFlags
161 profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs
162
163 -- | Record the allocation of a closure (size is given by a CmmExpr)
164 -- The size must be in words, because the allocation counter in a CCS counts
165 -- in words.
166 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
167 profAlloc words ccs
168 = ifProfiling $
169 do dflags <- getDynFlags
170 let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
171 emit (addToMemE alloc_rep
172 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
173 (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
174 [CmmMachOp (mo_wordSub dflags) [words,
175 mkIntExpr dflags (profHdrSize dflags)]]))
176 -- subtract the "profiling overhead", which is the
177 -- profiling header in a closure.
178
179 -- -----------------------------------------------------------------------
180 -- Setting the current cost centre on entry to a closure
181
182 enterCostCentreThunk :: CmmExpr -> FCode ()
183 enterCostCentreThunk closure =
184 ifProfiling $ do
185 dflags <- getDynFlags
186 emit $ storeCurCCS (costCentreFrom dflags closure)
187
188 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
189 enterCostCentreFun ccs closure =
190 ifProfiling $ do
191 if isCurrentCCS ccs
192 then do dflags <- getDynFlags
193 emitRtsCall rtsPackageId (fsLit "enterFunCCS")
194 [(CmmReg (CmmGlobal BaseReg), AddrHint),
195 (costCentreFrom dflags closure, AddrHint)] False
196 else return () -- top-level function, nothing to do
197
198 ifProfiling :: FCode () -> FCode ()
199 ifProfiling code
200 = do dflags <- getDynFlags
201 if dopt Opt_SccProfilingOn dflags
202 then code
203 else nopC
204
205 ifProfilingL :: DynFlags -> [a] -> [a]
206 ifProfilingL dflags xs
207 | dopt Opt_SccProfilingOn dflags = xs
208 | otherwise = []
209
210
211 ---------------------------------------------------------------
212 -- Initialising Cost Centres & CCSs
213 ---------------------------------------------------------------
214
215 initCostCentres :: CollectedCCs -> FCode ()
216 -- Emit the declarations
217 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
218 = do dflags <- getDynFlags
219 whenC (dopt Opt_SccProfilingOn dflags) $
220 do mapM_ emitCostCentreDecl local_CCs
221 mapM_ emitCostCentreStackDecl singleton_CCSs
222
223
224 emitCostCentreDecl :: CostCentre -> FCode ()
225 emitCostCentreDecl cc = do
226 { dflags <- getDynFlags
227 ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
228 | otherwise = zero dflags
229 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
230 ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
231 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
232 $ Module.moduleName
233 $ cc_mod cc)
234 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
235 showPpr dflags (costCentreSrcSpan cc)
236 -- XXX going via FastString to get UTF-8 encoding is silly
237 ; let
238 lits = [ zero dflags, -- StgInt ccID,
239 label, -- char *label,
240 modl, -- char *module,
241 loc, -- char *srcloc,
242 zero64, -- StgWord64 mem_alloc
243 zero dflags, -- StgWord time_ticks
244 is_caf, -- StgInt is_caf
245 zero dflags -- struct _CostCentre *link
246 ]
247 ; emitDataLits (mkCCLabel cc) lits
248 }
249
250 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
251 emitCostCentreStackDecl ccs
252 = case maybeSingletonCCS ccs of
253 Just cc ->
254 do dflags <- getDynFlags
255 let mk_lits cc = zero dflags :
256 mkCCostCentre cc :
257 replicate (sizeof_ccs_words dflags - 2) (zero dflags)
258 -- Note: to avoid making any assumptions about how the
259 -- C compiler (that compiles the RTS, in particular) does
260 -- layouts of structs containing long-longs, simply
261 -- pad out the struct with zero words until we hit the
262 -- size of the overall struct (which we get via DerivedConstants.h)
263 emitDataLits (mkCCSLabel ccs) (mk_lits cc)
264 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
265
266 zero :: DynFlags -> CmmLit
267 zero dflags = mkIntCLit dflags 0
268 zero64 :: CmmLit
269 zero64 = CmmInt 0 W64
270
271 sizeof_ccs_words :: DynFlags -> Int
272 sizeof_ccs_words dflags
273 -- round up to the next word.
274 | ms == 0 = ws
275 | otherwise = ws + 1
276 where
277 (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
278
279 -- ---------------------------------------------------------------------------
280 -- Set the current cost centre stack
281
282 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
283 emitSetCCC cc tick push
284 = do dflags <- getDynFlags
285 if not (dopt Opt_SccProfilingOn dflags)
286 then nopC
287 else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
288 pushCostCentre tmp curCCS cc
289 when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
290 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
291
292 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
293 pushCostCentre result ccs cc
294 = emitRtsCallWithResult result AddrHint
295 rtsPackageId
296 (fsLit "pushCostCentre") [(ccs,AddrHint),
297 (CmmLit (mkCCostCentre cc), AddrHint)]
298 False
299
300 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
301 bumpSccCount dflags ccs
302 = addToMem (rEP_CostCentreStack_scc_count dflags)
303 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
304
305 -----------------------------------------------------------------------------
306 --
307 -- Lag/drag/void stuff
308 --
309 -----------------------------------------------------------------------------
310
311 --
312 -- Initial value for the LDV field in a static closure
313 --
314 staticLdvInit :: DynFlags -> CmmLit
315 staticLdvInit = zeroCLit
316
317 --
318 -- Initial value of the LDV field in a dynamic closure
319 --
320 dynLdvInit :: DynFlags -> CmmExpr
321 dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
322 CmmMachOp (mo_wordOr dflags) [
323 CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
324 CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
325 ]
326
327 --
328 -- Initialise the LDV word of a new closure
329 --
330 ldvRecordCreate :: CmmExpr -> FCode ()
331 ldvRecordCreate closure = do dflags <- getDynFlags
332 emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
333
334 --
335 -- Called when a closure is entered, marks the closure as having been "used".
336 -- The closure is not an 'inherently used' one.
337 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
338 -- profiling.
339 --
340 ldvEnterClosure :: ClosureInfo -> FCode ()
341 ldvEnterClosure closure_info = do dflags <- getDynFlags
342 let tag = funTag dflags closure_info
343 ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
344 -- don't forget to substract node's tag
345
346 ldvEnter :: CmmExpr -> FCode ()
347 -- Argument is a closure pointer
348 ldvEnter cl_ptr = do
349 dflags <- getDynFlags
350 let -- don't forget to substract node's tag
351 ldv_wd = ldvWord dflags cl_ptr
352 new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
353 (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
354 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
355 ifProfiling $
356 -- if (era > 0) {
357 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
358 -- era | LDV_STATE_USE }
359 emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
360 (mkStore ldv_wd new_ldv_wd)
361 mkNop
362
363 loadEra :: DynFlags -> CmmExpr
364 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
365 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era")))
366 (cInt dflags)]
367
368 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
369 -- Takes the address of a closure, and returns
370 -- the address of the LDV word in the closure
371 ldvWord dflags closure_ptr
372 = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
373
374 lDV_CREATE_MASK :: DynFlags -> StgWord
375 lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
376 lDV_STATE_CREATE :: DynFlags -> StgWord
377 lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
378 lDV_STATE_USE :: DynFlags -> StgWord
379 lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
380