1 -----------------------------------------------------------------------------
3 -- Code generation for profiling
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
10 initCostCentres, ccType, ccsType,
11 mkCCostCentre, mkCCostCentreStack,
13 -- Cost-centre Profiling
14 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
15 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
21 saveCurrentCostCentre, restoreCurrentCostCentre,
23 -- Lag/drag/void stuff
24 ldvEnter, ldvEnterClosure, ldvRecordCreate
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
33 #include "../includes/DerivedConstants.h"
34 -- For REP_xxx constants, which are MachReps
47 import qualified Module
53 import Constants -- Lots of field offsets
59 -----------------------------------------------------------------------------
61 -- Cost-centre-stack Profiling
63 -----------------------------------------------------------------------------
65 -- Expression representing the current cost centre stack
66 ccsType :: CmmType -- Type of a cost-centre stack
69 ccType :: CmmType -- Type of a cost centre
73 curCCS = CmmLoad curCCSAddr ccsType
75 -- Address of current CCS variable, for storing into
77 curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
79 mkCCostCentre :: CostCentre -> CmmLit
80 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
82 mkCCostCentreStack :: CostCentreStack -> CmmLit
83 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
85 costCentreFrom :: CmmExpr -- A closure pointer
86 -> CmmExpr -- The cost centre from that closure
87 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
89 staticProfHdr :: CostCentreStack -> [CmmLit]
90 -- The profiling header words in a static closure
91 -- Was SET_STATIC_PROF_HDR
92 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
95 dynProfHdr :: CmmExpr -> [CmmExpr]
96 -- Profiling header words in a dynamic closure
97 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
99 initUpdFrameProf :: CmmExpr -> FCode ()
100 -- Initialise the profiling field of an update frame
101 initUpdFrameProf frame_amode
102 = ifProfiling $ -- frame->header.prof.ccs = CCCS
103 emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
104 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
105 -- is unnecessary because it is not used anyhow.
107 ---------------------------------------------------------------------------
108 -- Saving and restoring the current cost centre
109 ---------------------------------------------------------------------------
111 {- Note [Saving the current cost centre]
112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
113 The current cost centre is like a global register. Like other
114 global registers, it's a caller-saves one. But consider
115 case (f x) of (p,q) -> rhs
116 Since 'f' may set the cost centre, we must restore it
117 before resuming rhs. So we want code like this:
118 local_cc = CCC -- save
120 CCC = local_cc -- restore
121 That is, we explicitly "save" the current cost centre in
122 a LocalReg, local_cc; and restore it after the call. The
123 C-- infrastructure will arrange to save local_cc across the
126 The same goes for join points;
129 We want this kind of code:
130 local_cc = CCC -- save
133 CCC = local_cc -- restore
136 saveCurrentCostCentre :: FCode (Maybe LocalReg)
137 -- Returns Nothing if profiling is off
138 saveCurrentCostCentre
139 | not opt_SccProfilingOn
142 = do { local_cc <- newTemp ccType
143 ; emit (mkAssign (CmmLocal local_cc) curCCS)
144 ; return (Just local_cc) }
146 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
147 restoreCurrentCostCentre Nothing
149 restoreCurrentCostCentre (Just local_cc)
150 = emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))
153 -------------------------------------------------------------------------------
154 -- Recording allocation in a cost centre
155 -------------------------------------------------------------------------------
157 -- | Record the allocation of a closure. The CmmExpr is the cost
158 -- centre stack to which to attribute the allocation.
159 profDynAlloc :: ClosureInfo -> CmmExpr -> FCode ()
160 profDynAlloc cl_info ccs
162 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
164 -- | Record the allocation of a closure (size is given by a CmmExpr)
165 -- The size must be in words, because the allocation counter in a CCS counts
167 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
170 emit (addToMemE alloc_rep
171 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
172 (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
173 [CmmMachOp mo_wordSub [words,
174 CmmLit (mkIntCLit profHdrSize)]]))
175 -- subtract the "profiling overhead", which is the
176 -- profiling header in a closure.
178 alloc_rep = REP_CostCentreStack_mem_alloc
180 -- ----------------------------------------------------------------------
181 -- Setting the cost centre in a new closure
183 chooseDynCostCentres :: CostCentreStack
186 -> FCode (CmmExpr, CmmExpr)
187 -- Called when allocating a closure
188 -- Tells which cost centre to put in the object, and which
189 -- to blame the cost of allocation on
190 chooseDynCostCentres ccs args body = do
191 -- Cost-centre we record in the object
192 use_ccs <- emitCCS ccs
194 -- Cost-centre on whom we blame the allocation
196 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
197 | otherwise = use_ccs
199 return (use_ccs, blame_ccs)
202 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
203 -- These pushes must be performed before we can refer to the stack in
205 emitCCS :: CostCentreStack -> FCode CmmExpr
206 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
208 (cc's, ccs') = decomposeCCS ccs
210 push_em ccs [] = return ccs
211 push_em ccs (cc:rest) = do
212 tmp <- newTemp ccsType
213 pushCostCentre tmp ccs cc
214 push_em (CmmReg (CmmLocal tmp)) rest
216 ccsExpr :: CostCentreStack -> CmmExpr
218 | isCurrentCCS ccs = curCCS
219 | otherwise = CmmLit (mkCCostCentreStack ccs)
222 isBox :: StgExpr -> Bool
223 -- If it's an utterly trivial RHS, then it must be
224 -- one introduced by boxHigherOrderArgs for profiling,
225 -- so we charge it to "OVERHEAD".
226 -- This looks like a GROSS HACK to me --SDM
227 isBox (StgApp _ []) = True
231 -- -----------------------------------------------------------------------
232 -- Setting the current cost centre on entry to a closure
234 -- For lexically scoped profiling we have to load the cost centre from
235 -- the closure entered, if the costs are not supposed to be inherited.
236 -- This is done immediately on entering the fast entry point.
238 -- Load current cost centre from closure, if not inherited.
239 -- Node is guaranteed to point to it, if profiling and not inherited.
244 -> StgExpr -- The RHS of the closure
247 -- We used to have a special case for bindings of form
249 -- where g has arity 2. The RHS is a thunk, but we don't
250 -- need to update it; and we want to subsume costs.
251 -- We don't have these sort of PAPs any more, so the special
252 -- case has gone away.
254 enterCostCentre closure_info ccs body
256 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
257 enter_cost_centre closure_info ccs body
259 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> FCode ()
260 enter_cost_centre closure_info ccs body
262 = ASSERT(isToplevClosure closure_info)
266 | isDerivedFromCurrentCCS ccs
268 if re_entrant && not is_box
270 enter_ccs_fun node_ccs
272 emit (mkStore curCCSAddr node_ccs)
274 -- don't forget to bump the scc count. This closure might have been
275 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
276 -- pass has turned into simply let x = e in ...x... and attached
277 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
278 -- we don't lose the scc counter, bump it in the entry code for x.
279 -- ToDo: for a multi-push we should really bump the counter for
280 -- each of the intervening CCSs, not just the top one.
281 ; when (not (isCurrentCCS ccs)) $
282 emit (bumpSccCount curCCS)
286 = ASSERT(isToplevClosure closure_info)
287 ASSERT(not re_entrant)
288 do { -- This is just a special case of the isDerivedFromCurrentCCS
289 -- case above. We could delete this, but it's a micro
290 -- optimisation and saves a bit of code.
291 emit (mkStore curCCSAddr enc_ccs)
292 ; emit (bumpSccCount node_ccs)
296 = panic "enterCostCentre"
298 enc_ccs = CmmLit (mkCCostCentreStack ccs)
299 re_entrant = closureReEntrant closure_info
300 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
303 -- if this is a function, then node will be tagged; we must subract the tag
304 node_tag = funTag closure_info
306 -- set the current CCS when entering a PAP
307 enterCostCentrePAP :: CmmExpr -> FCode ()
308 enterCostCentrePAP closure =
310 enter_ccs_fun (costCentreFrom closure)
313 enterCostCentreThunk :: CmmExpr -> FCode ()
314 enterCostCentreThunk closure =
316 emit $ mkStore curCCSAddr (costCentreFrom closure)
318 enter_ccs_fun :: CmmExpr -> FCode ()
319 enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False
322 enter_ccs_fsub :: FCode ()
323 enter_ccs_fsub = enteringPAP 0
325 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
326 -- code and the function entry code; we don't want the function's
327 -- entry code to also update CCCS in the event that it was called via
328 -- a PAP, so we set the flag entering_PAP to indicate that we are
329 -- entering via a PAP.
330 enteringPAP :: Integer -> FCode ()
332 = emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
333 (CmmLit (CmmInt n cIntWidth)))
335 ifProfiling :: FCode () -> FCode ()
337 | opt_SccProfilingOn = code
340 ifProfilingL :: [a] -> [a]
342 | opt_SccProfilingOn = xs
346 ---------------------------------------------------------------
347 -- Initialising Cost Centres & CCSs
348 ---------------------------------------------------------------
350 initCostCentres :: CollectedCCs -> FCode CmmAGraph
351 -- Emit the declarations, and return code to register them
352 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
353 = getCode $ whenC opt_SccProfilingOn $
354 do { mapM_ emitCostCentreDecl local_CCs
355 ; mapM_ emitCostCentreStackDecl singleton_CCSs
356 ; emit $ catAGraphs $ map mkRegisterCC local_CCs
357 ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
360 emitCostCentreDecl :: CostCentre -> FCode ()
361 emitCostCentreDecl cc = do
362 { label <- mkStringCLit (costCentreUserName cc)
363 ; modl <- mkStringCLit (Module.moduleNameString
364 (Module.moduleName (cc_mod cc)))
365 -- All cost centres will be in the main package, since we
366 -- don't normally use -auto-all or add SCCs to other packages.
367 -- Hence don't emit the package name in the module here.
368 ; let lits = [ zero, -- StgInt ccID,
369 label, -- char *label,
370 modl, -- char *module,
371 zero, -- StgWord time_ticks
372 zero64, -- StgWord64 mem_alloc
373 subsumed, -- StgInt is_caf
374 zero -- struct _CostCentre *link
376 ; emitDataLits (mkCCLabel cc) lits
379 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
380 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
382 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
383 emitCostCentreStackDecl ccs
384 = case maybeSingletonCCS ccs of
385 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
386 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
390 replicate (sizeof_ccs_words - 2) zero
391 -- Note: to avoid making any assumptions about how the
392 -- C compiler (that compiles the RTS, in particular) does
393 -- layouts of structs containing long-longs, simply
394 -- pad out the struct with zero words until we hit the
395 -- size of the overall struct (which we get via DerivedConstants.h)
400 zero64 = CmmInt 0 W64
402 sizeof_ccs_words :: Int
404 -- round up to the next word.
408 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
410 -- ---------------------------------------------------------------------------
411 -- Registering CCs and CCSs
413 -- (cc)->link = CC_LIST;
415 -- (cc)->ccID = CC_ID++;
417 mkRegisterCC :: CostCentre -> CmmAGraph
419 = withTemp cInt $ \tmp ->
421 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
422 (CmmLoad cC_LIST bWord),
423 mkStore cC_LIST cc_lit,
424 mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
425 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
426 mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
429 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
431 -- (ccs)->prevStack = CCS_LIST;
433 -- (ccs)->ccsID = CCS_ID++;
435 mkRegisterCCS :: CostCentreStack -> CmmAGraph
437 = withTemp cInt $ \ tmp ->
439 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
440 (CmmLoad cCS_LIST bWord),
441 mkStore cCS_LIST ccs_lit,
442 mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
443 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
444 mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
447 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
450 cC_LIST, cC_ID :: CmmExpr
451 cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
452 cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
454 cCS_LIST, cCS_ID :: CmmExpr
455 cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
456 cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
458 -- ---------------------------------------------------------------------------
459 -- Set the current cost centre stack
461 emitSetCCC :: CostCentre -> FCode ()
463 | not opt_SccProfilingOn = nopC
465 tmp <- newTemp ccsType -- TODO FIXME NOW
466 ASSERT( sccAbleCostCentre cc )
467 pushCostCentre tmp curCCS cc
468 emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
469 when (isSccCountCostCentre cc) $
470 emit (bumpSccCount curCCS)
472 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
473 pushCostCentre result ccs cc
474 = emitRtsCallWithResult result AddrHint
476 (fsLit "PushCostCentre") [(ccs,AddrHint),
477 (CmmLit (mkCCostCentre cc), AddrHint)]
480 bumpSccCount :: CmmExpr -> CmmAGraph
482 = addToMem REP_CostCentreStack_scc_count
483 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
485 -----------------------------------------------------------------------------
487 -- Lag/drag/void stuff
489 -----------------------------------------------------------------------------
492 -- Initial value for the LDV field in a static closure
494 staticLdvInit :: CmmLit
495 staticLdvInit = zeroCLit
498 -- Initial value of the LDV field in a dynamic closure
500 dynLdvInit :: CmmExpr
501 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
502 CmmMachOp mo_wordOr [
503 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
504 CmmLit (mkWordCLit lDV_STATE_CREATE)
508 -- Initialise the LDV word of a new closure
510 ldvRecordCreate :: CmmExpr -> FCode ()
511 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
514 -- Called when a closure is entered, marks the closure as having been "used".
515 -- The closure is not an 'inherently used' one.
516 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
519 ldvEnterClosure :: ClosureInfo -> FCode ()
520 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
521 where tag = funTag closure_info
522 -- don't forget to substract node's tag
524 ldvEnter :: CmmExpr -> FCode ()
525 -- Argument is a closure pointer
529 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
530 -- era | LDV_STATE_USE }
531 emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
532 (mkStore ldv_wd new_ldv_wd)
535 -- don't forget to substract node's tag
536 ldv_wd = ldvWord cl_ptr
537 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
538 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
539 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
542 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
543 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
545 ldvWord :: CmmExpr -> CmmExpr
546 -- Takes the address of a closure, and returns
547 -- the address of the LDV word in the closure
548 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
550 -- LDV constants, from ghc/includes/Constants.h
552 lDV_SHIFT = LDV_SHIFT
553 --lDV_STATE_MASK :: StgWord
554 --lDV_STATE_MASK = LDV_STATE_MASK
555 lDV_CREATE_MASK :: StgWord
556 lDV_CREATE_MASK = LDV_CREATE_MASK
557 --lDV_LAST_MASK :: StgWord
558 --lDV_LAST_MASK = LDV_LAST_MASK
559 lDV_STATE_CREATE :: StgWord
560 lDV_STATE_CREATE = LDV_STATE_CREATE
561 lDV_STATE_USE :: StgWord
562 lDV_STATE_USE = LDV_STATE_USE