Pass DynFlags down to showSDoc
[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, 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 StaticFlags
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 :: 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 (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 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 $ storeCurCCS (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 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
217 { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
218 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
219 $ Module.moduleName
220 $ cc_mod cc)
221 ; dflags <- getDynFlags
222 ; loc <- newStringCLit (showPpr dflags (costCentreSrcSpan cc))
223 -- XXX should UTF-8 encode
224 -- All cost centres will be in the main package, since we
225 -- don't normally use -auto-all or add SCCs to other packages.
226 -- Hence don't emit the package name in the module here.
227 ; let lits = [ zero, -- StgInt ccID,
228 label, -- char *label,
229 modl, -- char *module,
230 loc, -- char *srcloc,
231 zero64, -- StgWord64 mem_alloc
232 zero, -- StgWord time_ticks
233 is_caf, -- StgInt is_caf
234 zero -- struct _CostCentre *link
235 ]
236 ; emitDataLits (mkCCLabel cc) lits
237 }
238 where
239 is_caf | isCafCC cc = mkIntCLit (ord 'c') -- 'c' == is a CAF
240 | otherwise = zero
241
242 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
243 emitCostCentreStackDecl ccs
244 = case maybeSingletonCCS ccs of
245 Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
246 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
247 where
248 mk_lits cc = zero :
249 mkCCostCentre cc :
250 replicate (sizeof_ccs_words - 2) zero
251 -- Note: to avoid making any assumptions about how the
252 -- C compiler (that compiles the RTS, in particular) does
253 -- layouts of structs containing long-longs, simply
254 -- pad out the struct with zero words until we hit the
255 -- size of the overall struct (which we get via DerivedConstants.h)
256
257 zero :: CmmLit
258 zero = mkIntCLit 0
259 zero64 :: CmmLit
260 zero64 = CmmInt 0 W64
261
262 sizeof_ccs_words :: Int
263 sizeof_ccs_words
264 -- round up to the next word.
265 | ms == 0 = ws
266 | otherwise = ws + 1
267 where
268 (ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
269
270 -- ---------------------------------------------------------------------------
271 -- Set the current cost centre stack
272
273 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
274 emitSetCCC cc tick push
275 | not opt_SccProfilingOn = nopC
276 | otherwise = do
277 tmp <- newTemp ccsType -- TODO FIXME NOW
278 pushCostCentre tmp curCCS cc
279 when tick $ emit (bumpSccCount (CmmReg (CmmLocal tmp)))
280 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
281
282 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
283 pushCostCentre result ccs cc
284 = emitRtsCallWithResult result AddrHint
285 rtsPackageId
286 (fsLit "PushCostCentre") [(ccs,AddrHint),
287 (CmmLit (mkCCostCentre cc), AddrHint)]
288 False
289
290 bumpSccCount :: CmmExpr -> CmmAGraph
291 bumpSccCount ccs
292 = addToMem REP_CostCentreStack_scc_count
293 (cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
294
295 -----------------------------------------------------------------------------
296 --
297 -- Lag/drag/void stuff
298 --
299 -----------------------------------------------------------------------------
300
301 --
302 -- Initial value for the LDV field in a static closure
303 --
304 staticLdvInit :: CmmLit
305 staticLdvInit = zeroCLit
306
307 --
308 -- Initial value of the LDV field in a dynamic closure
309 --
310 dynLdvInit :: CmmExpr
311 dynLdvInit = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
312 CmmMachOp mo_wordOr [
313 CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
314 CmmLit (mkWordCLit lDV_STATE_CREATE)
315 ]
316
317 --
318 -- Initialise the LDV word of a new closure
319 --
320 ldvRecordCreate :: CmmExpr -> FCode ()
321 ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
322
323 --
324 -- Called when a closure is entered, marks the closure as having been "used".
325 -- The closure is not an 'inherently used' one.
326 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
327 -- profiling.
328 --
329 ldvEnterClosure :: ClosureInfo -> FCode ()
330 ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (-tag))
331 where tag = funTag closure_info
332 -- don't forget to substract node's tag
333
334 ldvEnter :: CmmExpr -> FCode ()
335 -- Argument is a closure pointer
336 ldvEnter cl_ptr
337 = ifProfiling $
338 -- if (era > 0) {
339 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
340 -- era | LDV_STATE_USE }
341 emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
342 (mkStore ldv_wd new_ldv_wd)
343 mkNop)
344 where
345 -- don't forget to substract node's tag
346 ldv_wd = ldvWord cl_ptr
347 new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
348 (CmmLit (mkWordCLit lDV_CREATE_MASK)))
349 (cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
350
351 loadEra :: CmmExpr
352 loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
353 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
354
355 ldvWord :: CmmExpr -> CmmExpr
356 -- Takes the address of a closure, and returns
357 -- the address of the LDV word in the closure
358 ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
359
360 -- LDV constants, from ghc/includes/Constants.h
361 lDV_SHIFT :: Int
362 lDV_SHIFT = LDV_SHIFT
363 --lDV_STATE_MASK :: StgWord
364 --lDV_STATE_MASK = LDV_STATE_MASK
365 lDV_CREATE_MASK :: StgWord
366 lDV_CREATE_MASK = LDV_CREATE_MASK
367 --lDV_LAST_MASK :: StgWord
368 --lDV_LAST_MASK = LDV_LAST_MASK
369 lDV_STATE_CREATE :: StgWord
370 lDV_STATE_CREATE = LDV_STATE_CREATE
371 lDV_STATE_USE :: StgWord
372 lDV_STATE_USE = LDV_STATE_USE
373