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