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 ( moduleUserString )
49 import StgSyn ( GenStgExpr(..), StgExpr )
50 import StaticFlags ( opt_SccProfilingOn )
51 import FastString ( FastString, mkFastString, LitString )
52 import Constants -- Lots of field offsets
59 -----------------------------------------------------------------------------
61 -- Cost-centre-stack Profiling
63 -----------------------------------------------------------------------------
65 -- Expression representing the current cost centre stack
67 curCCS = CmmLoad curCCSAddr wordRep
69 -- Address of current CCS variable, for storing into
71 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCCS")))
73 mkCCostCentre :: CostCentre -> CmmLit
74 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
76 mkCCostCentreStack :: CostCentreStack -> CmmLit
77 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
79 costCentreFrom :: CmmExpr -- A closure pointer
80 -> CmmExpr -- The cost centre from that closure
81 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) wordRep
83 staticProfHdr :: CostCentreStack -> [CmmLit]
84 -- The profiling header words in a static closure
85 -- Was SET_STATIC_PROF_HDR
86 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
89 dynProfHdr :: CmmExpr -> [CmmExpr]
90 -- Profiling header words in a dynamic closure
91 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
93 initUpdFrameProf :: CmmExpr -> Code
94 -- Initialise the profiling field of an update frame
95 initUpdFrameProf frame_amode
96 = ifProfiling $ -- frame->header.prof.ccs = CCCS
97 stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
98 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
99 -- is unnecessary because it is not used anyhow.
101 -- -----------------------------------------------------------------------------
102 -- Recording allocation in a cost centre
104 -- | Record the allocation of a closure. The CmmExpr is the cost
105 -- centre stack to which to attribute the allocation.
106 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
107 profDynAlloc cl_info ccs
109 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
111 -- | Record the allocation of a closure (size is given by a CmmExpr)
112 -- The size must be in words, because the allocation counter in a CCS counts
114 profAlloc :: CmmExpr -> CmmExpr -> Code
117 stmtC (addToMemE alloc_rep
118 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
119 (CmmMachOp (MO_U_Conv wordRep alloc_rep) $
120 [CmmMachOp mo_wordSub [words,
121 CmmLit (mkIntCLit profHdrSize)]]))
122 -- subtract the "profiling overhead", which is the
123 -- profiling header in a closure.
125 alloc_rep = REP_CostCentreStack_mem_alloc
127 -- ----------------------------------------------------------------------
128 -- Setting the cost centre in a new closure
130 chooseDynCostCentres :: CostCentreStack
133 -> FCode (CmmExpr, CmmExpr)
134 -- Called when alllcating a closure
135 -- Tells which cost centre to put in the object, and which
136 -- to blame the cost of allocation on
137 chooseDynCostCentres ccs args body = do
138 -- Cost-centre we record in the object
139 use_ccs <- emitCCS ccs
141 -- Cost-centre on whom we blame the allocation
143 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
144 | otherwise = use_ccs
146 return (use_ccs, blame_ccs)
149 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
150 -- These pushes must be performed before we can refer to the stack in
152 emitCCS :: CostCentreStack -> FCode CmmExpr
153 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
155 (cc's, ccs') = decomposeCCS ccs
157 push_em ccs [] = return ccs
158 push_em ccs (cc:rest) = do
159 tmp <- newTemp wordRep
160 pushCostCentre tmp ccs cc
161 push_em (CmmReg tmp) rest
163 ccsExpr :: CostCentreStack -> CmmExpr
165 | isCurrentCCS ccs = curCCS
166 | otherwise = CmmLit (mkCCostCentreStack ccs)
169 isBox :: StgExpr -> Bool
170 -- If it's an utterly trivial RHS, then it must be
171 -- one introduced by boxHigherOrderArgs for profiling,
172 -- so we charge it to "OVERHEAD".
173 -- This looks like a GROSS HACK to me --SDM
174 isBox (StgApp fun []) = True
178 -- -----------------------------------------------------------------------
179 -- Setting the current cost centre on entry to a closure
181 -- For lexically scoped profiling we have to load the cost centre from
182 -- the closure entered, if the costs are not supposed to be inherited.
183 -- This is done immediately on entering the fast entry point.
185 -- Load current cost centre from closure, if not inherited.
186 -- Node is guaranteed to point to it, if profiling and not inherited.
191 -> StgExpr -- The RHS of the closure
194 -- We used to have a special case for bindings of form
196 -- where g has arity 2. The RHS is a thunk, but we don't
197 -- need to update it; and we want to subsume costs.
198 -- We don't have these sort of PAPs any more, so the special
199 -- case has gone away.
201 enterCostCentre closure_info ccs body
203 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
204 enter_cost_centre closure_info ccs body
206 enter_cost_centre closure_info ccs body
208 = ASSERT(isToplevClosure closure_info)
212 | isDerivedFromCurrentCCS ccs
214 if re_entrant && not is_box
216 enter_ccs_fun node_ccs
218 stmtC (CmmStore curCCSAddr node_ccs)
220 -- don't forget to bump the scc count. This closure might have been
221 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
222 -- pass has turned into simply let x = e in ...x... and attached
223 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
224 -- we don't lose the scc counter, bump it in the entry code for x.
225 -- ToDo: for a multi-push we should really bump the counter for
226 -- each of the intervening CCSs, not just the top one.
227 ; when (not (isCurrentCCS ccs)) $
228 stmtC (bumpSccCount curCCS)
232 = ASSERT(isToplevClosure closure_info)
233 ASSERT(not re_entrant)
234 do { -- This is just a special case of the isDerivedFromCurrentCCS
235 -- case above. We could delete this, but it's a micro
236 -- optimisation and saves a bit of code.
237 stmtC (CmmStore curCCSAddr enc_ccs)
238 ; stmtC (bumpSccCount node_ccs)
242 = panic "enterCostCentre"
244 enc_ccs = CmmLit (mkCCostCentreStack ccs)
245 re_entrant = closureReEntrant closure_info
246 node_ccs = costCentreFrom (CmmReg nodeReg)
249 -- set the current CCS when entering a PAP
250 enterCostCentrePAP :: CmmExpr -> Code
251 enterCostCentrePAP closure =
253 enter_ccs_fun (costCentreFrom closure)
256 enterCostCentreThunk :: CmmExpr -> Code
257 enterCostCentreThunk closure =
259 stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
261 enter_ccs_fun stack = emitRtsCall SLIT("EnterFunCCS") [(stack,PtrHint)]
264 enter_ccs_fsub = enteringPAP 0
266 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
267 -- code and the function entry code; we don't want the function's
268 -- entry code to also update CCCS in the event that it was called via
269 -- a PAP, so we set the flag entering_PAP to indicate that we are
270 -- entering via a PAP.
271 enteringPAP :: Integer -> Code
273 = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
274 (CmmLit (CmmInt n cIntRep)))
276 ifProfiling :: Code -> Code
278 | opt_SccProfilingOn = code
281 ifProfilingL :: [a] -> [a]
283 | opt_SccProfilingOn = xs
287 -- ---------------------------------------------------------------------------
288 -- Initialising Cost Centres & CCSs
293 emitCostCentreDecl cc = do
294 { label <- mkStringCLit (costCentreUserName cc)
295 ; modl <- mkStringCLit (moduleUserString (cc_mod cc))
297 lits = [ zero, -- StgInt ccID,
298 label, -- char *label,
299 modl, -- char *module,
300 zero, -- StgWord time_ticks
301 zero64, -- StgWord64 mem_alloc
302 subsumed, -- StgInt is_caf
303 zero -- struct _CostCentre *link
305 ; emitDataLits (mkCCLabel cc) lits
308 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
309 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
312 emitCostCentreStackDecl
315 emitCostCentreStackDecl ccs
316 | Just cc <- maybeSingletonCCS ccs = do
318 -- Note: to avoid making any assumptions about how the
319 -- C compiler (that compiles the RTS, in particular) does
320 -- layouts of structs containing long-longs, simply
321 -- pad out the struct with zero words until we hit the
322 -- size of the overall struct (which we get via DerivedConstants.h)
324 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
325 ; emitDataLits (mkCCSLabel ccs) lits
327 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
330 zero64 = CmmInt 0 I64
332 sizeof_ccs_words :: Int
334 -- round up to the next word.
338 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
340 -- ---------------------------------------------------------------------------
341 -- Registering CCs and CCSs
343 -- (cc)->link = CC_LIST;
345 -- (cc)->ccID = CC_ID++;
347 emitRegisterCC :: CostCentre -> Code
348 emitRegisterCC cc = do
349 { tmp <- newTemp cIntRep
351 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
352 (CmmLoad cC_LIST wordRep),
353 CmmStore cC_LIST cc_lit,
354 CmmAssign tmp (CmmLoad cC_ID cIntRep),
355 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
356 CmmStore cC_ID (cmmRegOffB tmp 1)
360 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
362 -- (ccs)->prevStack = CCS_LIST;
364 -- (ccs)->ccsID = CCS_ID++;
366 emitRegisterCCS :: CostCentreStack -> Code
367 emitRegisterCCS ccs = do
368 { tmp <- newTemp cIntRep
370 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
371 (CmmLoad cCS_LIST wordRep),
372 CmmStore cCS_LIST ccs_lit,
373 CmmAssign tmp (CmmLoad cCS_ID cIntRep),
374 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
375 CmmStore cCS_ID (cmmRegOffB tmp 1)
379 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
382 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
383 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
385 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
386 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
388 -- ---------------------------------------------------------------------------
389 -- Set the current cost centre stack
391 emitSetCCC :: CostCentre -> Code
393 | not opt_SccProfilingOn = nopC
395 tmp <- newTemp wordRep
396 ASSERT( sccAbleCostCentre cc )
397 pushCostCentre tmp curCCS cc
398 stmtC (CmmStore curCCSAddr (CmmReg tmp))
399 when (isSccCountCostCentre cc) $
400 stmtC (bumpSccCount curCCS)
402 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
403 pushCostCentre result ccs cc
404 = emitRtsCallWithResult result PtrHint
405 SLIT("PushCostCentre") [(ccs,PtrHint),
406 (CmmLit (mkCCostCentre cc), PtrHint)]
408 bumpSccCount :: CmmExpr -> CmmStmt
410 = addToMem REP_CostCentreStack_scc_count
411 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
413 -----------------------------------------------------------------------------
415 -- Lag/drag/void stuff
417 -----------------------------------------------------------------------------
420 -- Initial value for the LDV field in a static closure
422 staticLdvInit :: CmmLit
423 staticLdvInit = zeroCLit
426 -- Initial value of the LDV field in a dynamic closure
428 dynLdvInit :: CmmExpr
429 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
430 CmmMachOp mo_wordOr [
431 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
432 CmmLit (mkWordCLit lDV_STATE_CREATE)
436 -- Initialise the LDV word of a new closure
438 ldvRecordCreate :: CmmExpr -> Code
439 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
442 -- Called when a closure is entered, marks the closure as having been "used".
443 -- The closure is not an 'inherently used' one.
444 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
447 ldvEnter :: CmmExpr -> Code
448 -- Argument is a closure pointer
452 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
453 -- era | LDV_STATE_USE }
454 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
455 (stmtC (CmmStore ldv_wd new_ldv_wd))
457 ldv_wd = ldvWord cl_ptr
458 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
459 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
460 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
463 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
464 [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
466 ldvWord :: CmmExpr -> CmmExpr
467 -- Takes the address of a closure, and returns
468 -- the address of the LDV word in the closure
469 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
471 -- LDV constants, from ghc/includes/Constants.h
472 lDV_SHIFT = (LDV_SHIFT :: Int)
473 --lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
474 lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
475 --lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
476 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
477 lDV_STATE_USE = (LDV_STATE_USE :: StgWord)