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,
21 -- Lag/drag/void stuff
22 ldvEnter, ldvEnterClosure, ldvRecordCreate
25 #include "HsVersions.h"
26 #include "../includes/MachDeps.h"
27 -- For WORD_SIZE_IN_BITS only.
28 #include "../includes/rts/Constants.h"
29 -- For LDV_CREATE_MASK, LDV_STATE_USE
31 #include "../includes/DerivedConstants.h"
32 -- For REP_xxx constants, which are MachReps
44 import qualified Module
50 import Constants -- Lots of field offsets
56 -----------------------------------------------------------------------------
58 -- Cost-centre-stack Profiling
60 -----------------------------------------------------------------------------
62 -- Expression representing the current cost centre stack
64 curCCS = CmmLoad curCCSAddr bWord
66 -- Address of current CCS variable, for storing into
68 curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
70 mkCCostCentre :: CostCentre -> CmmLit
71 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
73 mkCCostCentreStack :: CostCentreStack -> CmmLit
74 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
76 costCentreFrom :: CmmExpr -- A closure pointer
77 -> CmmExpr -- The cost centre from that closure
78 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
80 staticProfHdr :: CostCentreStack -> [CmmLit]
81 -- The profiling header words in a static closure
82 -- Was SET_STATIC_PROF_HDR
83 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
86 dynProfHdr :: CmmExpr -> [CmmExpr]
87 -- Profiling header words in a dynamic closure
88 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
90 initUpdFrameProf :: CmmExpr -> Code
91 -- Initialise the profiling field of an update frame
92 initUpdFrameProf frame_amode
93 = ifProfiling $ -- frame->header.prof.ccs = CCCS
94 stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
95 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
96 -- is unnecessary because it is not used anyhow.
98 -- -----------------------------------------------------------------------------
99 -- Recording allocation in a cost centre
101 -- | Record the allocation of a closure. The CmmExpr is the cost
102 -- centre stack to which to attribute the allocation.
103 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
104 profDynAlloc cl_info ccs
106 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
108 -- | Record the allocation of a closure (size is given by a CmmExpr)
109 -- The size must be in words, because the allocation counter in a CCS counts
111 profAlloc :: CmmExpr -> CmmExpr -> Code
114 stmtC (addToMemE alloc_rep
115 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
116 (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
117 [CmmMachOp mo_wordSub [words,
118 CmmLit (mkIntCLit profHdrSize)]]))
119 -- subtract the "profiling overhead", which is the
120 -- profiling header in a closure.
122 alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
124 -- ----------------------------------------------------------------------
125 -- Setting the cost centre in a new closure
127 chooseDynCostCentres :: CostCentreStack
130 -> FCode (CmmExpr, CmmExpr)
131 -- Called when alllcating a closure
132 -- Tells which cost centre to put in the object, and which
133 -- to blame the cost of allocation on
134 chooseDynCostCentres ccs args body = do
135 -- Cost-centre we record in the object
136 use_ccs <- emitCCS ccs
138 -- Cost-centre on whom we blame the allocation
140 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
141 | otherwise = use_ccs
143 return (use_ccs, blame_ccs)
146 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
147 -- These pushes must be performed before we can refer to the stack in
149 emitCCS :: CostCentreStack -> FCode CmmExpr
150 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
152 (cc's, ccs') = decomposeCCS ccs
154 push_em ccs [] = return ccs
155 push_em ccs (cc:rest) = do
156 tmp <- newTemp bWord -- TODO FIXME NOW
157 pushCostCentre tmp ccs cc
158 push_em (CmmReg (CmmLocal tmp)) rest
160 ccsExpr :: CostCentreStack -> CmmExpr
162 | isCurrentCCS ccs = curCCS
163 | otherwise = CmmLit (mkCCostCentreStack ccs)
166 isBox :: StgExpr -> Bool
167 -- If it's an utterly trivial RHS, then it must be
168 -- one introduced by boxHigherOrderArgs for profiling,
169 -- so we charge it to "OVERHEAD".
170 -- This looks like a GROSS HACK to me --SDM
171 isBox (StgApp _ []) = True
175 -- -----------------------------------------------------------------------
176 -- Setting the current cost centre on entry to a closure
178 -- For lexically scoped profiling we have to load the cost centre from
179 -- the closure entered, if the costs are not supposed to be inherited.
180 -- This is done immediately on entering the fast entry point.
182 -- Load current cost centre from closure, if not inherited.
183 -- Node is guaranteed to point to it, if profiling and not inherited.
188 -> StgExpr -- The RHS of the closure
191 -- We used to have a special case for bindings of form
193 -- where g has arity 2. The RHS is a thunk, but we don't
194 -- need to update it; and we want to subsume costs.
195 -- We don't have these sort of PAPs any more, so the special
196 -- case has gone away.
198 enterCostCentre closure_info ccs body
200 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
201 enter_cost_centre closure_info ccs body
203 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> Code
204 enter_cost_centre closure_info ccs body
206 = ASSERT(isToplevClosure closure_info)
210 | isDerivedFromCurrentCCS ccs
212 if re_entrant && not is_box
214 enter_ccs_fun node_ccs
216 stmtC (CmmStore curCCSAddr node_ccs)
218 -- don't forget to bump the scc count. This closure might have been
219 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
220 -- pass has turned into simply let x = e in ...x... and attached
221 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
222 -- we don't lose the scc counter, bump it in the entry code for x.
223 -- ToDo: for a multi-push we should really bump the counter for
224 -- each of the intervening CCSs, not just the top one.
225 ; when (not (isCurrentCCS ccs)) $
226 stmtC (bumpSccCount curCCS)
230 = ASSERT(isToplevClosure closure_info)
231 ASSERT(not re_entrant)
232 do { -- This is just a special case of the isDerivedFromCurrentCCS
233 -- case above. We could delete this, but it's a micro
234 -- optimisation and saves a bit of code.
235 stmtC (CmmStore curCCSAddr enc_ccs)
236 ; stmtC (bumpSccCount node_ccs)
240 = panic "enterCostCentre"
242 enc_ccs = CmmLit (mkCCostCentreStack ccs)
243 re_entrant = closureReEntrant closure_info
244 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
247 -- if this is a function, then node will be tagged; we must subract the tag
248 node_tag = funTag closure_info
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 :: CmmExpr -> Code
263 enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
266 enter_ccs_fsub :: Code
267 enter_ccs_fsub = enteringPAP 0
269 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
270 -- code and the function entry code; we don't want the function's
271 -- entry code to also update CCCS in the event that it was called via
272 -- a PAP, so we set the flag entering_PAP to indicate that we are
273 -- entering via a PAP.
274 enteringPAP :: Integer -> Code
276 = stmtC (CmmStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
277 (CmmLit (CmmInt n cIntWidth)))
279 ifProfiling :: Code -> Code
281 | opt_SccProfilingOn = code
284 ifProfilingL :: [a] -> [a]
286 | opt_SccProfilingOn = xs
290 -- ---------------------------------------------------------------------------
291 -- Initialising Cost Centres & CCSs
296 emitCostCentreDecl cc = do
297 { label <- mkStringCLit (costCentreUserName cc)
298 ; modl <- mkStringCLit (Module.moduleNameString
299 (Module.moduleName (cc_mod cc)))
300 -- All cost centres will be in the main package, since we
301 -- don't normally use -auto-all or add SCCs to other packages.
302 -- Hence don't emit the package name in the module here.
304 lits = [ zero, -- StgInt ccID,
305 label, -- char *label,
306 modl, -- char *module,
307 zero, -- StgWord time_ticks
308 zero64, -- StgWord64 mem_alloc
309 subsumed, -- StgInt is_caf
310 zero -- struct _CostCentre *link
312 ; emitDataLits (mkCCLabel cc) lits
315 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
316 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
319 emitCostCentreStackDecl
322 emitCostCentreStackDecl ccs
323 | Just cc <- maybeSingletonCCS ccs = do
325 -- Note: to avoid making any assumptions about how the
326 -- C compiler (that compiles the RTS, in particular) does
327 -- layouts of structs containing long-longs, simply
328 -- pad out the struct with zero words until we hit the
329 -- size of the overall struct (which we get via DerivedConstants.h)
331 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
332 ; emitDataLits (mkCCSLabel ccs) lits
334 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
339 zero64 = CmmInt 0 W64
341 sizeof_ccs_words :: Int
343 -- round up to the next word.
347 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
349 -- ---------------------------------------------------------------------------
350 -- Set the current cost centre stack
352 emitSetCCC :: CostCentre -> Code
354 | not opt_SccProfilingOn = nopC
356 tmp <- newTemp bWord -- TODO FIXME NOW
357 ASSERT( sccAbleCostCentre cc )
358 pushCostCentre tmp curCCS cc
359 stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
360 when (isSccCountCostCentre cc) $
361 stmtC (bumpSccCount curCCS)
363 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
364 pushCostCentre result ccs cc
365 = emitRtsCallWithResult result AddrHint
367 (fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
368 CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
371 bumpSccCount :: CmmExpr -> CmmStmt
373 = addToMem (typeWidth REP_CostCentreStack_scc_count)
374 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
376 -----------------------------------------------------------------------------
378 -- Lag/drag/void stuff
380 -----------------------------------------------------------------------------
383 -- Initial value for the LDV field in a static closure
385 staticLdvInit :: CmmLit
386 staticLdvInit = zeroCLit
389 -- Initial value of the LDV field in a dynamic closure
391 dynLdvInit :: CmmExpr
392 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
393 CmmMachOp mo_wordOr [
394 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
395 CmmLit (mkWordCLit lDV_STATE_CREATE)
399 -- Initialise the LDV word of a new closure
401 ldvRecordCreate :: CmmExpr -> Code
402 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
405 -- Called when a closure is entered, marks the closure as having been "used".
406 -- The closure is not an 'inherently used' one.
407 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
410 ldvEnterClosure :: ClosureInfo -> Code
411 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
412 where tag = funTag closure_info
413 -- don't forget to substract node's tag
415 ldvEnter :: CmmExpr -> Code
416 -- Argument is a closure pointer
420 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
421 -- era | LDV_STATE_USE }
422 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
423 (stmtC (CmmStore ldv_wd new_ldv_wd))
425 -- don't forget to substract node's tag
426 ldv_wd = ldvWord cl_ptr
427 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
428 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
429 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
432 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
433 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
435 ldvWord :: CmmExpr -> CmmExpr
436 -- Takes the address of a closure, and returns
437 -- the address of the LDV word in the closure
438 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
440 -- LDV constants, from ghc/includes/Constants.h
442 lDV_SHIFT = LDV_SHIFT
443 --lDV_STATE_MASK :: StgWord
444 --lDV_STATE_MASK = LDV_STATE_MASK
445 lDV_CREATE_MASK :: StgWord
446 lDV_CREATE_MASK = LDV_CREATE_MASK
447 --lDV_LAST_MASK :: StgWord
448 --lDV_LAST_MASK = LDV_LAST_MASK
449 lDV_STATE_CREATE :: StgWord
450 lDV_STATE_CREATE = LDV_STATE_CREATE
451 lDV_STATE_USE :: StgWord
452 lDV_STATE_USE = LDV_STATE_USE