Fix warnings in StgCmmProf
[ghc.git] / compiler / codeGen / StgCmmProf.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module StgCmmProf (
10 initCostCentres, ccType, ccsType,
11 mkCCostCentre, mkCCostCentreStack,
12
13 -- Cost-centre Profiling
14 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
15 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
16 chooseDynCostCentres,
17 costCentreFrom,
18 curCCS, curCCSAddr,
19 emitSetCCC, emitCCS,
20
21 saveCurrentCostCentre, restoreCurrentCostCentre,
22
23 -- Lag/drag/void stuff
24 ldvEnter, ldvEnterClosure, ldvRecordCreate
25 ) where
26
27 #include "HsVersions.h"
28 #include "MachDeps.h"
29 -- For WORD_SIZE_IN_BITS only.
30 #include "../includes/Constants.h"
31 -- For LDV_CREATE_MASK, LDV_STATE_USE
32 -- which are StgWords
33 #include "../includes/DerivedConstants.h"
34 -- For REP_xxx constants, which are MachReps
35
36 import StgCmmClosure
37 import StgCmmUtils
38 import StgCmmMonad
39 import SMRep
40
41 import MkZipCfgCmm
42 import Cmm
43 import CmmUtils
44 import CLabel
45
46 import Id
47 import qualified Module
48 import CostCentre
49 import StgSyn
50 import StaticFlags
51 import FastString
52 import Constants -- Lots of field offsets
53 import Outputable
54
55 import Data.Maybe
56 import Data.Char
57 import Control.Monad
58
59 -----------------------------------------------------------------------------
60 --
61 -- Cost-centre-stack Profiling
62 --
63 -----------------------------------------------------------------------------
64
65 -- Expression representing the current cost centre stack
66 ccsType :: CmmType -- Type of a cost-centre stack
67 ccsType = bWord
68
69 ccType :: CmmType -- Type of a cost centre
70 ccType = bWord
71
72 curCCS :: CmmExpr
73 curCCS = CmmLoad curCCSAddr ccsType
74
75 -- Address of current CCS variable, for storing into
76 curCCSAddr :: CmmExpr
77 curCCSAddr = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCCS")))
78
79 mkCCostCentre :: CostCentre -> CmmLit
80 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
81
82 mkCCostCentreStack :: CostCentreStack -> CmmLit
83 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
84
85 costCentreFrom :: CmmExpr -- A closure pointer
86 -> CmmExpr -- The cost centre from that closure
87 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
88
89 staticProfHdr :: CostCentreStack -> [CmmLit]
90 -- The profiling header words in a static closure
91 -- Was SET_STATIC_PROF_HDR
92 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
93 staticLdvInit]
94
95 dynProfHdr :: CmmExpr -> [CmmExpr]
96 -- Profiling header words in a dynamic closure
97 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
98
99 initUpdFrameProf :: CmmExpr -> FCode ()
100 -- Initialise the profiling field of an update frame
101 initUpdFrameProf frame_amode
102 = ifProfiling $ -- frame->header.prof.ccs = CCCS
103 emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
104 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
105 -- is unnecessary because it is not used anyhow.
106
107 ---------------------------------------------------------------------------
108 -- Saving and restoring the current cost centre
109 ---------------------------------------------------------------------------
110
111 {- Note [Saving the current cost centre]
112 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
113 The current cost centre is like a global register. Like other
114 global registers, it's a caller-saves one. But consider
115 case (f x) of (p,q) -> rhs
116 Since 'f' may set the cost centre, we must restore it
117 before resuming rhs. So we want code like this:
118 local_cc = CCC -- save
119 r = f( x )
120 CCC = local_cc -- restore
121 That is, we explicitly "save" the current cost centre in
122 a LocalReg, local_cc; and restore it after the call. The
123 C-- infrastructure will arrange to save local_cc across the
124 call.
125
126 The same goes for join points;
127 let j x = join-stuff
128 in blah-blah
129 We want this kind of code:
130 local_cc = CCC -- save
131 blah-blah
132 J:
133 CCC = local_cc -- restore
134 -}
135
136 saveCurrentCostCentre :: FCode (Maybe LocalReg)
137 -- Returns Nothing if profiling is off
138 saveCurrentCostCentre
139 | not opt_SccProfilingOn
140 = return Nothing
141 | otherwise
142 = do { local_cc <- newTemp ccType
143 ; emit (mkAssign (CmmLocal local_cc) curCCS)
144 ; return (Just local_cc) }
145
146 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
147 restoreCurrentCostCentre Nothing
148 = return ()
149 restoreCurrentCostCentre (Just local_cc)
150 = emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))
151
152
153 -------------------------------------------------------------------------------
154 -- Recording allocation in a cost centre
155 -------------------------------------------------------------------------------
156
157 -- | Record the allocation of a closure. The CmmExpr is the cost
158 -- centre stack to which to attribute the allocation.
159 profDynAlloc :: ClosureInfo -> CmmExpr -> FCode ()
160 profDynAlloc cl_info ccs
161 = ifProfiling $
162 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
163
164 -- | Record the allocation of a closure (size is given by a CmmExpr)
165 -- The size must be in words, because the allocation counter in a CCS counts
166 -- in words.
167 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
168 profAlloc words ccs
169 = ifProfiling $
170 emit (addToMemE alloc_rep
171 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
172 (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
173 [CmmMachOp mo_wordSub [words,
174 CmmLit (mkIntCLit profHdrSize)]]))
175 -- subtract the "profiling overhead", which is the
176 -- profiling header in a closure.
177 where
178 alloc_rep = REP_CostCentreStack_mem_alloc
179
180 -- ----------------------------------------------------------------------
181 -- Setting the cost centre in a new closure
182
183 chooseDynCostCentres :: CostCentreStack
184 -> [Id] -- Args
185 -> StgExpr -- Body
186 -> FCode (CmmExpr, CmmExpr)
187 -- Called when allocating a closure
188 -- Tells which cost centre to put in the object, and which
189 -- to blame the cost of allocation on
190 chooseDynCostCentres ccs args body = do
191 -- Cost-centre we record in the object
192 use_ccs <- emitCCS ccs
193
194 -- Cost-centre on whom we blame the allocation
195 let blame_ccs
196 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
197 | otherwise = use_ccs
198
199 return (use_ccs, blame_ccs)
200
201
202 -- Some CostCentreStacks are a sequence of pushes on top of CCCS.
203 -- These pushes must be performed before we can refer to the stack in
204 -- an expression.
205 emitCCS :: CostCentreStack -> FCode CmmExpr
206 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
207 where
208 (cc's, ccs') = decomposeCCS ccs
209
210 push_em ccs [] = return ccs
211 push_em ccs (cc:rest) = do
212 tmp <- newTemp ccsType
213 pushCostCentre tmp ccs cc
214 push_em (CmmReg (CmmLocal tmp)) rest
215
216 ccsExpr :: CostCentreStack -> CmmExpr
217 ccsExpr ccs
218 | isCurrentCCS ccs = curCCS
219 | otherwise = CmmLit (mkCCostCentreStack ccs)
220
221
222 isBox :: StgExpr -> Bool
223 -- If it's an utterly trivial RHS, then it must be
224 -- one introduced by boxHigherOrderArgs for profiling,
225 -- so we charge it to "OVERHEAD".
226 -- This looks like a GROSS HACK to me --SDM
227 isBox (StgApp _ []) = True
228 isBox _ = False
229
230
231 -- -----------------------------------------------------------------------
232 -- Setting the current cost centre on entry to a closure
233
234 -- For lexically scoped profiling we have to load the cost centre from
235 -- the closure entered, if the costs are not supposed to be inherited.
236 -- This is done immediately on entering the fast entry point.
237
238 -- Load current cost centre from closure, if not inherited.
239 -- Node is guaranteed to point to it, if profiling and not inherited.
240
241 enterCostCentre
242 :: ClosureInfo
243 -> CostCentreStack
244 -> StgExpr -- The RHS of the closure
245 -> FCode ()
246
247 -- We used to have a special case for bindings of form
248 -- f = g True
249 -- where g has arity 2. The RHS is a thunk, but we don't
250 -- need to update it; and we want to subsume costs.
251 -- We don't have these sort of PAPs any more, so the special
252 -- case has gone away.
253
254 enterCostCentre closure_info ccs body
255 = ifProfiling $
256 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
257 enter_cost_centre closure_info ccs body
258
259 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> FCode ()
260 enter_cost_centre closure_info ccs body
261 | isSubsumedCCS ccs
262 = ASSERT(isToplevClosure closure_info)
263 ASSERT(re_entrant)
264 enter_ccs_fsub
265
266 | isDerivedFromCurrentCCS ccs
267 = do {
268 if re_entrant && not is_box
269 then
270 enter_ccs_fun node_ccs
271 else
272 emit (mkStore curCCSAddr node_ccs)
273
274 -- don't forget to bump the scc count. This closure might have been
275 -- of the form let x = _scc_ "x" e in ...x..., which the SCCfinal
276 -- pass has turned into simply let x = e in ...x... and attached
277 -- the _scc_ as PushCostCentre(x,CCCS) on the x closure. So that
278 -- we don't lose the scc counter, bump it in the entry code for x.
279 -- ToDo: for a multi-push we should really bump the counter for
280 -- each of the intervening CCSs, not just the top one.
281 ; when (not (isCurrentCCS ccs)) $
282 emit (bumpSccCount curCCS)
283 }
284
285 | isCafCCS ccs
286 = ASSERT(isToplevClosure closure_info)
287 ASSERT(not re_entrant)
288 do { -- This is just a special case of the isDerivedFromCurrentCCS
289 -- case above. We could delete this, but it's a micro
290 -- optimisation and saves a bit of code.
291 emit (mkStore curCCSAddr enc_ccs)
292 ; emit (bumpSccCount node_ccs)
293 }
294
295 | otherwise
296 = panic "enterCostCentre"
297 where
298 enc_ccs = CmmLit (mkCCostCentreStack ccs)
299 re_entrant = closureReEntrant closure_info
300 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
301 is_box = isBox body
302
303 -- if this is a function, then node will be tagged; we must subract the tag
304 node_tag = funTag closure_info
305
306 -- set the current CCS when entering a PAP
307 enterCostCentrePAP :: CmmExpr -> FCode ()
308 enterCostCentrePAP closure =
309 ifProfiling $ do
310 enter_ccs_fun (costCentreFrom closure)
311 enteringPAP 1
312
313 enterCostCentreThunk :: CmmExpr -> FCode ()
314 enterCostCentreThunk closure =
315 ifProfiling $ do
316 emit $ mkStore curCCSAddr (costCentreFrom closure)
317
318 enter_ccs_fun :: CmmExpr -> FCode ()
319 enter_ccs_fun stack = emitRtsCall (sLit "EnterFunCCS") [(stack,AddrHint)] False
320 -- ToDo: vols
321
322 enter_ccs_fsub :: FCode ()
323 enter_ccs_fsub = enteringPAP 0
324
325 -- When entering a PAP, EnterFunCCS is called by both the PAP entry
326 -- code and the function entry code; we don't want the function's
327 -- entry code to also update CCCS in the event that it was called via
328 -- a PAP, so we set the flag entering_PAP to indicate that we are
329 -- entering via a PAP.
330 enteringPAP :: Integer -> FCode ()
331 enteringPAP n
332 = emit (mkStore (CmmLit (CmmLabel (mkRtsDataLabel (sLit "entering_PAP"))))
333 (CmmLit (CmmInt n cIntWidth)))
334
335 ifProfiling :: FCode () -> FCode ()
336 ifProfiling code
337 | opt_SccProfilingOn = code
338 | otherwise = nopC
339
340 ifProfilingL :: [a] -> [a]
341 ifProfilingL xs
342 | opt_SccProfilingOn = xs
343 | otherwise = []
344
345
346 ---------------------------------------------------------------
347 -- Initialising Cost Centres & CCSs
348 ---------------------------------------------------------------
349
350 initCostCentres :: CollectedCCs -> FCode CmmAGraph
351 -- Emit the declarations, and return code to register them
352 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
353 = getCode $ whenC opt_SccProfilingOn $
354 do { mapM_ emitCostCentreDecl local_CCs
355 ; mapM_ emitCostCentreStackDecl singleton_CCSs
356 ; emit $ catAGraphs $ map mkRegisterCC local_CCs
357 ; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
358
359
360 emitCostCentreDecl :: CostCentre -> FCode ()
361 emitCostCentreDecl cc = do
362 { label <- mkStringCLit (costCentreUserName cc)
363 ; modl <- mkStringCLit (Module.moduleNameString
364 (Module.moduleName (cc_mod cc)))
365 -- All cost centres will be in the main package, since we
366 -- don't normally use -auto-all or add SCCs to other packages.
367 -- Hence don't emit the package name in the module here.
368 ; let lits = [ zero, -- StgInt ccID,
369 label, -- char *label,
370 modl, -- char *module,
371 zero, -- StgWord time_ticks
372 zero64, -- StgWord64 mem_alloc
373 subsumed, -- StgInt is_caf
374 zero -- struct _CostCentre *link
375 ]
376 ; emitDataLits (mkCCLabel cc) lits
377 }
378 where
379 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
380 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
381
382 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
383 emitCostCentreStackDecl ccs
384 = case maybeSingletonCCS ccs of
385 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
386 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
387 where
388 mk_lits cc = zero :
389 mkCCostCentre cc :
390 replicate (sizeof_ccs_words - 2) zero
391 -- Note: to avoid making any assumptions about how the
392 -- C compiler (that compiles the RTS, in particular) does
393 -- layouts of structs containing long-longs, simply
394 -- pad out the struct with zero words until we hit the
395 -- size of the overall struct (which we get via DerivedConstants.h)
396
397 zero :: CmmLit
398 zero = mkIntCLit 0
399 zero64 :: CmmLit
400 zero64 = CmmInt 0 W64
401
402 sizeof_ccs_words :: Int
403 sizeof_ccs_words
404 -- round up to the next word.
405 | ms == 0 = ws
406 | otherwise = ws + 1
407 where
408 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
409
410 -- ---------------------------------------------------------------------------
411 -- Registering CCs and CCSs
412
413 -- (cc)->link = CC_LIST;
414 -- CC_LIST = (cc);
415 -- (cc)->ccID = CC_ID++;
416
417 mkRegisterCC :: CostCentre -> CmmAGraph
418 mkRegisterCC cc
419 = withTemp cInt $ \tmp ->
420 catAGraphs [
421 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
422 (CmmLoad cC_LIST bWord),
423 mkStore cC_LIST cc_lit,
424 mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
425 mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
426 mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
427 ]
428 where
429 cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
430
431 -- (ccs)->prevStack = CCS_LIST;
432 -- CCS_LIST = (ccs);
433 -- (ccs)->ccsID = CCS_ID++;
434
435 mkRegisterCCS :: CostCentreStack -> CmmAGraph
436 mkRegisterCCS ccs
437 = withTemp cInt $ \ tmp ->
438 catAGraphs [
439 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
440 (CmmLoad cCS_LIST bWord),
441 mkStore cCS_LIST ccs_lit,
442 mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
443 mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
444 mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
445 ]
446 where
447 ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
448
449
450 cC_LIST, cC_ID :: CmmExpr
451 cC_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_LIST")))
452 cC_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CC_ID")))
453
454 cCS_LIST, cCS_ID :: CmmExpr
455 cCS_LIST = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_LIST")))
456 cCS_ID = CmmLit (CmmLabel (mkRtsDataLabel (sLit "CCS_ID")))
457
458 -- ---------------------------------------------------------------------------
459 -- Set the current cost centre stack
460
461 emitSetCCC :: CostCentre -> FCode ()
462 emitSetCCC cc
463 | not opt_SccProfilingOn = nopC
464 | otherwise = do
465 tmp <- newTemp ccsType -- TODO FIXME NOW
466 ASSERT( sccAbleCostCentre cc )
467 pushCostCentre tmp curCCS cc
468 emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
469 when (isSccCountCostCentre cc) $
470 emit (bumpSccCount curCCS)
471
472 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
473 pushCostCentre result ccs cc
474 = emitRtsCallWithResult result AddrHint
475 (sLit "PushCostCentre") [(ccs,AddrHint),
476 (CmmLit (mkCCostCentre cc), AddrHint)]
477 False
478
479 bumpSccCount :: CmmExpr -> CmmAGraph
480 bumpSccCount ccs
481 = addToMem REP_CostCentreStack_scc_count
482 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
483
484 -----------------------------------------------------------------------------
485 --
486 -- Lag/drag/void stuff
487 --
488 -----------------------------------------------------------------------------
489
490 --
491 -- Initial value for the LDV field in a static closure
492 --
493 staticLdvInit :: CmmLit
494 staticLdvInit = zeroCLit
495
496 --
497 -- Initial value of the LDV field in a dynamic closure
498 --
499 dynLdvInit :: CmmExpr
500 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
501 CmmMachOp mo_wordOr [
502 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
503 CmmLit (mkWordCLit lDV_STATE_CREATE)
504 ]
505
506 --
507 -- Initialise the LDV word of a new closure
508 --
509 ldvRecordCreate :: CmmExpr -> FCode ()
510 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
511
512 --
513 -- Called when a closure is entered, marks the closure as having been "used".
514 -- The closure is not an 'inherently used' one.
515 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
516 -- profiling.
517 --
518 ldvEnterClosure :: ClosureInfo -> FCode ()
519 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
520 where tag = funTag closure_info
521 -- don't forget to substract node's tag
522
523 ldvEnter :: CmmExpr -> FCode ()
524 -- Argument is a closure pointer
525 ldvEnter cl_ptr
526 = ifProfiling $
527 -- if (era > 0) {
528 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
529 -- era | LDV_STATE_USE }
530 emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
531 (mkStore ldv_wd new_ldv_wd)
532 mkNop)
533 where
534 -- don't forget to substract node's tag
535 ldv_wd = ldvWord cl_ptr
536 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
537 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
538 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
539
540 loadEra :: CmmExpr
541 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
542 [CmmLoad (mkLblExpr (mkRtsDataLabel (sLit "era"))) cInt]
543
544 ldvWord :: CmmExpr -> CmmExpr
545 -- Takes the address of a closure, and returns
546 -- the address of the LDV word in the closure
547 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
548
549 -- LDV constants, from ghc/includes/Constants.h
550 lDV_SHIFT :: Int
551 lDV_SHIFT = LDV_SHIFT
552 --lDV_STATE_MASK :: StgWord
553 --lDV_STATE_MASK = LDV_STATE_MASK
554 lDV_CREATE_MASK :: StgWord
555 lDV_CREATE_MASK = LDV_CREATE_MASK
556 --lDV_LAST_MASK :: StgWord
557 --lDV_LAST_MASK = LDV_LAST_MASK
558 lDV_STATE_CREATE :: StgWord
559 lDV_STATE_CREATE = LDV_STATE_CREATE
560 lDV_STATE_USE :: StgWord
561 lDV_STATE_USE = LDV_STATE_USE
562