1 -----------------------------------------------------------------------------
3 -- Code generation for profiling
5 -- (c) The University of Glasgow 2004
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, 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
35 import ClosureInfo ( ClosureInfo, closureSize,
36 closureName, isToplevClosure, closureReEntrant, )
39 import SMRep ( StgWord, profHdrSize )
43 import CmmUtils ( zeroCLit, mkIntCLit, mkLblExpr )
44 import CLabel ( mkCCLabel, mkCCSLabel, mkRtsDataLabel )
46 import Module ( moduleNameString )
47 import qualified Module ( moduleName ) -- clashes with CgMonad.moduleName
50 import StgSyn ( GenStgExpr(..), StgExpr )
51 import StaticFlags ( opt_SccProfilingOn )
52 import FastString ( FastString )
53 import Constants -- Lots of field offsets
60 -----------------------------------------------------------------------------
62 -- Cost-centre-stack Profiling
64 -----------------------------------------------------------------------------
66 -- Expression representing the current cost centre stack
68 curCCS = CmmLoad curCCSAddr wordRep
70 -- Address of current CCS variable, for storing into
72 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
74 mkCCostCentre :: CostCentre -> CmmLit
75 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
77 mkCCostCentreStack :: CostCentreStack -> CmmLit
78 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
80 costCentreFrom :: CmmExpr -- A closure pointer
81 -> CmmExpr -- The cost centre from that closure
82 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
84 staticProfHdr :: CostCentreStack -> [CmmLit]
85 -- The profiling header words in a static closure
86 -- Was SET_STATIC_PROF_HDR
87 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
90 dynProfHdr :: CmmExpr -> [CmmExpr]
91 -- Profiling header words in a dynamic closure
92 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
94 initUpdFrameProf :: CmmExpr -> Code
95 -- Initialise the profiling field of an update frame
96 initUpdFrameProf frame_amode
97 = ifProfiling $ -- frame->header.prof.ccs = CCCS
98 stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
99 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
100 -- is unnecessary because it is not used anyhow.
102 -- -----------------------------------------------------------------------------
103 -- Recording allocation in a cost centre
105 -- | Record the allocation of a closure. The CmmExpr is the cost
106 -- centre stack to which to attribute the allocation.
107 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
108 profDynAlloc cl_info ccs
110 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
112 -- | Record the allocation of a closure (size is given by a CmmExpr)
113 -- The size must be in words, because the allocation counter in a CCS counts
115 profAlloc :: CmmExpr -> CmmExpr -> Code
118 stmtC (addToMemE alloc_rep
119 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
120 (CmmMachOp (MO_U_Conv wordRep alloc_rep) $
121 [CmmMachOp mo_wordSub [words,
122 CmmLit (mkIntCLit profHdrSize)]]))
123 -- subtract the "profiling overhead", which is the
124 -- profiling header in a closure.
126 alloc_rep = REP_CostCentreStack_mem_alloc
128 -- ----------------------------------------------------------------------
129 -- Setting the cost centre in a new closure
131 chooseDynCostCentres :: CostCentreStack
134 -> FCode (CmmExpr, CmmExpr)
135 -- Called when alllcating a closure
136 -- Tells which cost centre to put in the object, and which
137 -- to blame the cost of allocation on
138 chooseDynCostCentres ccs args body = do
139 -- Cost-centre we record in the object
140 use_ccs <- emitCCS ccs
142 -- Cost-centre on whom we blame the allocation
144 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
145 | otherwise = use_ccs
147 return (use_ccs, blame_ccs)
150 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
151 -- These pushes must be performed before we can refer to the stack in
153 emitCCS :: CostCentreStack -> FCode CmmExpr
154 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
156 (cc's, ccs') = decomposeCCS ccs
158 push_em ccs [] = return ccs
159 push_em ccs (cc:rest) = do
160 tmp <- newTemp wordRep
161 pushCostCentre tmp ccs cc
162 push_em (CmmReg tmp) rest
164 ccsExpr :: CostCentreStack -> CmmExpr
166 | isCurrentCCS ccs = curCCS
167 | otherwise = CmmLit (mkCCostCentreStack ccs)
170 isBox :: StgExpr -> Bool
171 -- If it's an utterly trivial RHS, then it must be
172 -- one introduced by boxHigherOrderArgs for profiling,
173 -- so we charge it to "OVERHEAD".
174 -- This looks like a GROSS HACK to me --SDM
175 isBox (StgApp fun []) = True
179 -- -----------------------------------------------------------------------
180 -- Setting the current cost centre on entry to a closure
182 -- For lexically scoped profiling we have to load the cost centre from
183 -- the closure entered, if the costs are not supposed to be inherited.
184 -- This is done immediately on entering the fast entry point.
186 -- Load current cost centre from closure, if not inherited.
187 -- Node is guaranteed to point to it, if profiling and not inherited.
192 -> StgExpr -- The RHS of the closure
195 -- We used to have a special case for bindings of form
197 -- where g has arity 2. The RHS is a thunk, but we don't
198 -- need to update it; and we want to subsume costs.
199 -- We don't have these sort of PAPs any more, so the special
200 -- case has gone away.
202 enterCostCentre closure_info ccs body
204 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
205 enter_cost_centre closure_info ccs body
207 enter_cost_centre closure_info ccs body
209 = ASSERT(isToplevClosure closure_info)
213 | isDerivedFromCurrentCCS ccs
215 if re_entrant && not is_box
217 enter_ccs_fun node_ccs
219 stmtC (CmmStore curCCSAddr node_ccs)
221 -- don't forget to bump the scc count. This closure might have been
222 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
223 -- pass has turned into simply let x = e in ...x... and attached
224 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
225 -- we don't lose the scc counter, bump it in the entry code for x.
226 -- ToDo: for a multi-push we should really bump the counter for
227 -- each of the intervening CCSs, not just the top one.
228 ; when (not (isCurrentCCS ccs)) $
229 stmtC (bumpSccCount curCCS)
233 = ASSERT(isToplevClosure closure_info)
234 ASSERT(not re_entrant)
235 do { -- This is just a special case of the isDerivedFromCurrentCCS
236 -- case above. We could delete this, but it's a micro
237 -- optimisation and saves a bit of code.
238 stmtC (CmmStore curCCSAddr enc_ccs)
239 ; stmtC (bumpSccCount node_ccs)
243 = panic "enterCostCentre"
245 enc_ccs = CmmLit (mkCCostCentreStack ccs)
246 re_entrant = closureReEntrant closure_info
247 node_ccs = costCentreFrom (CmmReg nodeReg)
250 -- set the current CCS when entering a PAP
251 enterCostCentrePAP :: CmmExpr -> Code
252 enterCostCentrePAP closure =
254 enter_ccs_fun (costCentreFrom closure)
257 enterCostCentreThunk :: CmmExpr -> Code
258 enterCostCentreThunk closure =
260 stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
262 enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
265 enter_ccs_fsub = enteringPAP 0
267 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
268 -- code and the function entry code; we don't want the function's
269 -- entry code to also update CCCS in the event that it was called via
270 -- a PAP, so we set the flag entering_PAP to indicate that we are
271 -- entering via a PAP.
272 enteringPAP :: Integer -> Code
274 = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
275 (CmmLit (CmmInt n cIntRep)))
277 ifProfiling :: Code -> Code
279 | opt_SccProfilingOn = code
282 ifProfilingL :: [a] -> [a]
284 | opt_SccProfilingOn = xs
288 -- ---------------------------------------------------------------------------
289 -- Initialising Cost Centres & CCSs
294 emitCostCentreDecl cc = do
295 { label <- mkStringCLit (costCentreUserName cc)
296 ; modl <- mkStringCLit (moduleNameString (Module.moduleName (cc_mod cc)))
297 -- All cost centres will be in the main package, since we
298 -- don't normally use -auto-all or add SCCs to other packages.
299 -- Hence don't emit the package name in the module here.
301 lits = [ zero, -- StgInt ccID,
302 label, -- char *label,
303 modl, -- char *module,
304 zero, -- StgWord time_ticks
305 zero64, -- StgWord64 mem_alloc
306 subsumed, -- StgInt is_caf
307 zero -- struct _CostCentre *link
309 ; emitDataLits (mkCCLabel cc) lits
312 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
313 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
316 emitCostCentreStackDecl
319 emitCostCentreStackDecl ccs
320 | Just cc <- maybeSingletonCCS ccs = do
322 -- Note: to avoid making any assumptions about how the
323 -- C compiler (that compiles the RTS, in particular) does
324 -- layouts of structs containing long-longs, simply
325 -- pad out the struct with zero words until we hit the
326 -- size of the overall struct (which we get via DerivedConstants.h)
328 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
329 ; emitDataLits (mkCCSLabel ccs) lits
331 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
334 zero64 = CmmInt 0 I64
336 sizeof_ccs_words :: Int
338 -- round up to the next word.
342 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
344 -- ---------------------------------------------------------------------------
345 -- Registering CCs and CCSs
347 -- (cc)->link = CC_LIST;
349 -- (cc)->ccID = CC_ID++;
351 emitRegisterCC :: CostCentre -> Code
352 emitRegisterCC cc = do
353 { tmp <- newTemp cIntRep
355 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
356 (CmmLoad cC_LIST wordRep),
357 CmmStore cC_LIST cc_lit,
358 CmmAssign tmp (CmmLoad cC_ID cIntRep),
359 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
360 CmmStore cC_ID (cmmRegOffB tmp 1)
364 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
366 -- (ccs)->prevStack = CCS_LIST;
368 -- (ccs)->ccsID = CCS_ID++;
370 emitRegisterCCS :: CostCentreStack -> Code
371 emitRegisterCCS ccs = do
372 { tmp <- newTemp cIntRep
374 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
375 (CmmLoad cCS_LIST wordRep),
376 CmmStore cCS_LIST ccs_lit,
377 CmmAssign tmp (CmmLoad cCS_ID cIntRep),
378 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
379 CmmStore cCS_ID (cmmRegOffB tmp 1)
383 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
386 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
387 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
389 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
390 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
392 -- ---------------------------------------------------------------------------
393 -- Set the current cost centre stack
395 emitSetCCC :: CostCentre -> Code
397 | not opt_SccProfilingOn = nopC
399 tmp <- newTemp wordRep
400 ASSERT( sccAbleCostCentre cc )
401 pushCostCentre tmp curCCS cc
402 stmtC (CmmStore curCCSAddr (CmmReg tmp))
403 when (isSccCountCostCentre cc) $
404 stmtC (bumpSccCount curCCS)
406 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
407 pushCostCentre result ccs cc
408 = emitRtsCallWithResult result PtrHint
409 SLIT("PushCostCentre") [(ccs,PtrHint),
410 (CmmLit (mkCCostCentre cc), PtrHint)]
412 bumpSccCount :: CmmExpr -> CmmStmt
414 = addToMem REP_CostCentreStack_scc_count
415 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
417 -----------------------------------------------------------------------------
419 -- Lag/drag/void stuff
421 -----------------------------------------------------------------------------
424 -- Initial value for the LDV field in a static closure
426 staticLdvInit :: CmmLit
427 staticLdvInit = zeroCLit
430 -- Initial value of the LDV field in a dynamic closure
432 dynLdvInit :: CmmExpr
433 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
434 CmmMachOp mo_wordOr [
435 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
436 CmmLit (mkWordCLit lDV_STATE_CREATE)
440 -- Initialise the LDV word of a new closure
442 ldvRecordCreate :: CmmExpr -> Code
443 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
446 -- Called when a closure is entered, marks the closure as having been "used".
447 -- The closure is not an 'inherently used' one.
448 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
451 ldvEnter :: CmmExpr -> Code
452 -- Argument is a closure pointer
456 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
457 -- era | LDV_STATE_USE }
458 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
459 (stmtC (CmmStore ldv_wd new_ldv_wd))
461 ldv_wd = ldvWord cl_ptr
462 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
463 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
464 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
467 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
468 [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
470 ldvWord :: CmmExpr -> CmmExpr
471 -- Takes the address of a closure, and returns
472 -- the address of the LDV word in the closure
473 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
475 -- LDV constants, from ghc/includes/Constants.h
476 lDV_SHIFT = (LDV_SHIFT :: Int)
477 --lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
478 lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
479 --lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
480 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
481 lDV_STATE_USE = (LDV_STATE_USE :: StgWord)