c124b5f68acea00476b5b976658cf48e0b2f0393
[ghc.git] / compiler / codeGen / CgProf.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module CgProf (
10 mkCCostCentre, mkCCostCentreStack,
11
12 -- Cost-centre Profiling
13 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
14 enterCostCentreThunk,
15 enterCostCentreFun,
16 costCentreFrom,
17 curCCS, storeCurCCS,
18 emitCostCentreDecl, emitCostCentreStackDecl,
19 emitSetCCC,
20
21 -- Lag/drag/void stuff
22 ldvEnter, ldvEnterClosure, ldvRecordCreate
23 ) where
24
25 #include "HsVersions.h"
26
27 import ClosureInfo
28 import CgUtils
29 import CgMonad
30 import SMRep
31
32 import OldCmm
33 import OldCmmUtils
34 import CLabel
35
36 import qualified Module
37 import CostCentre
38 import DynFlags
39 import FastString
40 import Module
41 import Outputable
42
43 import Data.Char
44 import Control.Monad
45
46 -----------------------------------------------------------------------------
47 --
48 -- Cost-centre-stack Profiling
49 --
50 -----------------------------------------------------------------------------
51
52 -- Expression representing the current cost centre stack
53 curCCS :: CmmExpr
54 curCCS = CmmReg (CmmGlobal CCCS)
55
56 storeCurCCS :: CmmExpr -> CmmStmt
57 storeCurCCS e = CmmAssign (CmmGlobal CCCS) e
58
59 mkCCostCentre :: CostCentre -> CmmLit
60 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
61
62 mkCCostCentreStack :: CostCentreStack -> CmmLit
63 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
64
65 costCentreFrom :: DynFlags
66 -> CmmExpr -- A closure pointer
67 -> CmmExpr -- The cost centre from that closure
68 costCentreFrom dflags cl
69 = CmmLoad (cmmOffsetB dflags cl (oFFSET_StgHeader_ccs dflags)) (bWord dflags)
70
71 staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
72 -- The profiling header words in a static closure
73 -- Was SET_STATIC_PROF_HDR
74 staticProfHdr dflags ccs = ifProfilingL dflags [mkCCostCentreStack ccs,
75 staticLdvInit dflags]
76
77 dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
78 -- Profiling header words in a dynamic closure
79 dynProfHdr dflags ccs = ifProfilingL dflags [ccs, dynLdvInit dflags]
80
81 initUpdFrameProf :: CmmExpr -> Code
82 -- Initialise the profiling field of an update frame
83 initUpdFrameProf frame_amode
84 = ifProfiling $ -- frame->header.prof.ccs = CCCS
85 do dflags <- getDynFlags
86 stmtC (CmmStore (cmmOffsetB dflags frame_amode (oFFSET_StgHeader_ccs dflags)) curCCS)
87 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
88 -- is unnecessary because it is not used anyhow.
89
90 -- -----------------------------------------------------------------------------
91 -- Recording allocation in a cost centre
92
93 -- | Record the allocation of a closure. The CmmExpr is the cost
94 -- centre stack to which to attribute the allocation.
95 profDynAlloc :: ClosureInfo -> CmmExpr -> Code
96 profDynAlloc cl_info ccs
97 = ifProfiling $
98 do dflags <- getDynFlags
99 profAlloc (mkIntExpr dflags (closureSize dflags cl_info)) ccs
100
101 -- | Record the allocation of a closure (size is given by a CmmExpr)
102 -- The size must be in words, because the allocation counter in a CCS counts
103 -- in words.
104 --
105 -- This API is used by the @CCS_ALLOC()@ macro in @.cmm@ code.
106 --
107 profAlloc :: CmmExpr -> CmmExpr -> Code
108 profAlloc words ccs
109 = ifProfiling $
110 do dflags <- getDynFlags
111 let alloc_rep = typeWidth (rEP_CostCentreStack_mem_alloc dflags)
112 stmtC (addToMemE alloc_rep
113 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_mem_alloc dflags))
114 (CmmMachOp (MO_UU_Conv (wordWidth dflags) alloc_rep) $
115 [CmmMachOp (mo_wordSub dflags) [words,
116 mkIntExpr dflags (profHdrSize dflags)]]))
117 -- subtract the "profiling overhead", which is the
118 -- profiling header in a closure.
119
120 -- -----------------------------------------------------------------------
121 -- Setting the current cost centre on entry to a closure
122
123 enterCostCentreThunk :: CmmExpr -> Code
124 enterCostCentreThunk closure =
125 ifProfiling $ do
126 dflags <- getDynFlags
127 stmtC $ storeCurCCS (costCentreFrom dflags closure)
128
129 enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code
130 enterCostCentreFun ccs closure vols =
131 ifProfiling $ do
132 if isCurrentCCS ccs
133 then do dflags <- getDynFlags
134 emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS")
135 [CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
136 CmmHinted (costCentreFrom dflags closure) AddrHint] vols
137 else return () -- top-level function, nothing to do
138
139 ifProfiling :: Code -> Code
140 ifProfiling code
141 = do dflags <- getDynFlags
142 if dopt Opt_SccProfilingOn dflags then code else nopC
143
144 ifProfilingL :: DynFlags -> [a] -> [a]
145 ifProfilingL dflags xs
146 | dopt Opt_SccProfilingOn dflags = xs
147 | otherwise = []
148
149 -- ---------------------------------------------------------------------------
150 -- Initialising Cost Centres & CCSs
151
152 emitCostCentreDecl
153 :: CostCentre
154 -> Code
155 emitCostCentreDecl cc = do
156 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
157 { label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
158 ; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
159 $ Module.moduleName
160 $ cc_mod cc)
161 -- All cost centres will be in the main package, since we
162 -- don't normally use -auto-all or add SCCs to other packages.
163 -- Hence don't emit the package name in the module here.
164 ; dflags <- getDynFlags
165 ; loc <- newByteStringCLit $ bytesFS $ mkFastString $
166 showPpr dflags (costCentreSrcSpan cc)
167 -- XXX going via FastString to get UTF-8 encoding is silly
168 ; let
169 is_caf | isCafCC cc = mkIntCLit dflags (ord 'c') -- 'c' == is a CAF
170 | otherwise = zero dflags
171 lits = [ zero dflags, -- StgInt ccID,
172 label, -- char *label,
173 modl, -- char *module,
174 loc, -- char *srcloc,
175 zero64, -- StgWord64 mem_alloc
176 zero dflags, -- StgWord time_ticks
177 is_caf, -- StgInt is_caf
178 zero dflags -- struct _CostCentre *link
179 ]
180 ; emitDataLits (mkCCLabel cc) lits
181 }
182
183
184 emitCostCentreStackDecl
185 :: CostCentreStack
186 -> Code
187 emitCostCentreStackDecl ccs
188 | Just cc <- maybeSingletonCCS ccs = do
189 { dflags <- getDynFlags
190 ; let
191 -- Note: to avoid making any assumptions about how the
192 -- C compiler (that compiles the RTS, in particular) does
193 -- layouts of structs containing long-longs, simply
194 -- pad out the struct with zero words until we hit the
195 -- size of the overall struct (which we get via DerivedConstants.h)
196 --
197 lits = zero dflags
198 : mkCCostCentre cc
199 : replicate (sizeof_ccs_words dflags - 2) (zero dflags)
200 ; emitDataLits (mkCCSLabel ccs) lits
201 }
202 | otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
203
204 zero :: DynFlags -> CmmLit
205 zero dflags = mkIntCLit dflags 0
206 zero64 :: CmmLit
207 zero64 = CmmInt 0 W64
208
209 sizeof_ccs_words :: DynFlags -> Int
210 sizeof_ccs_words dflags
211 -- round up to the next word.
212 | ms == 0 = ws
213 | otherwise = ws + 1
214 where
215 (ws,ms) = sIZEOF_CostCentreStack dflags `divMod` wORD_SIZE dflags
216
217 -- ---------------------------------------------------------------------------
218 -- Set the current cost centre stack
219
220 emitSetCCC :: CostCentre -> Bool -> Bool -> Code
221 emitSetCCC cc tick push
222 = do dflags <- getDynFlags
223 if dopt Opt_SccProfilingOn dflags
224 then do tmp <- newTemp (bWord dflags) -- TODO FIXME NOW
225 pushCostCentre tmp curCCS cc
226 when tick $ stmtC (bumpSccCount dflags (CmmReg (CmmLocal tmp)))
227 when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
228 else nopC
229
230 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
231 pushCostCentre result ccs cc
232 = emitRtsCallWithResult result AddrHint
233 rtsPackageId
234 (fsLit "pushCostCentre") [CmmHinted ccs AddrHint,
235 CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
236
237 bumpSccCount :: DynFlags -> CmmExpr -> CmmStmt
238 bumpSccCount dflags ccs
239 = addToMem (typeWidth (rEP_CostCentreStack_scc_count dflags))
240 (cmmOffsetB dflags ccs (oFFSET_CostCentreStack_scc_count dflags)) 1
241
242 -----------------------------------------------------------------------------
243 --
244 -- Lag/drag/void stuff
245 --
246 -----------------------------------------------------------------------------
247
248 --
249 -- Initial value for the LDV field in a static closure
250 --
251 staticLdvInit :: DynFlags -> CmmLit
252 staticLdvInit = zeroCLit
253
254 --
255 -- Initial value of the LDV field in a dynamic closure
256 --
257 dynLdvInit :: DynFlags -> CmmExpr
258 dynLdvInit dflags = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
259 CmmMachOp (mo_wordOr dflags) [
260 CmmMachOp (mo_wordShl dflags) [loadEra dflags, mkIntExpr dflags (lDV_SHIFT dflags)],
261 CmmLit (mkWordCLit dflags (lDV_STATE_CREATE dflags))
262 ]
263
264 --
265 -- Initialise the LDV word of a new closure
266 --
267 ldvRecordCreate :: CmmExpr -> Code
268 ldvRecordCreate closure = do dflags <- getDynFlags
269 stmtC $ CmmStore (ldvWord dflags closure) (dynLdvInit dflags)
270
271 --
272 -- Called when a closure is entered, marks the closure as having been "used".
273 -- The closure is not an 'inherently used' one.
274 -- The closure is not IND or IND_OLDGEN because neither is considered for LDV
275 -- profiling.
276 --
277 ldvEnterClosure :: ClosureInfo -> Code
278 ldvEnterClosure closure_info
279 = do dflags <- getDynFlags
280 let tag = funTag dflags closure_info
281 ldvEnter (cmmOffsetB dflags (CmmReg nodeReg) (-tag))
282 -- don't forget to substract node's tag
283
284 ldvEnter :: CmmExpr -> Code
285 -- Argument is a closure pointer
286 ldvEnter cl_ptr = do
287 dflags <- getDynFlags
288 let
289 -- don't forget to substract node's tag
290 ldv_wd = ldvWord dflags cl_ptr
291 new_ldv_wd = cmmOrWord dflags (cmmAndWord dflags (CmmLoad ldv_wd (bWord dflags))
292 (CmmLit (mkWordCLit dflags (lDV_CREATE_MASK dflags))))
293 (cmmOrWord dflags (loadEra dflags) (CmmLit (mkWordCLit dflags (lDV_STATE_USE dflags))))
294 ifProfiling $
295 -- if (era > 0) {
296 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
297 -- era | LDV_STATE_USE }
298 emitIf (CmmMachOp (mo_wordUGt dflags) [loadEra dflags, CmmLit (zeroCLit dflags)])
299 (stmtC (CmmStore ldv_wd new_ldv_wd))
300
301 loadEra :: DynFlags -> CmmExpr
302 loadEra dflags = CmmMachOp (MO_UU_Conv (cIntWidth dflags) (wordWidth dflags))
303 [CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId $ fsLit("era"))) (cInt dflags)]
304
305 ldvWord :: DynFlags -> CmmExpr -> CmmExpr
306 -- Takes the address of a closure, and returns
307 -- the address of the LDV word in the closure
308 ldvWord dflags closure_ptr
309 = cmmOffsetB dflags closure_ptr (oFFSET_StgHeader_ldvw dflags)
310
311 lDV_CREATE_MASK :: DynFlags -> StgWord
312 lDV_CREATE_MASK dflags = toStgWord dflags (iLDV_CREATE_MASK dflags)
313 lDV_STATE_CREATE :: DynFlags -> StgWord
314 lDV_STATE_CREATE dflags = toStgWord dflags (iLDV_STATE_CREATE dflags)
315 lDV_STATE_USE :: DynFlags -> StgWord
316 lDV_STATE_USE dflags = toStgWord dflags (iLDV_STATE_USE dflags)
317