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