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