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