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