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"
27 #include "../includes/ghcconfig.h"
28 -- Needed by Constants.h
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 ( moduleNameUserString )
49 import StgSyn ( GenStgExpr(..), StgExpr )
50 import CmdLineOpts ( 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)]
263 enter_ccs_fsub = enteringPAP 0
265 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
266 -- code and the function entry code; we don't want the function's
267 -- entry code to also update CCCS in the event that it was called via
268 -- a PAP, so we set the flag entering_PAP to indicate that we are
269 -- entering via a PAP.
270 enteringPAP :: Integer -> Code
272 = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel SLIT("entering_PAP"))))
273 (CmmLit (CmmInt n cIntRep)))
275 ifProfiling :: Code -> Code
277 | opt_SccProfilingOn = code
280 ifProfilingL :: [a] -> [a]
282 | opt_SccProfilingOn = xs
286 -- ---------------------------------------------------------------------------
287 -- Initialising Cost Centres & CCSs
292 emitCostCentreDecl cc = do
293 { label <- mkStringCLit (costCentreUserName cc)
294 ; modl <- mkStringCLit (moduleNameUserString (cc_mod cc))
296 lits = [ zero, -- StgInt ccID,
297 label, -- char *label,
298 modl, -- char *module,
299 zero, -- StgWord time_ticks
300 zero64, -- StgWord64 mem_alloc
301 subsumed, -- StgInt is_caf
302 zero -- struct _CostCentre *link
304 ; emitDataLits (mkCCLabel cc) lits
307 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
308 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
311 emitCostCentreStackDecl
314 emitCostCentreStackDecl ccs
315 | Just cc <- maybeSingletonCCS ccs = do
319 zero, -- struct _CostCentreStack *prevStack;
320 zero, -- struct _IndexTable *indexTable;
321 zero, -- StgWord selected;
322 zero64, -- StgWord64 scc_count;
323 zero, -- StgWord time_ticks;
324 zero64, -- StgWord64 mem_alloc;
325 zero, -- StgWord inherited_ticks;
326 zero64, -- StgWord64 inherited_alloc;
327 zero -- CostCentre *root;
329 ; emitDataLits (mkCCSLabel ccs) lits
331 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
334 zero64 = CmmInt 0 I64
337 -- ---------------------------------------------------------------------------
338 -- Registering CCs and CCSs
340 -- (cc)->link = CC_LIST;
342 -- (cc)->ccID = CC_ID++;
344 emitRegisterCC :: CostCentre -> Code
345 emitRegisterCC cc = do
346 { tmp <- newTemp cIntRep
348 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
349 (CmmLoad cC_LIST wordRep),
350 CmmStore cC_LIST cc_lit,
351 CmmAssign tmp (CmmLoad cC_ID cIntRep),
352 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg tmp),
353 CmmStore cC_ID (cmmRegOffB tmp 1)
357 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
359 -- (ccs)->prevStack = CCS_LIST;
361 -- (ccs)->ccsID = CCS_ID++;
363 emitRegisterCCS :: CostCentreStack -> Code
364 emitRegisterCCS ccs = do
365 { tmp <- newTemp cIntRep
367 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
368 (CmmLoad cCS_LIST wordRep),
369 CmmStore cCS_LIST ccs_lit,
370 CmmAssign tmp (CmmLoad cCS_ID cIntRep),
371 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg tmp),
372 CmmStore cCS_ID (cmmRegOffB tmp 1)
376 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
379 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_LIST")))
380 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CC_ID")))
382 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_LIST")))
383 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel SLIT("CCS_ID")))
385 -- ---------------------------------------------------------------------------
386 -- Set the current cost centre stack
388 emitSetCCC :: CostCentre -> Code
390 | not opt_SccProfilingOn = nopC
392 tmp <- newTemp wordRep
393 ASSERT( sccAbleCostCentre cc )
394 pushCostCentre tmp curCCS cc
395 stmtC (CmmStore curCCSAddr (CmmReg tmp))
396 when (isSccCountCostCentre cc) $
397 stmtC (bumpSccCount curCCS)
399 pushCostCentre :: CmmReg -> CmmExpr -> CostCentre -> Code
400 pushCostCentre result ccs cc
401 = emitRtsCallWithResult result PtrHint
402 SLIT("PushCostCentre") [(ccs,PtrHint),
403 (CmmLit (mkCCostCentre cc), PtrHint)]
405 bumpSccCount :: CmmExpr -> CmmStmt
407 = addToMem REP_CostCentreStack_scc_count
408 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
410 -----------------------------------------------------------------------------
412 -- Lag/drag/void stuff
414 -----------------------------------------------------------------------------
417 -- Initial value for the LDV field in a static closure
419 staticLdvInit :: CmmLit
420 staticLdvInit = zeroCLit
423 -- Initial value of the LDV field in a dynamic closure
425 dynLdvInit :: CmmExpr
426 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
427 CmmMachOp mo_wordOr [
428 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
429 CmmLit (mkWordCLit lDV_STATE_CREATE)
433 -- Initialise the LDV word of a new closure
435 ldvRecordCreate :: CmmExpr -> Code
436 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
439 -- Called when a closure is entered, marks the closure as having been "used".
440 -- The closure is not an 'inherently used' one.
441 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
444 ldvEnter :: CmmExpr -> Code
445 -- Argument is a closure pointer
449 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
450 -- era | LDV_STATE_USE }
451 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
452 (stmtC (CmmStore ldv_wd new_ldv_wd))
454 ldv_wd = ldvWord cl_ptr
455 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd wordRep)
456 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
457 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
460 loadEra = CmmMachOp (MO_U_Conv cIntRep wordRep)
461 [CmmLoad (mkLblExpr (mkRtsDataLabel SLIT("era"))) cIntRep]
463 ldvWord :: CmmExpr -> CmmExpr
464 -- Takes the address of a closure, and returns
465 -- the address of the LDV word in the closure
466 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
468 -- LDV constants, from ghc/includes/Constants.h
469 lDV_SHIFT = (LDV_SHIFT :: Int)
470 --lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
471 lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
472 --lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
473 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
474 lDV_STATE_USE = (LDV_STATE_USE :: StgWord)