1 -----------------------------------------------------------------------------
3 -- Code generation for profiling
5 -- (c) The University of Glasgow 2004-2006
7 -----------------------------------------------------------------------------
10 mkCCostCentre, mkCCostCentreStack,
12 -- Cost-centre Profiling
13 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
14 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
18 emitCostCentreDecl, emitCostCentreStackDecl,
19 emitRegisterCC, emitRegisterCCS,
22 -- Lag/drag/void stuff
23 ldvEnter, ldvEnterClosure, ldvRecordCreate
26 #include "HsVersions.h"
28 -- For WORD_SIZE_IN_BITS only.
29 #include "../includes/Constants.h"
30 -- For LDV_CREATE_MASK, LDV_STATE_USE
32 #include "../includes/DerivedConstants.h"
33 -- For REP_xxx constants, which are MachReps
46 import qualified Module
51 import Constants -- Lots of field offsets
58 -----------------------------------------------------------------------------
60 -- Cost-centre-stack Profiling
62 -----------------------------------------------------------------------------
64 -- Expression representing the current cost centre stack
66 curCCS = CmmLoad curCCSAddr wordRep
68 -- Address of current CCS variable, for storing into
70 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
72 mkCCostCentre :: CostCentre -> CmmLit
73 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
75 mkCCostCentreStack :: CostCentreStack -> CmmLit
76 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
78 costCentreFrom :: CmmExpr -- A closure pointer
79 -> CmmExpr -- The cost centre from that closure
80 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
82 staticProfHdr :: CostCentreStack -> [CmmLit]
83 -- The profiling header words in a static closure
84 -- Was SET_STATIC_PROF_HDR
85 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
88 dynProfHdr :: CmmExpr -> [CmmExpr]
89 -- Profiling header words in a dynamic closure
90 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
92 initUpdFrameProf :: CmmExpr -> Code
93 -- Initialise the profiling field of an update frame
94 initUpdFrameProf frame_amode
95 = ifProfiling $ -- frame->header.prof.ccs = CCCS
96 stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
97 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
98 -- is unnecessary because it is not used anyhow.
100 -- -----------------------------------------------------------------------------
101 -- Recording allocation in a cost centre
103 -- | Record the allocation of a closure. The CmmExpr is the cost
104 -- centre stack to which to attribute the allocation.
105 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
106 profDynAlloc cl_info ccs
108 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
110 -- | Record the allocation of a closure (size is given by a CmmExpr)
111 -- The size must be in words, because the allocation counter in a CCS counts
113 profAlloc :: CmmExpr -> CmmExpr -> Code
116 stmtC (addToMemE alloc_rep
117 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
118 (CmmMachOp (MO_U_Conv wordRep alloc_rep) $
119 [CmmMachOp mo_wordSub [words,
120 CmmLit (mkIntCLit profHdrSize)]]))
121 -- subtract the "profiling overhead", which is the
122 -- profiling header in a closure.
124 alloc_rep = REP_CostCentreStack_mem_alloc
126 -- ----------------------------------------------------------------------
127 -- Setting the cost centre in a new closure
129 chooseDynCostCentres :: CostCentreStack
132 -> FCode (CmmExpr, CmmExpr)
133 -- Called when alllcating a closure
134 -- Tells which cost centre to put in the object, and which
135 -- to blame the cost of allocation on
136 chooseDynCostCentres ccs args body = do
137 -- Cost-centre we record in the object
138 use_ccs <- emitCCS ccs
140 -- Cost-centre on whom we blame the allocation
142 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
143 | otherwise = use_ccs
145 return (use_ccs, blame_ccs)
148 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
149 -- These pushes must be performed before we can refer to the stack in
151 emitCCS :: CostCentreStack -> FCode CmmExpr
152 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
154 (cc's, ccs') = decomposeCCS ccs
156 push_em ccs [] = return ccs
157 push_em ccs (cc:rest) = do
158 tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW
159 pushCostCentre tmp ccs cc
160 push_em (CmmReg (CmmLocal tmp)) rest
162 ccsExpr :: CostCentreStack -> CmmExpr
164 | isCurrentCCS ccs = curCCS
165 | otherwise = CmmLit (mkCCostCentreStack ccs)
168 isBox :: StgExpr -> Bool
169 -- If it's an utterly trivial RHS, then it must be
170 -- one introduced by boxHigherOrderArgs for profiling,
171 -- so we charge it to "OVERHEAD".
172 -- This looks like a GROSS HACK to me --SDM
173 isBox (StgApp fun []) = True
177 -- -----------------------------------------------------------------------
178 -- Setting the current cost centre on entry to a closure
180 -- For lexically scoped profiling we have to load the cost centre from
181 -- the closure entered, if the costs are not supposed to be inherited.
182 -- This is done immediately on entering the fast entry point.
184 -- Load current cost centre from closure, if not inherited.
185 -- Node is guaranteed to point to it, if profiling and not inherited.
190 -> StgExpr -- The RHS of the closure
193 -- We used to have a special case for bindings of form
195 -- where g has arity 2. The RHS is a thunk, but we don't
196 -- need to update it; and we want to subsume costs.
197 -- We don't have these sort of PAPs any more, so the special
198 -- case has gone away.
200 enterCostCentre closure_info ccs body
202 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
203 enter_cost_centre closure_info ccs body
205 enter_cost_centre closure_info ccs body
207 = ASSERT(isToplevClosure closure_info)
211 | isDerivedFromCurrentCCS ccs
213 if re_entrant && not is_box
215 enter_ccs_fun node_ccs
217 stmtC (CmmStore curCCSAddr node_ccs)
219 -- don't forget to bump the scc count. This closure might have been
220 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
221 -- pass has turned into simply let x = e in ...x... and attached
222 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
223 -- we don't lose the scc counter, bump it in the entry code for x.
224 -- ToDo: for a multi-push we should really bump the counter for
225 -- each of the intervening CCSs, not just the top one.
226 ; when (not (isCurrentCCS ccs)) $
227 stmtC (bumpSccCount curCCS)
231 = ASSERT(isToplevClosure closure_info)
232 ASSERT(not re_entrant)
233 do { -- This is just a special case of the isDerivedFromCurrentCCS
234 -- case above. We could delete this, but it's a micro
235 -- optimisation and saves a bit of code.
236 stmtC (CmmStore curCCSAddr enc_ccs)
237 ; stmtC (bumpSccCount node_ccs)
241 = panic "enterCostCentre"
243 enc_ccs = CmmLit (mkCCostCentreStack ccs)
244 re_entrant = closureReEntrant closure_info
245 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
248 -- if this is a function, then node will be tagged; we must subract the tag
249 node_tag = funTag closure_info
251 -- set the current CCS when entering a PAP
252 enterCostCentrePAP :: CmmExpr -> Code
253 enterCostCentrePAP closure =
255 enter_ccs_fun (costCentreFrom closure)
258 enterCostCentreThunk :: CmmExpr -> Code
259 enterCostCentreThunk closure =
261 stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
263 enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)] False
266 enter_ccs_fsub = enteringPAP 0
268 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
269 -- code and the function entry code; we don't want the function's
270 -- entry code to also update CCCS in the event that it was called via
271 -- a PAP, so we set the flag entering_PAP to indicate that we are
272 -- entering via a PAP.
273 enteringPAP :: Integer -> Code
275 = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
276 (CmmLit (CmmInt n cIntRep)))
278 ifProfiling :: Code -> Code
280 | opt_SccProfilingOn = code
283 ifProfilingL :: [a] -> [a]
285 | opt_SccProfilingOn = xs
289 -- ---------------------------------------------------------------------------
290 -- Initialising Cost Centres & CCSs
295 emitCostCentreDecl cc = do
296 { label <- mkStringCLit (costCentreUserName cc)
297 ; modl <- mkStringCLit (Module.moduleNameString
298 (Module.moduleName (cc_mod cc)))
299 -- All cost centres will be in the main package, since we
300 -- don't normally use -auto-all or add SCCs to other packages.
301 -- Hence don't emit the package name in the module here.
303 lits = [ zero, -- StgInt ccID,
304 label, -- char *label,
305 modl, -- char *module,
306 zero, -- StgWord time_ticks
307 zero64, -- StgWord64 mem_alloc
308 subsumed, -- StgInt is_caf
309 zero -- struct _CostCentre *link
311 ; emitDataLits (mkCCLabel cc) lits
314 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
315 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
318 emitCostCentreStackDecl
321 emitCostCentreStackDecl ccs
322 | Just cc <- maybeSingletonCCS ccs = do
324 -- Note: to avoid making any assumptions about how the
325 -- C compiler (that compiles the RTS, in particular) does
326 -- layouts of structs containing long-longs, simply
327 -- pad out the struct with zero words until we hit the
328 -- size of the overall struct (which we get via DerivedConstants.h)
330 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
331 ; emitDataLits (mkCCSLabel ccs) lits
333 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
336 zero64 = CmmInt 0 I64
338 sizeof_ccs_words :: Int
340 -- round up to the next word.
344 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
346 -- ---------------------------------------------------------------------------
347 -- Registering CCs and CCSs
349 -- (cc)->link = CC_LIST;
351 -- (cc)->ccID = CC_ID++;
353 emitRegisterCC :: CostCentre -> Code
354 emitRegisterCC cc = do
355 { tmp <- newNonPtrTemp cIntRep
357 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
358 (CmmLoad cC_LIST wordRep),
359 CmmStore cC_LIST cc_lit,
360 CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cIntRep),
361 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
362 CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
366 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
368 -- (ccs)->prevStack = CCS_LIST;
370 -- (ccs)->ccsID = CCS_ID++;
372 emitRegisterCCS :: CostCentreStack -> Code
373 emitRegisterCCS ccs = do
374 { tmp <- newNonPtrTemp cIntRep
376 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
377 (CmmLoad cCS_LIST wordRep),
378 CmmStore cCS_LIST ccs_lit,
379 CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cIntRep),
380 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
381 CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
385 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
388 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
389 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
391 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
392 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
394 -- ---------------------------------------------------------------------------
395 -- Set the current cost centre stack
397 emitSetCCC :: CostCentre -> Code
399 | not opt_SccProfilingOn = nopC
401 tmp <- newNonPtrTemp wordRep -- TODO FIXME NOW
402 ASSERT( sccAbleCostCentre cc )
403 pushCostCentre tmp curCCS cc
404 stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
405 when (isSccCountCostCentre cc) $
406 stmtC (bumpSccCount curCCS)
408 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
409 pushCostCentre result ccs cc
410 = emitRtsCallWithResult result PtrHint
411 SLIT("PushCostCentre") [(ccs,PtrHint),
412 (CmmLit (mkCCostCentre cc), PtrHint)]
415 bumpSccCount :: CmmExpr -> CmmStmt
417 = addToMem REP_CostCentreStack_scc_count
418 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
420 -----------------------------------------------------------------------------
422 -- Lag/drag/void stuff
424 -----------------------------------------------------------------------------
427 -- Initial value for the LDV field in a static closure
429 staticLdvInit :: CmmLit
430 staticLdvInit = zeroCLit
433 -- Initial value of the LDV field in a dynamic closure
435 dynLdvInit :: CmmExpr
436 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
437 CmmMachOp mo_wordOr [
438 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
439 CmmLit (mkWordCLit lDV_STATE_CREATE)
443 -- Initialise the LDV word of a new closure
445 ldvRecordCreate :: CmmExpr -> Code
446 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
449 -- Called when a closure is entered, marks the closure as having been "used".
450 -- The closure is not an 'inherently used' one.
451 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
454 ldvEnterClosure :: ClosureInfo -> Code
455 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
456 where tag = funTag closure_info
457 -- don't forget to substract node's tag
459 ldvEnter :: CmmExpr -> Code
460 -- Argument is a closure pointer
464 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
465 -- era | LDV_STATE_USE }
466 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
467 (stmtC (CmmStore ldv_wd new_ldv_wd))
469 -- don't forget to substract node's tag
470 ldv_wd = ldvWord cl_ptr
471 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
472 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
473 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
476 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
477 [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
479 ldvWord :: CmmExpr -> CmmExpr
480 -- Takes the address of a closure, and returns
481 -- the address of the LDV word in the closure
482 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
484 -- LDV constants, from ghc/includes/Constants.h
485 lDV_SHIFT = (LDV_SHIFT :: Int)
486 --lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
487 lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
488 --lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
489 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
490 lDV_STATE_USE = (LDV_STATE_USE :: StgWord)