243aa1d89a9e614788bb7e760a3968a1e2f0cc31
[ghc.git] / compiler / codeGen / CgProf.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgProf (
10 mkCCostCentre, mkCCostCentreStack,
11
12 -- Cost-centre Profiling
13 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
14 enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
15 chooseDynCostCentres,
16 costCentreFrom,
17 curCCS, curCCSAddr,
18 emitCostCentreDecl, emitCostCentreStackDecl,
19 emitSetCCC, emitCCS,
20
21 -- Lag/drag/void stuff
22 ldvEnter, ldvEnterClosure, ldvRecordCreate
23 ) where
24
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
30 -- which are StgWords
31 #include "../includes/DerivedConstants.h"
32 -- For REP_xxx constants, which are MachReps
33
34 import ClosureInfo
35 import CgUtils
36 import CgMonad
37 import SMRep
38
39 import OldCmm
40 import OldCmmUtils
41 import CLabel
42
43 import Id
44 import qualified Module
45 import CostCentre
46 import StgSyn
47 import StaticFlags
48 import FastString
49 import Module
50 import Constants -- Lots of field offsets
51 import Outputable
52
53 import Data.Char
54 import Control.Monad
55
56 -----------------------------------------------------------------------------
57 --
58 -- Cost-centre-stack Profiling
59 --
60 -----------------------------------------------------------------------------
61
62 -- Expression representing the current cost centre stack
63 curCCS :: CmmExpr
64 curCCS = CmmLoad curCCSAddr bWord
65
66 -- Address of current CCS variable, for storing into
67 curCCSAddr :: CmmExpr
68 curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
69
70 mkCCostCentre :: CostCentre -> CmmLit
71 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
72
73 mkCCostCentreStack :: CostCentreStack -> CmmLit
74 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
75
76 costCentreFrom :: CmmExpr -- A closure pointer
77 -> CmmExpr -- The cost centre from that closure
78 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) bWord
79
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,
84 staticLdvInit]
85
86 dynProfHdr :: CmmExpr -> [CmmExpr]
87 -- Profiling header words in a dynamic closure
88 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
89
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.
97
98 -- -----------------------------------------------------------------------------
99 -- Recording allocation in a cost centre
100
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
105 = ifProfiling $
106 profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
107
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
110 -- in words.
111 profAlloc :: CmmExpr -> CmmExpr -> Code
112 profAlloc words ccs
113 = ifProfiling $
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.
121 where
122 alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
123
124 -- ----------------------------------------------------------------------
125 -- Setting the cost centre in a new closure
126
127 chooseDynCostCentres :: CostCentreStack
128 -> [Id] -- Args
129 -> StgExpr -- Body
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
137
138 -- Cost-centre on whom we blame the allocation
139 let blame_ccs
140 | null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
141 | otherwise = use_ccs
142
143 return (use_ccs, blame_ccs)
144
145
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
148 -- an expression.
149 emitCCS :: CostCentreStack -> FCode CmmExpr
150 emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
151 where
152 (cc's, ccs') = decomposeCCS ccs
153
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
159
160 ccsExpr :: CostCentreStack -> CmmExpr
161 ccsExpr ccs
162 | isCurrentCCS ccs = curCCS
163 | otherwise = CmmLit (mkCCostCentreStack ccs)
164
165
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
172 isBox _ = False
173
174
175 -- -----------------------------------------------------------------------
176 -- Setting the current cost centre on entry to a closure
177
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.
181
182 -- Load current cost centre from closure, if not inherited.
183 -- Node is guaranteed to point to it, if profiling and not inherited.
184
185 enterCostCentre
186 :: ClosureInfo
187 -> CostCentreStack
188 -> StgExpr -- The RHS of the closure
189 -> Code
190
191 -- We used to have a special case for bindings of form
192 -- f = g True
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.
197
198 enterCostCentre closure_info ccs body
199 = ifProfiling $
200 ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
201 enter_cost_centre closure_info ccs body
202
203 enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> Code
204 enter_cost_centre closure_info ccs body
205 | isSubsumedCCS ccs
206 = ASSERT(isToplevClosure closure_info)
207 ASSERT(re_entrant)
208 enter_ccs_fsub
209
210 | isDerivedFromCurrentCCS ccs
211 = do {
212 if re_entrant && not is_box
213 then
214 enter_ccs_fun node_ccs
215 else
216 stmtC (CmmStore curCCSAddr node_ccs)
217
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)
227 }
228
229 | isCafCCS ccs
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)
237 }
238
239 | otherwise
240 = panic "enterCostCentre"
241 where
242 enc_ccs = CmmLit (mkCCostCentreStack ccs)
243 re_entrant = closureReEntrant closure_info
244 node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (-node_tag))
245 is_box = isBox body
246
247 -- if this is a function, then node will be tagged; we must subract the tag
248 node_tag = funTag closure_info
249
250 -- set the current CCS when entering a PAP
251 enterCostCentrePAP :: CmmExpr -> Code
252 enterCostCentrePAP closure =
253 ifProfiling $ do
254 enter_ccs_fun (costCentreFrom closure)
255 enteringPAP 1
256
257 enterCostCentreThunk :: CmmExpr -> Code
258 enterCostCentreThunk closure =
259 ifProfiling $ do
260 stmtC $ CmmStore curCCSAddr (costCentreFrom closure)
261
262 enter_ccs_fun :: CmmExpr -> Code
263 enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [CmmHinted stack AddrHint] False
264 -- ToDo: vols
265
266 enter_ccs_fsub :: Code
267 enter_ccs_fsub = enteringPAP 0
268
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
275 enteringPAP n
276 = stmtC (CmmStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
277 (CmmLit (CmmInt n cIntWidth)))
278
279 ifProfiling :: Code -> Code
280 ifProfiling code
281 | opt_SccProfilingOn = code
282 | otherwise = nopC
283
284 ifProfilingL :: [a] -> [a]
285 ifProfilingL xs
286 | opt_SccProfilingOn = xs
287 | otherwise = []
288
289
290 -- ---------------------------------------------------------------------------
291 -- Initialising Cost Centres & CCSs
292
293 emitCostCentreDecl
294 :: CostCentre
295 -> Code
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.
303 ; let
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
311 ]
312 ; emitDataLits (mkCCLabel cc) lits
313 }
314 where
315 subsumed | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
316 | otherwise = mkIntCLit (ord 'B') -- 'B' == is boring
317
318
319 emitCostCentreStackDecl
320 :: CostCentreStack
321 -> Code
322 emitCostCentreStackDecl ccs
323 | Just cc <- maybeSingletonCCS ccs = do
324 { let
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)
330 --
331 lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words - 2) zero
332 ; emitDataLits (mkCCSLabel ccs) lits
333 }
334 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
335
336 zero :: CmmLit
337 zero = mkIntCLit 0
338 zero64 :: CmmLit
339 zero64 = CmmInt 0 W64
340
341 sizeof_ccs_words :: Int
342 sizeof_ccs_words
343 -- round up to the next word.
344 | ms == 0 = ws
345 | otherwise = ws + 1
346 where
347 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
348
349 -- ---------------------------------------------------------------------------
350 -- Set the current cost centre stack
351
352 emitSetCCC :: CostCentre -> Code
353 emitSetCCC cc
354 | not opt_SccProfilingOn = nopC
355 | otherwise = do
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)
362
363 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
364 pushCostCentre result ccs cc
365 = emitRtsCallWithResult result AddrHint
366 rtsPackageId
367 (fsLit "PushCostCentre") [CmmHinted ccs AddrHint,
368 CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
369 False
370
371 bumpSccCount :: CmmExpr -> CmmStmt
372 bumpSccCount ccs
373 = addToMem (typeWidth REP_CostCentreStack_scc_count)
374 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
375
376 -----------------------------------------------------------------------------
377 --
378 -- Lag/drag/void stuff
379 --
380 -----------------------------------------------------------------------------
381
382 --
383 -- Initial value for the LDV field in a static closure
384 --
385 staticLdvInit :: CmmLit
386 staticLdvInit = zeroCLit
387
388 --
389 -- Initial value of the LDV field in a dynamic closure
390 --
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)
396 ]
397
398 --
399 -- Initialise the LDV word of a new closure
400 --
401 ldvRecordCreate :: CmmExpr -> Code
402 ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
403
404 --
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
408 -- profiling.
409 --
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
414
415 ldvEnter :: CmmExpr -> Code
416 -- Argument is a closure pointer
417 ldvEnter cl_ptr
418 = ifProfiling $
419 -- if (era > 0) {
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))
424 where
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)))
430
431 loadEra :: CmmExpr
432 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
433 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) cInt]
434
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
439
440 -- LDV constants, from ghc/includes/Constants.h
441 lDV_SHIFT :: Int
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
453