Cleanup: add mkIntExpr and zeroExpr utils
[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, enterCostCentreFun,
23 costCentreFrom,
24 curCCS, storeCurCCS,
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/dist-derivedconstants/header/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 DynFlags
55 import FastString
56 import Module
57 import Constants -- Lots of field offsets
58 import Outputable
59
60 import Control.Monad
61 import Data.Char (ord)
62
63 -----------------------------------------------------------------------------
64 --
65 -- Cost-centre-stack Profiling
66 --
67 -----------------------------------------------------------------------------
68
69 -- Expression representing the current cost centre stack
70 ccsType :: CmmType -- Type of a cost-centre stack
71 ccsType = bWord
72
73 ccType :: CmmType -- Type of a cost centre
74 ccType = bWord
75
76 curCCS :: CmmExpr
77 curCCS = CmmReg (CmmGlobal CCCS)
78
79 storeCurCCS :: CmmExpr -> CmmAGraph
80 storeCurCCS e = mkAssign (CmmGlobal CCCS) e
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 :: DynFlags -> CostCentreStack -> [CmmLit]
93 -- The profiling header words in a static closure
94 -- Was SET_STATIC_PROF_HDR
95 staticProfHdr dflags ccs
96 = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit]
97
98 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
99 -- Profiling header words in a dynamic closure
100 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit]
101
102 initUpdFrameProf :: ByteOff -> FCode ()
103 -- Initialise the profiling field of an update frame
104 initUpdFrameProf frame_off
105 = ifProfiling $ -- frame->header.prof.ccs = CCCS
106 emitStore (CmmStackSlot Old (frame_off - 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 = do dflags <- getDynFlags
143 if not (dopt Opt_SccProfilingOn dflags)
144 then return Nothing
145 else do local_cc <- newTemp ccType
146 emitAssign (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 (storeCurCCS (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 do dflags <- getDynFlags
166 profAlloc (mkIntExpr (heapClosureSize dflags rep)) ccs
167
168 -- | Record the allocation of a closure (size is given by a CmmExpr)
169 -- The size must be in words, because the allocation counter in a CCS counts
170 -- in words.
171 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
172 profAlloc words ccs
173 = ifProfiling $
174 do dflags <- getDynFlags
175 emit (addToMemE alloc_rep
176 (cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
177 (CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
178 [CmmMachOp mo_wordSub [words,
179 mkIntExpr (profHdrSize dflags)]]))
180 -- subtract the "profiling overhead", which is the
181 -- profiling header in a closure.
182 where
183 alloc_rep = REP_CostCentreStack_mem_alloc
184
185 -- -----------------------------------------------------------------------
186 -- Setting the current cost centre on entry to a closure
187
188 enterCostCentreThunk :: CmmExpr -> FCode ()
189 enterCostCentreThunk closure =
190 ifProfiling $ do
191 emit $ storeCurCCS (costCentreFrom closure)
192
193 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
194 enterCostCentreFun ccs closure =
195 ifProfiling $ do
196 if isCurrentCCS ccs
197 then emitRtsCall rtsPackageId (fsLit "enterFunCCS")
198 [(CmmReg (CmmGlobal BaseReg), AddrHint),
199 (costCentreFrom closure, AddrHint)] False
200 else return () -- top-level function, nothing to do
201
202 ifProfiling :: FCode () -> FCode ()
203 ifProfiling code
204 = do dflags <- getDynFlags
205 if dopt Opt_SccProfilingOn dflags
206 then code
207 else nopC
208
209 ifProfilingL :: DynFlags -> [a] -> [a]
210 ifProfilingL dflags xs
211 | dopt Opt_SccProfilingOn dflags = xs
212 | otherwise = []
213
214
215 ---------------------------------------------------------------
216 -- Initialising Cost Centres & CCSs
217 ---------------------------------------------------------------
218
219 initCostCentres :: CollectedCCs -> FCode ()
220 -- Emit the declarations
221 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
222 = do dflags <- getDynFlags
223 whenC (dopt Opt_SccProfilingOn dflags) $
224 do mapM_ emitCostCentreDecl local_CCs
225 mapM_ emitCostCentreStackDecl singleton_CCSs
226
227
228 emitCostCentreDecl :: CostCentre -> FCode ()
229 emitCostCentreDecl cc = do
230 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
231 { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
232 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
233 $ Module.moduleName
234 $ cc_mod cc)
235 ; dflags <- getDynFlags
236 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
237 showPpr dflags (costCentreSrcSpan cc)
238 -- XXX going via FastString to get UTF-8 encoding is silly
239 ; let
240 lits = [ zero, -- StgInt ccID,
241 label, -- char *label,
242 modl, -- char *module,
243 loc, -- char *srcloc,
244 zero64, -- StgWord64 mem_alloc
245 zero, -- StgWord time_ticks
246 is_caf, -- StgInt is_caf
247 zero -- struct _CostCentre *link
248 ]
249 ; emitDataLits (mkCCLabel cc) lits
250 }
251 where
252 is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
253 | otherwise = zero
254
255 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
256 emitCostCentreStackDecl ccs
257 = case maybeSingletonCCS ccs of
258 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
259 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
260 where
261 mk_lits cc = zero :
262 mkCCostCentre cc :
263 replicate (sizeof_ccs_words - 2) zero
264 -- Note: to avoid making any assumptions about how the
265 -- C compiler (that compiles the RTS, in particular) does
266 -- layouts of structs containing long-longs, simply
267 -- pad out the struct with zero words until we hit the
268 -- size of the overall struct (which we get via DerivedConstants.h)
269
270 zero :: CmmLit
271 zero = mkIntCLit 0
272 zero64 :: CmmLit
273 zero64 = CmmInt 0 W64
274
275 sizeof_ccs_words :: Int
276 sizeof_ccs_words
277 -- round up to the next word.
278 | ms == 0 = ws
279 | otherwise = ws + 1
280 where
281 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
282
283 -- ---------------------------------------------------------------------------
284 -- Set the current cost centre stack
285
286 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
287 emitSetCCC cc tick push
288 = do dflags <- getDynFlags
289 if not (dopt Opt_SccProfilingOn dflags)
290 then nopC
291 else do tmp <- newTemp ccsType -- TODO FIXME NOW
292 pushCostCentre tmp curCCS cc
293 when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
294 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
295
296 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
297 pushCostCentre result ccs cc
298 = emitRtsCallWithResult result AddrHint
299 rtsPackageId
300 (fsLit "pushCostCentre") [(ccs,AddrHint),
301 (CmmLit (mkCCostCentre cc), AddrHint)]
302 False
303
304 bumpSccCount :: CmmExpr -> CmmAGraph
305 bumpSccCount ccs
306 = addToMem REP_CostCentreStack_scc_count
307 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
308
309 -----------------------------------------------------------------------------
310 --
311 -- Lag/drag/void stuff
312 --
313 -----------------------------------------------------------------------------
314
315 --
316 -- Initial value for the LDV field in a static closure
317 --
318 staticLdvInit :: CmmLit
319 staticLdvInit = zeroCLit
320
321 --
322 -- Initial value of the LDV field in a dynamic closure
323 --
324 dynLdvInit :: CmmExpr
325 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
326 CmmMachOp mo_wordOr [
327 CmmMachOp mo_wordShl [loadEra, mkIntExpr lDV_SHIFT ],
328 CmmLit (mkWordCLit lDV_STATE_CREATE)
329 ]
330
331 --
332 -- Initialise the LDV word of a new closure
333 --
334 ldvRecordCreate :: CmmExpr -> FCode ()
335 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
336
337 --
338 -- Called when a closure is entered, marks the closure as having been "used".
339 -- The closure is not an 'inherently used' one.
340 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
341 -- profiling.
342 --
343 ldvEnterClosure :: ClosureInfo -> FCode ()
344 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
345 where tag = funTag closure_info
346 -- don't forget to substract node's tag
347
348 ldvEnter :: CmmExpr -> FCode ()
349 -- Argument is a closure pointer
350 ldvEnter cl_ptr
351 = ifProfiling $
352 -- if (era > 0) {
353 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
354 -- era | LDV_STATE_USE }
355 emit =<< mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
356 (mkStore ldv_wd new_ldv_wd)
357 mkNop
358 where
359 -- don't forget to substract node's tag
360 ldv_wd = ldvWord cl_ptr
361 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
362 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
363 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
364
365 loadEra :: CmmExpr
366 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
367 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
368
369 ldvWord :: CmmExpr -> CmmExpr
370 -- Takes the address of a closure, and returns
371 -- the address of the LDV word in the closure
372 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
373
374 -- LDV constants, from ghc/includes/Constants.h
375 lDV_SHIFT :: Int
376 lDV_SHIFT = LDV_SHIFT
377 --lDV_STATE_MASK :: StgWord
378 --lDV_STATE_MASK = LDV_STATE_MASK
379 lDV_CREATE_MASK :: StgWord
380 lDV_CREATE_MASK = LDV_CREATE_MASK
381 --lDV_LAST_MASK :: StgWord
382 --lDV_LAST_MASK = LDV_LAST_MASK
383 lDV_STATE_CREATE :: StgWord
384 lDV_STATE_CREATE = LDV_STATE_CREATE
385 lDV_STATE_USE :: StgWord
386 lDV_STATE_USE = LDV_STATE_USE
387