2 -- The above warning supression flag is a temporary kludge.
3 -- While working on this module you are encouraged to remove it and fix
4 -- any warnings in the module. See
5 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
8 -----------------------------------------------------------------------------
10 -- Code generation for profiling
12 -- (c) The University of Glasgow 2004-2006
14 -----------------------------------------------------------------------------
17 mkCCostCentre, mkCCostCentreStack,
19 -- Cost-centre Profiling
20 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
21 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
25 emitCostCentreDecl, emitCostCentreStackDecl,
26 emitRegisterCC, emitRegisterCCS,
29 -- Lag/drag/void stuff
30 ldvEnter, ldvEnterClosure, ldvRecordCreate
33 #include "HsVersions.h"
35 -- For WORD_SIZE_IN_BITS only.
36 #include "../includes/Constants.h"
37 -- For LDV_CREATE_MASK, LDV_STATE_USE
39 #include "../includes/DerivedConstants.h"
40 -- For REP_xxx constants, which are MachReps
52 import qualified Module
57 import Constants -- Lots of field offsets
64 -----------------------------------------------------------------------------
66 -- Cost-centre-stack Profiling
68 -----------------------------------------------------------------------------
70 -- Expression representing the current cost centre stack
72 curCCS = CmmLoad curCCSAddr bWord
74 -- Address of current CCS variable, for storing into
76 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))
78 mkCCostCentre :: CostCentre -> CmmLit
79 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
81 mkCCostCentreStack :: CostCentreStack -> CmmLit
82 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
84 costCentreFrom :: CmmExpr -- A closure pointer
85 -> CmmExpr -- The cost centre from that closure
86 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
88 staticProfHdr :: CostCentreStack -> [CmmLit]
89 -- The profiling header words in a static closure
90 -- Was SET_STATIC_PROF_HDR
91 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
94 dynProfHdr :: CmmExpr -> [CmmExpr]
95 -- Profiling header words in a dynamic closure
96 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
98 initUpdFrameProf :: CmmExpr -> Code
99 -- Initialise the profiling field of an update frame
100 initUpdFrameProf frame_amode
101 = ifProfiling $ -- frame->header.prof.ccs = CCCS
102 stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
103 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
104 -- is unnecessary because it is not used anyhow.
106 -- -----------------------------------------------------------------------------
107 -- Recording allocation in a cost centre
109 -- | Record the allocation of a closure. The CmmExpr is the cost
110 -- centre stack to which to attribute the allocation.
111 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
112 profDynAlloc cl_info ccs
114 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
116 -- | Record the allocation of a closure (size is given by a CmmExpr)
117 -- The size must be in words, because the allocation counter in a CCS counts
119 profAlloc :: CmmExpr -> CmmExpr -> Code
122 stmtC (addToMemE alloc_rep
123 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
124 (CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
125 [CmmMachOp mo_wordSub [words,
126 CmmLit (mkIntCLit profHdrSize)]]))
127 -- subtract the "profiling overhead", which is the
128 -- profiling header in a closure.
130 alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
132 -- ----------------------------------------------------------------------
133 -- Setting the cost centre in a new closure
135 chooseDynCostCentres :: CostCentreStack
138 -> FCode (CmmExpr, CmmExpr)
139 -- Called when alllcating a closure
140 -- Tells which cost centre to put in the object, and which
141 -- to blame the cost of allocation on
142 chooseDynCostCentres ccs args body = do
143 -- Cost-centre we record in the object
144 use_ccs <- emitCCS ccs
146 -- Cost-centre on whom we blame the allocation
148 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
149 | otherwise = use_ccs
151 return (use_ccs, blame_ccs)
154 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
155 -- These pushes must be performed before we can refer to the stack in
157 emitCCS :: CostCentreStack -> FCode CmmExpr
158 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
160 (cc's, ccs') = decomposeCCS ccs
162 push_em ccs [] = return ccs
163 push_em ccs (cc:rest) = do
164 tmp <- newTemp bWord -- TODO FIXME NOW
165 pushCostCentre tmp ccs cc
166 push_em (CmmReg (CmmLocal tmp)) rest
168 ccsExpr :: CostCentreStack -> CmmExpr
170 | isCurrentCCS ccs = curCCS
171 | otherwise = CmmLit (mkCCostCentreStack ccs)
174 isBox :: StgExpr -> Bool
175 -- If it's an utterly trivial RHS, then it must be
176 -- one introduced by boxHigherOrderArgs for profiling,
177 -- so we charge it to "OVERHEAD".
178 -- This looks like a GROSS HACK to me --SDM
179 isBox (StgApp fun []) = True
183 -- -----------------------------------------------------------------------
184 -- Setting the current cost centre on entry to a closure
186 -- For lexically scoped profiling we have to load the cost centre from
187 -- the closure entered, if the costs are not supposed to be inherited.
188 -- This is done immediately on entering the fast entry point.
190 -- Load current cost centre from closure, if not inherited.
191 -- Node is guaranteed to point to it, if profiling and not inherited.
196 -> StgExpr -- The RHS of the closure
199 -- We used to have a special case for bindings of form
201 -- where g has arity 2. The RHS is a thunk, but we don't
202 -- need to update it; and we want to subsume costs.
203 -- We don't have these sort of PAPs any more, so the special
204 -- case has gone away.
206 enterCostCentre closure_info ccs body
208 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
209 enter_cost_centre closure_info ccs body
211 enter_cost_centre closure_info ccs body
213 = ASSERT(isToplevClosure closure_info)
217 | isDerivedFromCurrentCCS ccs
219 if re_entrant && not is_box
221 enter_ccs_fun node_ccs
223 stmtC (CmmStore curCCSAddr node_ccs)
225 -- don't forget to bump the scc count. This closure might have been
226 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
227 -- pass has turned into simply let x = e in ...x... and attached
228 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
229 -- we don't lose the scc counter, bump it in the entry code for x.
230 -- ToDo: for a multi-push we should really bump the counter for
231 -- each of the intervening CCSs, not just the top one.
232 ; when (not (isCurrentCCS ccs)) $
233 stmtC (bumpSccCount curCCS)
237 = ASSERT(isToplevClosure closure_info)
238 ASSERT(not re_entrant)
239 do { -- This is just a special case of the isDerivedFromCurrentCCS
240 -- case above. We could delete this, but it's a micro
241 -- optimisation and saves a bit of code.
242 stmtC (CmmStore curCCSAddr enc_ccs)
243 ; stmtC (bumpSccCount node_ccs)
247 = panic "enterCostCentre"
249 enc_ccs = CmmLit (mkCCostCentreStack ccs)
250 re_entrant = closureReEntrant closure_info
251 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
254 -- if this is a function, then node will be tagged; we must subract the tag
255 node_tag = funTag closure_info
257 -- set the current CCS when entering a PAP
258 enterCostCentrePAP :: CmmExpr -> Code
259 enterCostCentrePAP closure =
261 enter_ccs_fun (costCentreFrom closure)
264 enterCostCentreThunk :: CmmExpr -> Code
265 enterCostCentreThunk closure =
267 stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
269 enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [CmmHinted stack AddrHint] False
272 enter_ccs_fsub = enteringPAP 0
274 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
275 -- code and the function entry code; we don't want the function's
276 -- entry code to also update CCCS in the event that it was called via
277 -- a PAP, so we set the flag entering_PAP to indicate that we are
278 -- entering via a PAP.
279 enteringPAP :: Integer -> Code
281 = stmtC (CmmStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
282 (CmmLit (CmmInt n cIntWidth)))
284 ifProfiling :: Code -> Code
286 | opt_SccProfilingOn = code
289 ifProfilingL :: [a] -> [a]
291 | opt_SccProfilingOn = xs
295 -- ---------------------------------------------------------------------------
296 -- Initialising Cost Centres & CCSs
301 emitCostCentreDecl cc = do
302 { label <- mkStringCLit (costCentreUserName cc)
303 ; modl <- mkStringCLit (Module.moduleNameString
304 (Module.moduleName (cc_mod cc)))
305 -- All cost centres will be in the main package, since we
306 -- don't normally use -auto-all or add SCCs to other packages.
307 -- Hence don't emit the package name in the module here.
309 lits = [ zero, -- StgInt ccID,
310 label, -- char *label,
311 modl, -- char *module,
312 zero, -- StgWord time_ticks
313 zero64, -- StgWord64 mem_alloc
314 subsumed, -- StgInt is_caf
315 zero -- struct _CostCentre *link
317 ; emitDataLits (mkCCLabel cc) lits
320 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
321 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
324 emitCostCentreStackDecl
327 emitCostCentreStackDecl ccs
328 | Just cc <- maybeSingletonCCS ccs = do
330 -- Note: to avoid making any assumptions about how the
331 -- C compiler (that compiles the RTS, in particular) does
332 -- layouts of structs containing long-longs, simply
333 -- pad out the struct with zero words until we hit the
334 -- size of the overall struct (which we get via DerivedConstants.h)
336 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
337 ; emitDataLits (mkCCSLabel ccs) lits
339 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
342 zero64 = CmmInt 0 W64
344 sizeof_ccs_words :: Int
346 -- round up to the next word.
350 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
352 -- ---------------------------------------------------------------------------
353 -- Registering CCs and CCSs
355 -- (cc)->link = CC_LIST;
357 -- (cc)->ccID = CC_ID++;
359 emitRegisterCC :: CostCentre -> Code
360 emitRegisterCC cc = do
361 { tmp <- newTemp cInt
363 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
364 (CmmLoad cC_LIST bWord),
365 CmmStore cC_LIST cc_lit,
366 CmmAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
367 CmmStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
368 CmmStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
372 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
374 -- (ccs)->prevStack = CCS_LIST;
376 -- (ccs)->ccsID = CCS_ID++;
378 emitRegisterCCS :: CostCentreStack -> Code
379 emitRegisterCCS ccs = do
380 { tmp <- newTemp cInt
382 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
383 (CmmLoad cCS_LIST bWord),
384 CmmStore cCS_LIST ccs_lit,
385 CmmAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
386 CmmStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
387 CmmStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
391 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
394 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
395 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))
397 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
398 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
400 -- ---------------------------------------------------------------------------
401 -- Set the current cost centre stack
403 emitSetCCC :: CostCentre -> Code
405 | not opt_SccProfilingOn = nopC
407 tmp <- newTemp bWord -- TODO FIXME NOW
408 ASSERT( sccAbleCostCentre cc )
409 pushCostCentre tmp curCCS cc
410 stmtC (CmmStore curCCSAddr (CmmReg (CmmLocal tmp)))
411 when (isSccCountCostCentre cc) $
412 stmtC (bumpSccCount curCCS)
414 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
415 pushCostCentre result ccs cc
416 = emitRtsCallWithResult result AddrHint
417 (sLit "PushCostCentre") [CmmHinted ccs AddrHint,
418 CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
421 bumpSccCount :: CmmExpr -> CmmStmt
423 = addToMem (typeWidth REP_CostCentreStack_scc_count)
424 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
426 -----------------------------------------------------------------------------
428 -- Lag/drag/void stuff
430 -----------------------------------------------------------------------------
433 -- Initial value for the LDV field in a static closure
435 staticLdvInit :: CmmLit
436 staticLdvInit = zeroCLit
439 -- Initial value of the LDV field in a dynamic closure
441 dynLdvInit :: CmmExpr
442 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
443 CmmMachOp mo_wordOr [
444 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
445 CmmLit (mkWordCLit lDV_STATE_CREATE)
449 -- Initialise the LDV word of a new closure
451 ldvRecordCreate :: CmmExpr -> Code
452 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
455 -- Called when a closure is entered, marks the closure as having been "used".
456 -- The closure is not an 'inherently used' one.
457 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
460 ldvEnterClosure :: ClosureInfo -> Code
461 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
462 where tag = funTag closure_info
463 -- don't forget to substract node's tag
465 ldvEnter :: CmmExpr -> Code
466 -- Argument is a closure pointer
470 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
471 -- era | LDV_STATE_USE }
472 emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
473 (stmtC (CmmStore ldv_wd new_ldv_wd))
475 -- don't forget to substract node's tag
476 ldv_wd = ldvWord cl_ptr
477 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
478 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
479 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
482 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
483 [CmmLoad (mkLblExpr (mkRtsDataLabel $ sLit("era"))) cInt]
485 ldvWord :: CmmExpr -> CmmExpr
486 -- Takes the address of a closure, and returns
487 -- the address of the LDV word in the closure
488 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
490 -- LDV constants, from ghc/includes/Constants.h
491 lDV_SHIFT = (LDV_SHIFT :: Int)
492 --lDV_STATE_MASK = (LDV_STATE_MASK :: StgWord)
493 lDV_CREATE_MASK = (LDV_CREATE_MASK :: StgWord)
494 --lDV_LAST_MASK = (LDV_LAST_MASK :: StgWord)
495 lDV_STATE_CREATE = (LDV_STATE_CREATE :: StgWord)
496 lDV_STATE_USE = (LDV_STATE_USE :: StgWord)