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