Merge RtsLabelInfo.Rts* with RtsLabelInfo.Rts*FS
[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 module StgCmmProf (
10 initCostCentres, ccType, ccsType,
11 mkCCostCentre, mkCCostCentreStack,
12
13 -- Cost-centre Profiling
14 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
15 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
16 chooseDynCostCentres,
17 costCentreFrom,
18 curCCS, curCCSAddr,
19 emitSetCCC, emitCCS,
20
21 saveCurrentCostCentre, restoreCurrentCostCentre,
22
23 -- Lag/drag/void stuff
24 ldvEnter, ldvEnterClosure, ldvRecordCreate
25 ) where
26
27 #include "HsVersions.h"
28 #include "../includes/MachDeps.h"
29 -- For WORD_SIZE_IN_BITS only.
30 #include "../includes/rts/Constants.h"
31 -- For LDV_CREATE_MASK, LDV_STATE_USE
32 -- which are StgWords
33 #include "../includes/DerivedConstants.h"
34 -- For REP_xxx constants, which are MachReps
35
36 import StgCmmClosure
37 import StgCmmUtils
38 import StgCmmMonad
39 import SMRep
40
41 import MkZipCfgCmm
42 import Cmm
43 import CmmUtils
44 import CLabel
45
46 import Id
47 import qualified Module
48 import CostCentre
49 import StgSyn
50 import StaticFlags
51 import FastString
52 import Constants -- Lots of field offsets
53 import Outputable
54
55 import Data.Char
56 import Control.Monad
57
58 -----------------------------------------------------------------------------
59 --
60 -- Cost-centre-stack Profiling
61 --
62 -----------------------------------------------------------------------------
63
64 -- Expression representing the current cost centre stack
65 ccsType :: CmmType -- Type of a cost-centre stack
66 ccsType = bWord
67
68 ccType :: CmmType -- Type of a cost centre
69 ccType = bWord
70
71 curCCS :: CmmExpr
72 curCCS = CmmLoad curCCSAddr ccsType
73
74 -- Address of current CCS variable, for storing into
75 curCCSAddr :: CmmExpr
76 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCCS")))
77
78 mkCCostCentre :: CostCentre -> CmmLit
79 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
80
81 mkCCostCentreStack :: CostCentreStack -> CmmLit
82 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
83
84 costCentreFrom :: CmmExpr -- A closure pointer
85 -> CmmExpr -- The cost centre from that closure
86 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
87
88 staticProfHdr :: CostCentreStack -> [CmmLit]
89 -- The profiling header words in a static closure
90 -- Was SET_STATIC_PROF_HDR
91 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
92 staticLdvInit]
93
94 dynProfHdr :: CmmExpr -> [CmmExpr]
95 -- Profiling header words in a dynamic closure
96 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
97
98 initUpdFrameProf :: CmmExpr -> FCode ()
99 -- Initialise the profiling field of an update frame
100 initUpdFrameProf frame_amode
101 = ifProfiling $ -- frame->header.prof.ccs = CCCS
102 emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
103 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
104 -- is unnecessary because it is not used anyhow.
105
106 ---------------------------------------------------------------------------
107 -- Saving and restoring the current cost centre
108 ---------------------------------------------------------------------------
109
110 {- Note [Saving the current cost centre]
111 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
112 The current cost centre is like a global register. Like other
113 global registers, it's a caller-saves one. But consider
114 case (f x) of (p,q) -> rhs
115 Since 'f' may set the cost centre, we must restore it
116 before resuming rhs. So we want code like this:
117 local_cc = CCC -- save
118 r = f( x )
119 CCC = local_cc -- restore
120 That is, we explicitly "save" the current cost centre in
121 a LocalReg, local_cc; and restore it after the call. The
122 C-- infrastructure will arrange to save local_cc across the
123 call.
124
125 The same goes for join points;
126 let j x = join-stuff
127 in blah-blah
128 We want this kind of code:
129 local_cc = CCC -- save
130 blah-blah
131 J:
132 CCC = local_cc -- restore
133 -}
134
135 saveCurrentCostCentre :: FCode (Maybe LocalReg)
136 -- Returns Nothing if profiling is off
137 saveCurrentCostCentre
138 | not opt_SccProfilingOn
139 = return Nothing
140 | otherwise
141 = do { local_cc <- newTemp ccType
142 ; emit (mkAssign (CmmLocal local_cc) curCCS)
143 ; return (Just local_cc) }
144
145 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
146 restoreCurrentCostCentre Nothing
147 = return ()
148 restoreCurrentCostCentre (Just local_cc)
149 = emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))
150
151
152 -------------------------------------------------------------------------------
153 -- Recording allocation in a cost centre
154 -------------------------------------------------------------------------------
155
156 -- | Record the allocation of a closure. The CmmExpr is the cost
157 -- centre stack to which to attribute the allocation.
158 profDynAlloc :: ClosureInfo -> CmmExpr -> FCode ()
159 profDynAlloc cl_info ccs
160 = ifProfiling $
161 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) 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 emit (addToMemE alloc_rep
170 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
171 (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
172 [CmmMachOp mo_wordSub [words,
173 CmmLit (mkIntCLit profHdrSize)]]))
174 -- subtract the "profiling overhead", which is the
175 -- profiling header in a closure.
176 where
177 alloc_rep = REP_CostCentreStack_mem_alloc
178
179 -- ----------------------------------------------------------------------
180 -- Setting the cost centre in a new closure
181
182 chooseDynCostCentres :: CostCentreStack
183 -> [Id] -- Args
184 -> StgExpr -- Body
185 -> FCode (CmmExpr, CmmExpr)
186 -- Called when allocating a closure
187 -- Tells which cost centre to put in the object, and which
188 -- to blame the cost of allocation on
189 chooseDynCostCentres ccs args body = do
190 -- Cost-centre we record in the object
191 use_ccs <- emitCCS ccs
192
193 -- Cost-centre on whom we blame the allocation
194 let blame_ccs
195 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
196 | otherwise = use_ccs
197
198 return (use_ccs, blame_ccs)
199
200
201 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
202 -- These pushes must be performed before we can refer to the stack in
203 -- an expression.
204 emitCCS :: CostCentreStack -> FCode CmmExpr
205 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
206 where
207 (cc's, ccs') = decomposeCCS ccs
208
209 push_em ccs [] = return ccs
210 push_em ccs (cc:rest) = do
211 tmp <- newTemp ccsType
212 pushCostCentre tmp ccs cc
213 push_em (CmmReg (CmmLocal tmp)) rest
214
215 ccsExpr :: CostCentreStack -> CmmExpr
216 ccsExpr ccs
217 | isCurrentCCS ccs = curCCS
218 | otherwise = CmmLit (mkCCostCentreStack ccs)
219
220
221 isBox :: StgExpr -> Bool
222 -- If it's an utterly trivial RHS, then it must be
223 -- one introduced by boxHigherOrderArgs for profiling,
224 -- so we charge it to "OVERHEAD".
225 -- This looks like a GROSS HACK to me --SDM
226 isBox (StgApp _ []) = True
227 isBox _ = False
228
229
230 -- -----------------------------------------------------------------------
231 -- Setting the current cost centre on entry to a closure
232
233 -- For lexically scoped profiling we have to load the cost centre from
234 -- the closure entered, if the costs are not supposed to be inherited.
235 -- This is done immediately on entering the fast entry point.
236
237 -- Load current cost centre from closure, if not inherited.
238 -- Node is guaranteed to point to it, if profiling and not inherited.
239
240 enterCostCentre
241 :: ClosureInfo
242 -> CostCentreStack
243 -> StgExpr -- The RHS of the closure
244 -> FCode ()
245
246 -- We used to have a special case for bindings of form
247 -- f = g True
248 -- where g has arity 2. The RHS is a thunk, but we don't
249 -- need to update it; and we want to subsume costs.
250 -- We don't have these sort of PAPs any more, so the special
251 -- case has gone away.
252
253 enterCostCentre closure_info ccs body
254 = ifProfiling $
255 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
256 enter_cost_centre closure_info ccs body
257
258 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> FCode ()
259 enter_cost_centre closure_info ccs body
260 | isSubsumedCCS ccs
261 = ASSERT(isToplevClosure closure_info)
262 ASSERT(re_entrant)
263 enter_ccs_fsub
264
265 | isDerivedFromCurrentCCS ccs
266 = do {
267 if re_entrant && not is_box
268 then
269 enter_ccs_fun node_ccs
270 else
271 emit (mkStore curCCSAddr node_ccs)
272
273 -- don't forget to bump the scc count. This closure might have been
274 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
275 -- pass has turned into simply let x = e in ...x... and attached
276 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
277 -- we don't lose the scc counter, bump it in the entry code for x.
278 -- ToDo: for a multi-push we should really bump the counter for
279 -- each of the intervening CCSs, not just the top one.
280 ; when (not (isCurrentCCS ccs)) $
281 emit (bumpSccCount curCCS)
282 }
283
284 | isCafCCS ccs
285 = ASSERT(isToplevClosure closure_info)
286 ASSERT(not re_entrant)
287 do { -- This is just a special case of the isDerivedFromCurrentCCS
288 -- case above. We could delete this, but it's a micro
289 -- optimisation and saves a bit of code.
290 emit (mkStore curCCSAddr enc_ccs)
291 ; emit (bumpSccCount node_ccs)
292 }
293
294 | otherwise
295 = panic "enterCostCentre"
296 where
297 enc_ccs = CmmLit (mkCCostCentreStack ccs)
298 re_entrant = closureReEntrant closure_info
299 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
300 is_box = isBox body
301
302 -- if this is a function, then node will be tagged; we must subract the tag
303 node_tag = funTag closure_info
304
305 -- set the current CCS when entering a PAP
306 enterCostCentrePAP :: CmmExpr -> FCode ()
307 enterCostCentrePAP closure =
308 ifProfiling $ do
309 enter_ccs_fun (costCentreFrom closure)
310 enteringPAP 1
311
312 enterCostCentreThunk :: CmmExpr -> FCode ()
313 enterCostCentreThunk closure =
314 ifProfiling $ do
315 emit $ mkStore curCCSAddr (costCentreFrom closure)
316
317 enter_ccs_fun :: CmmExpr -> FCode ()
318 enter_ccs_fun stack = emitRtsCall (fsLit "EnterFunCCS") [(stack,AddrHint)] False
319 -- ToDo: vols
320
321 enter_ccs_fsub :: FCode ()
322 enter_ccs_fsub = enteringPAP 0
323
324 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
325 -- code and the function entry code; we don't want the function's
326 -- entry code to also update CCCS in the event that it was called via
327 -- a PAP, so we set the flag entering_PAP to indicate that we are
328 -- entering via a PAP.
329 enteringPAP :: Integer -> FCode ()
330 enteringPAP n
331 = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (fsLit "entering_PAP"))))
332 (CmmLit (CmmInt n cIntWidth)))
333
334 ifProfiling :: FCode () -> FCode ()
335 ifProfiling code
336 | opt_SccProfilingOn = code
337 | otherwise = nopC
338
339 ifProfilingL :: [a] -> [a]
340 ifProfilingL xs
341 | opt_SccProfilingOn = xs
342 | otherwise = []
343
344
345 ---------------------------------------------------------------
346 -- Initialising Cost Centres & CCSs
347 ---------------------------------------------------------------
348
349 initCostCentres :: CollectedCCs -> FCode CmmAGraph
350 -- Emit the declarations, and return code to register them
351 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
352 = getCode $ whenC opt_SccProfilingOn $
353 do { mapM_ emitCostCentreDecl local_CCs
354 ; mapM_ emitCostCentreStackDecl singleton_CCSs
355 ; emit $ catAGraphs $ map mkRegisterCC local_CCs
356 ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
357
358
359 emitCostCentreDecl :: CostCentre -> FCode ()
360 emitCostCentreDecl cc = do
361 { label <- mkStringCLit (costCentreUserName cc)
362 ; modl <- mkStringCLit (Module.moduleNameString
363 (Module.moduleName (cc_mod cc)))
364 -- All cost centres will be in the main package, since we
365 -- don't normally use -auto-all or add SCCs to other packages.
366 -- Hence don't emit the package name in the module here.
367 ; let lits = [ zero, -- StgInt ccID,
368 label, -- char *label,
369 modl, -- char *module,
370 zero, -- StgWord time_ticks
371 zero64, -- StgWord64 mem_alloc
372 subsumed, -- StgInt is_caf
373 zero -- struct _CostCentre *link
374 ]
375 ; emitDataLits (mkCCLabel cc) lits
376 }
377 where
378 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
379 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
380
381 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
382 emitCostCentreStackDecl ccs
383 = case maybeSingletonCCS ccs of
384 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
385 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
386 where
387 mk_lits cc = zero :
388 mkCCostCentre cc :
389 replicate (sizeof_ccs_words - 2) zero
390 -- Note: to avoid making any assumptions about how the
391 -- C compiler (that compiles the RTS, in particular) does
392 -- layouts of structs containing long-longs, simply
393 -- pad out the struct with zero words until we hit the
394 -- size of the overall struct (which we get via DerivedConstants.h)
395
396 zero :: CmmLit
397 zero = mkIntCLit 0
398 zero64 :: CmmLit
399 zero64 = CmmInt 0 W64
400
401 sizeof_ccs_words :: Int
402 sizeof_ccs_words
403 -- round up to the next word.
404 | ms == 0 = ws
405 | otherwise = ws + 1
406 where
407 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
408
409 -- ---------------------------------------------------------------------------
410 -- Registering CCs and CCSs
411
412 -- (cc)->link = CC_LIST;
413 -- CC_LIST = (cc);
414 -- (cc)->ccID = CC_ID++;
415
416 mkRegisterCC :: CostCentre -> CmmAGraph
417 mkRegisterCC cc
418 = withTemp cInt $ \tmp ->
419 catAGraphs [
420 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
421 (CmmLoad cC_LIST bWord),
422 mkStore cC_LIST cc_lit,
423 mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
424 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
425 mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
426 ]
427 where
428 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
429
430 -- (ccs)->prevStack = CCS_LIST;
431 -- CCS_LIST = (ccs);
432 -- (ccs)->ccsID = CCS_ID++;
433
434 mkRegisterCCS :: CostCentreStack -> CmmAGraph
435 mkRegisterCCS ccs
436 = withTemp cInt $ \ tmp ->
437 catAGraphs [
438 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
439 (CmmLoad cCS_LIST bWord),
440 mkStore cCS_LIST ccs_lit,
441 mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
442 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
443 mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
444 ]
445 where
446 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
447
448
449 cC_LIST, cC_ID :: CmmExpr
450 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_LIST")))
451 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CC_ID")))
452
453 cCS_LIST, cCS_ID :: CmmExpr
454 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_LIST")))
455 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (fsLit "CCS_ID")))
456
457 -- ---------------------------------------------------------------------------
458 -- Set the current cost centre stack
459
460 emitSetCCC :: CostCentre -> FCode ()
461 emitSetCCC cc
462 | not opt_SccProfilingOn = nopC
463 | otherwise = do
464 tmp <- newTemp ccsType -- TODO FIXME NOW
465 ASSERT( sccAbleCostCentre cc )
466 pushCostCentre tmp curCCS cc
467 emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
468 when (isSccCountCostCentre cc) $
469 emit (bumpSccCount curCCS)
470
471 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
472 pushCostCentre result ccs cc
473 = emitRtsCallWithResult result AddrHint
474 (fsLit "PushCostCentre") [(ccs,AddrHint),
475 (CmmLit (mkCCostCentre cc), AddrHint)]
476 False
477
478 bumpSccCount :: CmmExpr -> CmmAGraph
479 bumpSccCount ccs
480 = addToMem REP_CostCentreStack_scc_count
481 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
482
483 -----------------------------------------------------------------------------
484 --
485 -- Lag/drag/void stuff
486 --
487 -----------------------------------------------------------------------------
488
489 --
490 -- Initial value for the LDV field in a static closure
491 --
492 staticLdvInit :: CmmLit
493 staticLdvInit = zeroCLit
494
495 --
496 -- Initial value of the LDV field in a dynamic closure
497 --
498 dynLdvInit :: CmmExpr
499 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
500 CmmMachOp mo_wordOr [
501 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
502 CmmLit (mkWordCLit lDV_STATE_CREATE)
503 ]
504
505 --
506 -- Initialise the LDV word of a new closure
507 --
508 ldvRecordCreate :: CmmExpr -> FCode ()
509 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
510
511 --
512 -- Called when a closure is entered, marks the closure as having been "used".
513 -- The closure is not an 'inherently used' one.
514 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
515 -- profiling.
516 --
517 ldvEnterClosure :: ClosureInfo -> FCode ()
518 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
519 where tag = funTag closure_info
520 -- don't forget to substract node's tag
521
522 ldvEnter :: CmmExpr -> FCode ()
523 -- Argument is a closure pointer
524 ldvEnter cl_ptr
525 = ifProfiling $
526 -- if (era > 0) {
527 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
528 -- era | LDV_STATE_USE }
529 emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
530 (mkStore ldv_wd new_ldv_wd)
531 mkNop)
532 where
533 -- don't forget to substract node's tag
534 ldv_wd = ldvWord cl_ptr
535 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
536 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
537 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
538
539 loadEra :: CmmExpr
540 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
541 [CmmLoad (mkLblExpr (mkRtsDataLabel (fsLit "era"))) cInt]
542
543 ldvWord :: CmmExpr -> CmmExpr
544 -- Takes the address of a closure, and returns
545 -- the address of the LDV word in the closure
546 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
547
548 -- LDV constants, from ghc/includes/Constants.h
549 lDV_SHIFT :: Int
550 lDV_SHIFT = LDV_SHIFT
551 --lDV_STATE_MASK :: StgWord
552 --lDV_STATE_MASK = LDV_STATE_MASK
553 lDV_CREATE_MASK :: StgWord
554 lDV_CREATE_MASK = LDV_CREATE_MASK
555 --lDV_LAST_MASK :: StgWord
556 --lDV_LAST_MASK = LDV_LAST_MASK
557 lDV_STATE_CREATE :: StgWord
558 lDV_STATE_CREATE = LDV_STATE_CREATE
559 lDV_STATE_USE :: StgWord
560 lDV_STATE_USE = LDV_STATE_USE
561