Generalize CmmUnwind and pass unwind information through NCG
[ghc.git] / compiler / codeGen / StgCmmProf.hs
1 {-# LANGUAGE CPP #-}
2
3 -----------------------------------------------------------------------------
4 --
5 -- Code generation for profiling
6 --
7 -- (c) The University of Glasgow 2004-2006
8 --
9 -----------------------------------------------------------------------------
10
11 module StgCmmProf (
12 initCostCentres, ccType, ccsType,
13 mkCCostCentre, mkCCostCentreStack,
14
15 -- Cost-centre Profiling
16 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
17 enterCostCentreThunk, enterCostCentreFun,
18 costCentreFrom,
19 curCCS, storeCurCCS,
20 emitSetCCC,
21
22 saveCurrentCostCentre, restoreCurrentCostCentre,
23
24 -- Lag/drag/void stuff
25 ldvEnter, ldvEnterClosure, ldvRecordCreate
26 ) where
27
28 #include "HsVersions.h"
29
30 import StgCmmClosure
31 import StgCmmUtils
32 import StgCmmMonad
33 import SMRep
34
35 import MkGraph
36 import Cmm
37 import CmmUtils
38 import CLabel
39
40 import qualified Module
41 import CostCentre
42 import DynFlags
43 import FastString
44 import Module
45 import Outputable
46
47 import Control.Monad
48 import Data.Char (ord)
49
50 -----------------------------------------------------------------------------
51 --
52 -- Cost-centre-stack Profiling
53 --
54 -----------------------------------------------------------------------------
55
56 -- Expression representing the current cost centre stack
57 ccsType :: DynFlags -> CmmType -- Type of a cost-centre stack
58 ccsType = bWord
59
60 ccType :: DynFlags -> CmmType -- Type of a cost centre
61 ccType = bWord
62
63 curCCS :: CmmExpr
64 curCCS = CmmReg (CmmGlobal CCCS)
65
66 storeCurCCS :: CmmExpr -> CmmAGraph
67 storeCurCCS e = mkAssign (CmmGlobal CCCS) e
68
69 mkCCostCentre :: CostCentre -> CmmLit
70 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
71
72 mkCCostCentreStack :: CostCentreStack -> CmmLit
73 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
74
75 costCentreFrom :: DynFlags
76 -> CmmExpr -- A closure pointer
77 -> CmmExpr -- The cost centre from that closure
78 costCentreFrom dflags cl = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (ccsType dflags)
79
80 -- | The profiling header words in a static closure
81 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
82 staticProfHdr dflags ccs
83 = ifProfilingL dflags [mkCCostCentreStack ccs, staticLdvInit dflags]
84
85 -- | Profiling header words in a dynamic closure
86 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
87 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
88
89 -- | Initialise the profiling field of an update frame
90 initUpdFrameProf :: CmmExpr -> FCode ()
91 initUpdFrameProf frame
92 = ifProfiling $ -- frame->header.prof.ccs = CCCS
93 do dflags <- getDynFlags
94 emitStore (cmmOffset dflags frame (oFFSET_StgHeader_ccs dflags)) curCCS
95 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
96 -- is unnecessary because it is not used anyhow.
97
98 ---------------------------------------------------------------------------
99 -- Saving and restoring the current cost centre
100 ---------------------------------------------------------------------------
101
102 {- Note [Saving the current cost centre]
103 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
104 The current cost centre is like a global register. Like other
105 global registers, it's a caller-saves one. But consider
106 case (f x) of (p,q) -> rhs
107 Since 'f' may set the cost centre, we must restore it
108 before resuming rhs. So we want code like this:
109 local_cc = CCC -- save
110 r = f( x )
111 CCC = local_cc -- restore
112 That is, we explicitly "save" the current cost centre in
113 a LocalReg, local_cc; and restore it after the call. The
114 C-- infrastructure will arrange to save local_cc across the
115 call.
116
117 The same goes for join points;
118 let j x = join-stuff
119 in blah-blah
120 We want this kind of code:
121 local_cc = CCC -- save
122 blah-blah
123 J:
124 CCC = local_cc -- restore
125 -}
126
127 saveCurrentCostCentre :: FCode (Maybe LocalReg)
128 -- Returns Nothing if profiling is off
129 saveCurrentCostCentre
130 = do dflags <- getDynFlags
131 if not (gopt Opt_SccProfilingOn dflags)
132 then return Nothing
133 else do local_cc <- newTemp (ccType dflags)
134 emitAssign (CmmLocal local_cc) curCCS
135 return (Just local_cc)
136
137 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
138 restoreCurrentCostCentre Nothing
139 = return ()
140 restoreCurrentCostCentre (Just local_cc)
141 = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
142
143
144 -------------------------------------------------------------------------------
145 -- Recording allocation in a cost centre
146 -------------------------------------------------------------------------------
147
148 -- | Record the allocation of a closure. The CmmExpr is the cost
149 -- centre stack to which to attribute the allocation.
150 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
151 profDynAlloc rep ccs
152 = ifProfiling $
153 do dflags <- getDynFlags
154 profAlloc (mkIntExpr dflags (heapClosureSizeW dflags rep)) ccs
155
156 -- | Record the allocation of a closure (size is given by a CmmExpr)
157 -- The size must be in words, because the allocation counter in a CCS counts
158 -- in words.
159 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
160 profAlloc words ccs
161 = ifProfiling $
162 do dflags <- getDynFlags
163 let alloc_rep = rEP_CostCentreStack_mem_alloc dflags
164 emit (addToMemE alloc_rep
165 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
166 (CmmMachOp (MO_UU_Conv (wordWidth dflags) (typeWidth alloc_rep)) $
167 [CmmMachOp (mo_wordSub dflags) [words,
168 mkIntExpr dflags (profHdrSize dflags)]]))
169 -- subtract the "profiling overhead", which is the
170 -- profiling header in a closure.
171
172 -- -----------------------------------------------------------------------
173 -- Setting the current cost centre on entry to a closure
174
175 enterCostCentreThunk :: CmmExpr -> FCode ()
176 enterCostCentreThunk closure =
177 ifProfiling $ do
178 dflags <- getDynFlags
179 emit $ storeCurCCS (costCentreFrom dflags closure)
180
181 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
182 enterCostCentreFun ccs closure =
183 ifProfiling $ do
184 if isCurrentCCS ccs
185 then do dflags <- getDynFlags
186 emitRtsCall rtsUnitId (fsLit "enterFunCCS")
187 [(CmmReg (CmmGlobal BaseReg), AddrHint),
188 (costCentreFrom dflags closure, AddrHint)] False
189 else return () -- top-level function, nothing to do
190
191 ifProfiling :: FCode () -> FCode ()
192 ifProfiling code
193 = do dflags <- getDynFlags
194 if gopt Opt_SccProfilingOn dflags
195 then code
196 else return ()
197
198 ifProfilingL :: DynFlags -> [a] -> [a]
199 ifProfilingL dflags xs
200 | gopt Opt_SccProfilingOn dflags = xs
201 | otherwise = []
202
203
204 ---------------------------------------------------------------
205 -- Initialising Cost Centres & CCSs
206 ---------------------------------------------------------------
207
208 initCostCentres :: CollectedCCs -> FCode ()
209 -- Emit the declarations
210 initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
211 = do dflags <- getDynFlags
212 when (gopt Opt_SccProfilingOn dflags) $
213 do mapM_ emitCostCentreDecl local_CCs
214 mapM_ emitCostCentreStackDecl singleton_CCSs
215
216
217 emitCostCentreDecl :: CostCentre -> FCode ()
218 emitCostCentreDecl cc = do
219 { dflags <- getDynFlags
220 ; let is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
221 | otherwise = zero dflags
222 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
223 ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
224 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
225 $ Module.moduleName
226 $ cc_mod cc)
227 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
228 showPpr dflags (costCentreSrcSpan cc)
229 -- XXX going via FastString to get UTF-8 encoding is silly
230 ; let
231 lits = [ zero dflags, -- StgInt ccID,
232 label, -- char *label,
233 modl, -- char *module,
234 loc, -- char *srcloc,
235 zero64, -- StgWord64 mem_alloc
236 zero dflags, -- StgWord time_ticks
237 is_caf, -- StgInt is_caf
238 zero dflags -- struct _CostCentre *link
239 ]
240 ; emitDataLits (mkCCLabel cc) lits
241 }
242
243 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
244 emitCostCentreStackDecl ccs
245 = case maybeSingletonCCS ccs of
246 Just cc ->
247 do dflags <- getDynFlags
248 let mk_lits cc = zero dflags :
249 mkCCostCentre cc :
250 replicate (sizeof_ccs_words dflags - 2) (zero dflags)
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 emitDataLits (mkCCSLabel ccs) (mk_lits cc)
257 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
258
259 zero :: DynFlags -> CmmLit
260 zero dflags = mkIntCLit dflags 0
261 zero64 :: CmmLit
262 zero64 = CmmInt 0 W64
263
264 sizeof_ccs_words :: DynFlags -> Int
265 sizeof_ccs_words dflags
266 -- round up to the next word.
267 | ms == 0 = ws
268 | otherwise = ws + 1
269 where
270 (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
271
272 -- ---------------------------------------------------------------------------
273 -- Set the current cost centre stack
274
275 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
276 emitSetCCC cc tick push
277 = do dflags <- getDynFlags
278 if not (gopt Opt_SccProfilingOn dflags)
279 then return ()
280 else do tmp <- newTemp (ccsType dflags)
281 pushCostCentre tmp curCCS cc
282 when tick $ emit (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
283 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
284
285 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
286 pushCostCentre result ccs cc
287 = emitRtsCallWithResult result AddrHint
288 rtsUnitId
289 (fsLit "pushCostCentre") [(ccs,AddrHint),
290 (CmmLit (mkCCostCentre cc), AddrHint)]
291 False
292
293 bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
294 bumpSccCount dflags ccs
295 = addToMem (rEP_CostCentreStack_scc_count dflags)
296 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
297
298 -----------------------------------------------------------------------------
299 --
300 -- Lag/drag/void stuff
301 --
302 -----------------------------------------------------------------------------
303
304 --
305 -- Initial value for the LDV field in a static closure
306 --
307 staticLdvInit :: DynFlags -> CmmLit
308 staticLdvInit = zeroCLit
309
310 --
311 -- Initial value of the LDV field in a dynamic closure
312 --
313 dynLdvInit :: DynFlags -> CmmExpr
314 dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
315 CmmMachOp (mo_wordOr dflags) [
316 CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
317 CmmLit (mkWordCLit dflags (iLDV_STATE_CREATE dflags))
318 ]
319
320 --
321 -- Initialise the LDV word of a new closure
322 --
323 ldvRecordCreate :: CmmExpr -> FCode ()
324 ldvRecordCreate closure = do
325 dflags <- getDynFlags
326 emit $ mkStore (ldvWord dflags closure) (dynLdvInit dflags)
327
328 --
329 -- | Called when a closure is entered, marks the closure as having
330 -- been "used". The closure is not an "inherently used" one. The
331 -- closure is not @IND@ because that is not considered for LDV profiling.
332 --
333 ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
334 ldvEnterClosure closure_info node_reg = do
335 dflags <- getDynFlags
336 let tag = funTag dflags closure_info
337 -- don't forget to substract node's tag
338 ldvEnter (cmmOffsetB dflags (CmmReg node_reg) (-tag))
339
340 ldvEnter :: CmmExpr -> FCode ()
341 -- Argument is a closure pointer
342 ldvEnter cl_ptr = do
343 dflags <- getDynFlags
344 let -- don't forget to substract node's tag
345 ldv_wd = ldvWord dflags cl_ptr
346 new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
347 (CmmLit (mkWordCLit dflags (iLDV_CREATE_MASK dflags))))
348 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (iLDV_STATE_USE dflags))))
349 ifProfiling $
350 -- if (era > 0) {
351 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
352 -- era | LDV_STATE_USE }
353 emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
354 (mkStore ldv_wd new_ldv_wd)
355 mkNop
356
357 loadEra :: DynFlags -> CmmExpr
358 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
359 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "era")))
360 (cInt dflags)]
361
362 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
363 -- Takes the address of a closure, and returns
364 -- the address of the LDV word in the closure
365 ldvWord dflags closure_ptr
366 = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)