Merge branch 'master' of http://darcs.haskell.org/ghc
[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 {-# OPTIONS -fno-warn-tabs #-}
10 -- The above warning supression flag is a temporary kludge.
11 -- While working on this module you are encouraged to remove it and
12 -- detab the module (please do the detabbing in a separate patch). See
13 -- http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#TabsvsSpaces
14 -- for details
15
16 module StgCmmProf (
17 initCostCentres, ccType, ccsType,
18 mkCCostCentre, mkCCostCentreStack,
19
20 -- Cost-centre Profiling
21 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
22 enterCostCentreThunk,
23 costCentreFrom,
24 curCCS, curCCSAddr,
25 emitSetCCC,
26
27 saveCurrentCostCentre, restoreCurrentCostCentre,
28
29 -- Lag/drag/void stuff
30 ldvEnter, ldvEnterClosure, ldvRecordCreate
31 ) where
32
33 #include "HsVersions.h"
34 #include "../includes/MachDeps.h"
35 -- For WORD_SIZE_IN_BITS only.
36 #include "../includes/rts/Constants.h"
37 -- For LDV_CREATE_MASK, LDV_STATE_USE
38 -- which are StgWords
39 #include "../includes/DerivedConstants.h"
40 -- For REP_xxx constants, which are MachReps
41
42 import StgCmmClosure
43 import StgCmmUtils
44 import StgCmmMonad
45 import SMRep
46
47 import MkGraph
48 import Cmm
49 import CmmUtils
50 import CLabel
51
52 import qualified Module
53 import CostCentre
54 import StaticFlags
55 import FastString
56 import Module
57 import Constants -- Lots of field offsets
58 import Outputable
59
60 import Control.Monad
61
62 -----------------------------------------------------------------------------
63 --
64 -- Cost-centre-stack Profiling
65 --
66 -----------------------------------------------------------------------------
67
68 -- Expression representing the current cost centre stack
69 ccsType :: CmmType -- Type of a cost-centre stack
70 ccsType = bWord
71
72 ccType :: CmmType -- Type of a cost centre
73 ccType = bWord
74
75 curCCS :: CmmExpr
76 curCCS = CmmLoad curCCSAddr ccsType
77
78 -- Address of current CCS variable, for storing into
79 curCCSAddr :: CmmExpr
80 curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
81
82 mkCCostCentre :: CostCentre -> CmmLit
83 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
84
85 mkCCostCentreStack :: CostCentreStack -> CmmLit
86 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
87
88 costCentreFrom :: CmmExpr -- A closure pointer
89 -> CmmExpr -- The cost centre from that closure
90 costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
91
92 staticProfHdr :: CostCentreStack -> [CmmLit]
93 -- The profiling header words in a static closure
94 -- Was SET_STATIC_PROF_HDR
95 staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
96 staticLdvInit]
97
98 dynProfHdr :: CmmExpr -> [CmmExpr]
99 -- Profiling header words in a dynamic closure
100 dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
101
102 initUpdFrameProf :: CmmExpr -> FCode ()
103 -- Initialise the profiling field of an update frame
104 initUpdFrameProf frame_amode
105 = ifProfiling $ -- frame->header.prof.ccs = CCCS
106 emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
107 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
108 -- is unnecessary because it is not used anyhow.
109
110 ---------------------------------------------------------------------------
111 -- Saving and restoring the current cost centre
112 ---------------------------------------------------------------------------
113
114 {- Note [Saving the current cost centre]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 The current cost centre is like a global register. Like other
117 global registers, it's a caller-saves one. But consider
118 case (f x) of (p,q) -> rhs
119 Since 'f' may set the cost centre, we must restore it
120 before resuming rhs. So we want code like this:
121 local_cc = CCC -- save
122 r = f( x )
123 CCC = local_cc -- restore
124 That is, we explicitly "save" the current cost centre in
125 a LocalReg, local_cc; and restore it after the call. The
126 C-- infrastructure will arrange to save local_cc across the
127 call.
128
129 The same goes for join points;
130 let j x = join-stuff
131 in blah-blah
132 We want this kind of code:
133 local_cc = CCC -- save
134 blah-blah
135 J:
136 CCC = local_cc -- restore
137 -}
138
139 saveCurrentCostCentre :: FCode (Maybe LocalReg)
140 -- Returns Nothing if profiling is off
141 saveCurrentCostCentre
142 | not opt_SccProfilingOn
143 = return Nothing
144 | otherwise
145 = do { local_cc <- newTemp ccType
146 ; emit (mkAssign (CmmLocal local_cc) curCCS)
147 ; return (Just local_cc) }
148
149 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
150 restoreCurrentCostCentre Nothing
151 = return ()
152 restoreCurrentCostCentre (Just local_cc)
153 = emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))
154
155
156 -------------------------------------------------------------------------------
157 -- Recording allocation in a cost centre
158 -------------------------------------------------------------------------------
159
160 -- | Record the allocation of a closure. The CmmExpr is the cost
161 -- centre stack to which to attribute the allocation.
162 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
163 profDynAlloc rep ccs
164 = ifProfiling $
165 profAlloc (CmmLit (mkIntCLit (heapClosureSize rep))) ccs
166
167 -- | Record the allocation of a closure (size is given by a CmmExpr)
168 -- The size must be in words, because the allocation counter in a CCS counts
169 -- in words.
170 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
171 profAlloc words ccs
172 = ifProfiling $
173 emit (addToMemE alloc_rep
174 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
175 (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
176 [CmmMachOp mo_wordSub [words,
177 CmmLit (mkIntCLit profHdrSize)]]))
178 -- subtract the "profiling overhead", which is the
179 -- profiling header in a closure.
180 where
181 alloc_rep = REP_CostCentreStack_mem_alloc
182
183 -- -----------------------------------------------------------------------
184 -- Setting the current cost centre on entry to a closure
185
186 enterCostCentreThunk :: CmmExpr -> FCode ()
187 enterCostCentreThunk closure =
188 ifProfiling $ do
189 emit $ mkStore curCCSAddr (costCentreFrom closure)
190
191 ifProfiling :: FCode () -> FCode ()
192 ifProfiling code
193 | opt_SccProfilingOn = code
194 | otherwise = nopC
195
196 ifProfilingL :: [a] -> [a]
197 ifProfilingL xs
198 | opt_SccProfilingOn = xs
199 | otherwise = []
200
201
202 ---------------------------------------------------------------
203 -- Initialising Cost Centres & CCSs
204 ---------------------------------------------------------------
205
206 initCostCentres :: CollectedCCs -> FCode ()
207 -- Emit the declarations
208 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
209 = whenC opt_SccProfilingOn $
210 do { mapM_ emitCostCentreDecl local_CCs
211 ; mapM_ emitCostCentreStackDecl singleton_CCSs }
212
213
214 emitCostCentreDecl :: CostCentre -> FCode ()
215 emitCostCentreDecl cc = do
216 { label <- newStringCLit (costCentreUserName cc)
217 ; modl <- newStringCLit (Module.moduleNameString
218 (Module.moduleName (cc_mod cc)))
219 -- All cost centres will be in the main package, since we
220 -- don't normally use -auto-all or add SCCs to other packages.
221 -- Hence don't emit the package name in the module here.
222 ; let lits = [ zero, -- StgInt ccID,
223 label, -- char *label,
224 modl, -- char *module,
225 zero, -- StgWord time_ticks
226 zero64, -- StgWord64 mem_alloc
227 zero -- struct _CostCentre *link
228 ]
229 ; emitDataLits (mkCCLabel cc) lits
230 }
231
232 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
233 emitCostCentreStackDecl ccs
234 = case maybeSingletonCCS ccs of
235 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
236 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
237 where
238 mk_lits cc = zero :
239 mkCCostCentre cc :
240 replicate (sizeof_ccs_words - 2) zero
241 -- Note: to avoid making any assumptions about how the
242 -- C compiler (that compiles the RTS, in particular) does
243 -- layouts of structs containing long-longs, simply
244 -- pad out the struct with zero words until we hit the
245 -- size of the overall struct (which we get via DerivedConstants.h)
246
247 zero :: CmmLit
248 zero = mkIntCLit 0
249 zero64 :: CmmLit
250 zero64 = CmmInt 0 W64
251
252 sizeof_ccs_words :: Int
253 sizeof_ccs_words
254 -- round up to the next word.
255 | ms == 0 = ws
256 | otherwise = ws + 1
257 where
258 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
259
260 -- ---------------------------------------------------------------------------
261 -- Set the current cost centre stack
262
263 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
264 emitSetCCC cc tick push
265 | not opt_SccProfilingOn = nopC
266 | otherwise = do
267 tmp <- newTemp ccsType -- TODO FIXME NOW
268 pushCostCentre tmp curCCS cc
269 when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
270 when push $ emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
271
272 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
273 pushCostCentre result ccs cc
274 = emitRtsCallWithResult result AddrHint
275 rtsPackageId
276 (fsLit "PushCostCentre") [(ccs,AddrHint),
277 (CmmLit (mkCCostCentre cc), AddrHint)]
278 False
279
280 bumpSccCount :: CmmExpr -> CmmAGraph
281 bumpSccCount ccs
282 = addToMem REP_CostCentreStack_scc_count
283 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
284
285 -----------------------------------------------------------------------------
286 --
287 -- Lag/drag/void stuff
288 --
289 -----------------------------------------------------------------------------
290
291 --
292 -- Initial value for the LDV field in a static closure
293 --
294 staticLdvInit :: CmmLit
295 staticLdvInit = zeroCLit
296
297 --
298 -- Initial value of the LDV field in a dynamic closure
299 --
300 dynLdvInit :: CmmExpr
301 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
302 CmmMachOp mo_wordOr [
303 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
304 CmmLit (mkWordCLit lDV_STATE_CREATE)
305 ]
306
307 --
308 -- Initialise the LDV word of a new closure
309 --
310 ldvRecordCreate :: CmmExpr -> FCode ()
311 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
312
313 --
314 -- Called when a closure is entered, marks the closure as having been "used".
315 -- The closure is not an 'inherently used' one.
316 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
317 -- profiling.
318 --
319 ldvEnterClosure :: ClosureInfo -> FCode ()
320 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
321 where tag = funTag closure_info
322 -- don't forget to substract node's tag
323
324 ldvEnter :: CmmExpr -> FCode ()
325 -- Argument is a closure pointer
326 ldvEnter cl_ptr
327 = ifProfiling $
328 -- if (era > 0) {
329 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
330 -- era | LDV_STATE_USE }
331 emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
332 (mkStore ldv_wd new_ldv_wd)
333 mkNop)
334 where
335 -- don't forget to substract node's tag
336 ldv_wd = ldvWord cl_ptr
337 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
338 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
339 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
340
341 loadEra :: CmmExpr
342 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
343 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
344
345 ldvWord :: CmmExpr -> CmmExpr
346 -- Takes the address of a closure, and returns
347 -- the address of the LDV word in the closure
348 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
349
350 -- LDV constants, from ghc/includes/Constants.h
351 lDV_SHIFT :: Int
352 lDV_SHIFT = LDV_SHIFT
353 --lDV_STATE_MASK :: StgWord
354 --lDV_STATE_MASK = LDV_STATE_MASK
355 lDV_CREATE_MASK :: StgWord
356 lDV_CREATE_MASK = LDV_CREATE_MASK
357 --lDV_LAST_MASK :: StgWord
358 --lDV_LAST_MASK = LDV_LAST_MASK
359 lDV_STATE_CREATE :: StgWord
360 lDV_STATE_CREATE = LDV_STATE_CREATE
361 lDV_STATE_USE :: StgWord
362 lDV_STATE_USE = LDV_STATE_USE
363