Pass DynFlags down to wordWidth
[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 :: DynFlags -> CmmType -- Type of a cost-centre stack
71 ccsType = bWord
72
73 ccType :: DynFlags -> 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 :: DynFlags
89 -> CmmExpr -- A closure pointer
90 -> CmmExpr -- The cost centre from that closure
91 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl oFFSET_StgHeader_ccs) (ccsType dflags)
92
93 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
94 -- The profiling header words in a static closure
95 -- Was SET_STATIC_PROF_HDR
96 staticProfHdr dflags ccs
97 = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
98
99 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
100 -- Profiling header words in a dynamic closure
101 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
102
103 initUpdFrameProf :: ByteOff -> FCode ()
104 -- Initialise the profiling field of an update frame
105 initUpdFrameProf frame_off
106 = ifProfiling $ -- frame->header.prof.ccs = CCCS
107 emitStore (CmmStackSlot Old (frame_off - oFFSET_StgHeader_ccs)) curCCS
108 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
109 -- is unnecessary because it is not used anyhow.
110
111 ---------------------------------------------------------------------------
112 -- Saving and restoring the current cost centre
113 ---------------------------------------------------------------------------
114
115 {- Note [Saving the current cost centre]
116 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
117 The current cost centre is like a global register. Like other
118 global registers, it's a caller-saves one. But consider
119 case (f x) of (p,q) -> rhs
120 Since 'f' may set the cost centre, we must restore it
121 before resuming rhs. So we want code like this:
122 local_cc = CCC -- save
123 r = f( x )
124 CCC = local_cc -- restore
125 That is, we explicitly "save" the current cost centre in
126 a LocalReg, local_cc; and restore it after the call. The
127 C-- infrastructure will arrange to save local_cc across the
128 call.
129
130 The same goes for join points;
131 let j x = join-stuff
132 in blah-blah
133 We want this kind of code:
134 local_cc = CCC -- save
135 blah-blah
136 J:
137 CCC = local_cc -- restore
138 -}
139
140 saveCurrentCostCentre :: FCode (Maybe LocalReg)
141 -- Returns Nothing if profiling is off
142 saveCurrentCostCentre
143 = do dflags <- getDynFlags
144 if not (dopt Opt_SccProfilingOn dflags)
145 then return Nothing
146 else do local_cc <- newTemp (ccType dflags)
147 emitAssign (CmmLocal local_cc) curCCS
148 return (Just local_cc)
149
150 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
151 restoreCurrentCostCentre Nothing
152 = return ()
153 restoreCurrentCostCentre (Just local_cc)
154 = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
155
156
157 -------------------------------------------------------------------------------
158 -- Recording allocation in a cost centre
159 -------------------------------------------------------------------------------
160
161 -- | Record the allocation of a closure. The CmmExpr is the cost
162 -- centre stack to which to attribute the allocation.
163 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
164 profDynAlloc rep ccs
165 = ifProfiling $
166 do dflags <- getDynFlags
167 profAlloc (mkIntExpr dflags (heapClosureSize dflags rep)) ccs
168
169 -- | Record the allocation of a closure (size is given by a CmmExpr)
170 -- The size must be in words, because the allocation counter in a CCS counts
171 -- in words.
172 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
173 profAlloc words ccs
174 = ifProfiling $
175 do dflags <- getDynFlags
176 emit (addToMemE alloc_rep
177 (cmmOffsetB dflags ccs oFFSET_CostCentreStack_mem_alloc)
178 (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
179 [CmmMachOp (mo_wordSub dflags) [words,
180 mkIntExpr dflags (profHdrSize dflags)]]))
181 -- subtract the "profiling overhead", which is the
182 -- profiling header in a closure.
183 where
184 alloc_rep = REP_CostCentreStack_mem_alloc
185
186 -- -----------------------------------------------------------------------
187 -- Setting the current cost centre on entry to a closure
188
189 enterCostCentreThunk :: CmmExpr -> FCode ()
190 enterCostCentreThunk closure =
191 ifProfiling $ do
192 dflags <- getDynFlags
193 emit $ storeCurCCS (costCentreFrom dflags closure)
194
195 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
196 enterCostCentreFun ccs closure =
197 ifProfiling $ do
198 if isCurrentCCS ccs
199 then do dflags <- getDynFlags
200 emitRtsCall rtsPackageId (fsLit "enterFunCCS")
201 [(CmmReg (CmmGlobal BaseReg), AddrHint),
202 (costCentreFrom dflags closure, AddrHint)] False
203 else return () -- top-level function, nothing to do
204
205 ifProfiling :: FCode () -> FCode ()
206 ifProfiling code
207 = do dflags <- getDynFlags
208 if dopt Opt_SccProfilingOn dflags
209 then code
210 else nopC
211
212 ifProfilingL :: DynFlags -> [a] -> [a]
213 ifProfilingL dflags xs
214 | dopt Opt_SccProfilingOn dflags = xs
215 | otherwise = []
216
217
218 ---------------------------------------------------------------
219 -- Initialising Cost Centres & CCSs
220 ---------------------------------------------------------------
221
222 initCostCentres :: CollectedCCs -> FCode ()
223 -- Emit the declarations
224 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
225 = do dflags <- getDynFlags
226 whenC (dopt Opt_SccProfilingOn dflags) $
227 do mapM_ emitCostCentreDecl local_CCs
228 mapM_ emitCostCentreStackDecl singleton_CCSs
229
230
231 emitCostCentreDecl :: CostCentre -> FCode ()
232 emitCostCentreDecl cc = do
233 { dflags <- getDynFlags
234 ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
235 | otherwise = zero dflags
236 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
237 ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
238 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
239 $ Module.moduleName
240 $ cc_mod cc)
241 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
242 showPpr dflags (costCentreSrcSpan cc)
243 -- XXX going via FastString to get UTF-8 encoding is silly
244 ; let
245 lits = [ zero dflags, -- StgInt ccID,
246 label, -- char *label,
247 modl, -- char *module,
248 loc, -- char *srcloc,
249 zero64, -- StgWord64 mem_alloc
250 zero dflags, -- StgWord time_ticks
251 is_caf, -- StgInt is_caf
252 zero dflags -- struct _CostCentre *link
253 ]
254 ; emitDataLits (mkCCLabel cc) lits
255 }
256
257 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
258 emitCostCentreStackDecl ccs
259 = case maybeSingletonCCS ccs of
260 Just cc ->
261 do dflags <- getDynFlags
262 let mk_lits cc = zero dflags :
263 mkCCostCentre cc :
264 replicate (sizeof_ccs_words - 2) (zero dflags)
265 -- Note: to avoid making any assumptions about how the
266 -- C compiler (that compiles the RTS, in particular) does
267 -- layouts of structs containing long-longs, simply
268 -- pad out the struct with zero words until we hit the
269 -- size of the overall struct (which we get via DerivedConstants.h)
270 emitDataLits (mkCCSLabel ccs) (mk_lits cc)
271 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
272
273 zero :: DynFlags -> CmmLit
274 zero dflags = mkIntCLit dflags 0
275 zero64 :: CmmLit
276 zero64 = CmmInt 0 W64
277
278 sizeof_ccs_words :: Int
279 sizeof_ccs_words
280 -- round up to the next word.
281 | ms == 0 = ws
282 | otherwise = ws + 1
283 where
284 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
285
286 -- ---------------------------------------------------------------------------
287 -- Set the current cost centre stack
288
289 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
290 emitSetCCC cc tick push
291 = do dflags <- getDynFlags
292 if not (dopt Opt_SccProfilingOn dflags)
293 then nopC
294 else do tmp <- newTemp (ccsType dflags) -- TODO FIXME NOW
295 pushCostCentre tmp curCCS cc
296 when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
297 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
298
299 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
300 pushCostCentre result ccs cc
301 = emitRtsCallWithResult result AddrHint
302 rtsPackageId
303 (fsLit "pushCostCentre") [(ccs,AddrHint),
304 (CmmLit (mkCCostCentre cc), AddrHint)]
305 False
306
307 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
308 bumpSccCount dflags ccs
309 = addToMem REP_CostCentreStack_scc_count
310 (cmmOffsetB dflags ccs oFFSET_CostCentreStack_scc_count) 1
311
312 -----------------------------------------------------------------------------
313 --
314 -- Lag/drag/void stuff
315 --
316 -----------------------------------------------------------------------------
317
318 --
319 -- Initial value for the LDV field in a static closure
320 --
321 staticLdvInit :: DynFlags -> CmmLit
322 staticLdvInit = zeroCLit
323
324 --
325 -- Initial value of the LDV field in a dynamic closure
326 --
327 dynLdvInit :: DynFlags -> CmmExpr
328 dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
329 CmmMachOp (mo_wordOr dflags) [
330 CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags lDV_SHIFT ],
331 CmmLit (mkWordCLit dflags lDV_STATE_CREATE)
332 ]
333
334 --
335 -- Initialise the LDV word of a new closure
336 --
337 ldvRecordCreate :: CmmExpr -> FCode ()
338 ldvRecordCreate closure = do dflags <- getDynFlags
339 emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
340
341 --
342 -- Called when a closure is entered, marks the closure as having been "used".
343 -- The closure is not an 'inherently used' one.
344 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
345 -- profiling.
346 --
347 ldvEnterClosure :: ClosureInfo -> FCode ()
348 ldvEnterClosure closure_info = do dflags <- getDynFlags
349 ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
350 where tag = funTag closure_info
351 -- don't forget to substract node's tag
352
353 ldvEnter :: CmmExpr -> FCode ()
354 -- Argument is a closure pointer
355 ldvEnter cl_ptr = do
356 dflags <- getDynFlags
357 let -- don't forget to substract node's tag
358 ldv_wd = ldvWord dflags cl_ptr
359 new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
360 (CmmLit (mkWordCLit dflags lDV_CREATE_MASK)))
361 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags lDV_STATE_USE)))
362 ifProfiling $
363 -- if (era > 0) {
364 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
365 -- era | LDV_STATE_USE }
366 emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
367 (mkStore ldv_wd new_ldv_wd)
368 mkNop
369
370 loadEra :: DynFlags -> CmmExpr
371 loadEra dflags = CmmMachOp (MO_UU_Conv cIntWidth (wordWidth dflags))
372 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
373
374 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
375 -- Takes the address of a closure, and returns
376 -- the address of the LDV word in the closure
377 ldvWord dflags closure_ptr = cmmOffsetB dflags closure_ptr oFFSET_StgHeader_ldvw
378
379 -- LDV constants, from ghc/includes/Constants.h
380 lDV_SHIFT :: Int
381 lDV_SHIFT = LDV_SHIFT
382 --lDV_STATE_MASK :: StgWord
383 --lDV_STATE_MASK = LDV_STATE_MASK
384 lDV_CREATE_MASK :: StgWord
385 lDV_CREATE_MASK = LDV_CREATE_MASK
386 --lDV_LAST_MASK :: StgWord
387 --lDV_LAST_MASK = LDV_LAST_MASK
388 lDV_STATE_CREATE :: StgWord
389 lDV_STATE_CREATE = LDV_STATE_CREATE
390 lDV_STATE_USE :: StgWord
391 lDV_STATE_USE = LDV_STATE_USE
392