never executed always true always false
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 module GHC.StgToCmm.Prof (
10 initCostCentres, ccType, ccsType,
11 mkCCostCentre, mkCCostCentreStack,
12
13 -- infoTablePRov
14 initInfoTableProv, emitInfoTableProv,
15
16 -- Cost-centre Profiling
17 dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
18 enterCostCentreThunk, enterCostCentreFun,
19 costCentreFrom,
20 storeCurCCS,
21 emitSetCCC,
22
23 saveCurrentCostCentre, restoreCurrentCostCentre,
24
25 -- Lag/drag/void stuff
26 ldvEnter, ldvEnterClosure, ldvRecordCreate
27 ) where
28
29 import GHC.Prelude
30
31 import GHC.Driver.Session
32 import GHC.Driver.Ppr
33
34 import GHC.Platform
35 import GHC.Platform.Profile
36 import GHC.StgToCmm.Closure
37 import GHC.StgToCmm.Utils
38 import GHC.StgToCmm.Monad
39 import GHC.StgToCmm.Lit
40 import GHC.Runtime.Heap.Layout
41
42 import GHC.Cmm.Graph
43 import GHC.Cmm
44 import GHC.Cmm.Utils
45 import GHC.Cmm.CLabel
46
47 import GHC.Types.CostCentre
48 import GHC.Types.IPE
49 import GHC.Types.ForeignStubs
50 import GHC.Data.FastString
51 import GHC.Unit.Module as Module
52 import GHC.Utils.Outputable
53 import GHC.Utils.Panic
54 import GHC.Driver.CodeOutput ( ipInitCode )
55
56 import GHC.Utils.Encoding
57
58 import Control.Monad
59 import Data.Char (ord)
60
61 -----------------------------------------------------------------------------
62 --
63 -- Cost-centre-stack Profiling
64 --
65 -----------------------------------------------------------------------------
66
67 -- Expression representing the current cost centre stack
68 ccsType :: Platform -> CmmType -- Type of a cost-centre stack
69 ccsType = bWord
70
71 ccType :: Platform -> CmmType -- Type of a cost centre
72 ccType = bWord
73
74 storeCurCCS :: CmmExpr -> CmmAGraph
75 storeCurCCS e = mkAssign cccsReg e
76
77 mkCCostCentre :: CostCentre -> CmmLit
78 mkCCostCentre cc = CmmLabel (mkCCLabel cc)
79
80 mkCCostCentreStack :: CostCentreStack -> CmmLit
81 mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
82
83 costCentreFrom :: Platform
84 -> CmmExpr -- A closure pointer
85 -> CmmExpr -- The cost centre from that closure
86 costCentreFrom platform cl = CmmLoad (cmmOffsetB platform cl (pc_OFFSET_StgHeader_ccs (platformConstants platform))) (ccsType platform)
87
88 -- | The profiling header words in a static closure
89 staticProfHdr :: Profile -> CostCentreStack -> [CmmLit]
90 staticProfHdr profile ccs
91 | profileIsProfiling profile = [mkCCostCentreStack ccs, staticLdvInit platform]
92 | otherwise = []
93 where platform = profilePlatform profile
94
95 -- | Profiling header words in a dynamic closure
96 dynProfHdr :: Profile -> CmmExpr -> [CmmExpr]
97 dynProfHdr profile ccs
98 | profileIsProfiling profile = [ccs, dynLdvInit (profilePlatform profile)]
99 | otherwise = []
100
101 -- | Initialise the profiling field of an update frame
102 initUpdFrameProf :: CmmExpr -> FCode ()
103 initUpdFrameProf frame
104 = ifProfiling $ -- frame->header.prof.ccs = CCCS
105 do platform <- getPlatform
106 emitStore (cmmOffset platform frame (pc_OFFSET_StgHeader_ccs (platformConstants platform))) cccsExpr
107 -- frame->header.prof.hp.rs = NULL (or frame-header.prof.hp.ldvw = 0)
108 -- is unnecessary because it is not used anyhow.
109
110 ---------------------------------------------------------------------------
111 -- Saving and restoring the current cost centre
112 ---------------------------------------------------------------------------
113
114 {- Note [Saving the current cost centre]
115 ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
116 The current cost centre is like a global register. Like other
117 global registers, it's a caller-saves one. But consider
118 case (f x) of (p,q) -> rhs
119 Since 'f' may set the cost centre, we must restore it
120 before resuming rhs. So we want code like this:
121 local_cc = CCC -- save
122 r = f( x )
123 CCC = local_cc -- restore
124 That is, we explicitly "save" the current cost centre in
125 a LocalReg, local_cc; and restore it after the call. The
126 C-- infrastructure will arrange to save local_cc across the
127 call.
128
129 The same goes for join points;
130 let j x = join-stuff
131 in blah-blah
132 We want this kind of code:
133 local_cc = CCC -- save
134 blah-blah
135 J:
136 CCC = local_cc -- restore
137 -}
138
139 saveCurrentCostCentre :: FCode (Maybe LocalReg)
140 -- Returns Nothing if profiling is off
141 saveCurrentCostCentre
142 = do dflags <- getDynFlags
143 platform <- getPlatform
144 if not (sccProfilingEnabled dflags)
145 then return Nothing
146 else do local_cc <- newTemp (ccType platform)
147 emitAssign (CmmLocal local_cc) cccsExpr
148 return (Just local_cc)
149
150 restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
151 restoreCurrentCostCentre Nothing
152 = return ()
153 restoreCurrentCostCentre (Just local_cc)
154 = emit (storeCurCCS (CmmReg (CmmLocal local_cc)))
155
156
157 -------------------------------------------------------------------------------
158 -- Recording allocation in a cost centre
159 -------------------------------------------------------------------------------
160
161 -- | Record the allocation of a closure. The CmmExpr is the cost
162 -- centre stack to which to attribute the allocation.
163 profDynAlloc :: SMRep -> CmmExpr -> FCode ()
164 profDynAlloc rep ccs
165 = ifProfiling $
166 do profile <- targetProfile <$> getDynFlags
167 let platform = profilePlatform profile
168 profAlloc (mkIntExpr platform (heapClosureSizeW profile rep)) ccs
169
170 -- | Record the allocation of a closure (size is given by a CmmExpr)
171 -- The size must be in words, because the allocation counter in a CCS counts
172 -- in words.
173 profAlloc :: CmmExpr -> CmmExpr -> FCode ()
174 profAlloc words ccs
175 = ifProfiling $
176 do profile <- targetProfile <$> getDynFlags
177 let platform = profilePlatform profile
178 let alloc_rep = rEP_CostCentreStack_mem_alloc platform
179 emit $ addToMemE alloc_rep
180 (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_mem_alloc (platformConstants platform)))
181 (CmmMachOp (MO_UU_Conv (wordWidth platform) (typeWidth alloc_rep)) $
182 -- subtract the "profiling overhead", which is the
183 -- profiling header in a closure.
184 [CmmMachOp (mo_wordSub platform) [ words, mkIntExpr platform (profHdrSize profile)]]
185 )
186
187 -- -----------------------------------------------------------------------
188 -- Setting the current cost centre on entry to a closure
189
190 enterCostCentreThunk :: CmmExpr -> FCode ()
191 enterCostCentreThunk closure =
192 ifProfiling $ do
193 platform <- getPlatform
194 emit $ storeCurCCS (costCentreFrom platform closure)
195
196 enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
197 enterCostCentreFun ccs closure =
198 ifProfiling $
199 if isCurrentCCS ccs
200 then do platform <- getPlatform
201 emitRtsCall rtsUnitId (fsLit "enterFunCCS")
202 [(baseExpr, AddrHint),
203 (costCentreFrom platform closure, AddrHint)] False
204 else return () -- top-level function, nothing to do
205
206 ifProfiling :: FCode () -> FCode ()
207 ifProfiling code
208 = do profile <- targetProfile <$> getDynFlags
209 if profileIsProfiling profile
210 then code
211 else return ()
212
213 ---------------------------------------------------------------
214 -- Initialising Cost Centres & CCSs
215 ---------------------------------------------------------------
216
217 initCostCentres :: CollectedCCs -> FCode ()
218 -- Emit the declarations
219 initCostCentres (local_CCs, singleton_CCSs)
220 = ifProfiling $ do
221 mapM_ emitCostCentreDecl local_CCs
222 mapM_ emitCostCentreStackDecl singleton_CCSs
223
224
225 emitCostCentreDecl :: CostCentre -> FCode ()
226 emitCostCentreDecl cc = do
227 { dflags <- getDynFlags
228 ; platform <- getPlatform
229 ; let is_caf | isCafCC cc = mkIntCLit platform (ord 'c') -- 'c' == is a CAF
230 | otherwise = zero platform
231 -- NB. bytesFS: we want the UTF-8 bytes here (#5559)
232 ; label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
233 ; modl <- newByteStringCLit (bytesFS $ moduleNameFS
234 $ moduleName
235 $ cc_mod cc)
236 ; loc <- newByteStringCLit $ utf8EncodeString $
237 showPpr dflags (costCentreSrcSpan cc)
238 ; let
239 lits = [ zero platform, -- StgInt ccID,
240 label, -- char *label,
241 modl, -- char *module,
242 loc, -- char *srcloc,
243 zero64, -- StgWord64 mem_alloc
244 zero platform, -- StgWord time_ticks
245 is_caf, -- StgInt is_caf
246 zero platform -- struct _CostCentre *link
247 ]
248 ; emitDataLits (mkCCLabel cc) lits
249 }
250
251 emitCostCentreStackDecl :: CostCentreStack -> FCode ()
252 emitCostCentreStackDecl ccs
253 = case maybeSingletonCCS ccs of
254 Just cc ->
255 do platform <- getPlatform
256 let mk_lits cc = zero platform :
257 mkCCostCentre cc :
258 replicate (sizeof_ccs_words platform - 2) (zero platform)
259 -- Note: to avoid making any assumptions about how the
260 -- C compiler (that compiles the RTS, in particular) does
261 -- layouts of structs containing long-longs, simply
262 -- pad out the struct with zero words until we hit the
263 -- size of the overall struct (which we get via DerivedConstants.h)
264 emitDataLits (mkCCSLabel ccs) (mk_lits cc)
265 Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
266
267 zero :: Platform -> CmmLit
268 zero platform = mkIntCLit platform 0
269 zero64 :: CmmLit
270 zero64 = CmmInt 0 W64
271
272 sizeof_ccs_words :: Platform -> Int
273 sizeof_ccs_words platform
274 -- round up to the next word.
275 | ms == 0 = ws
276 | otherwise = ws + 1
277 where
278 (ws,ms) = pc_SIZEOF_CostCentreStack (platformConstants platform) `divMod` platformWordSizeInBytes platform
279
280
281 initInfoTableProv :: [CmmInfoTable] -> InfoTableProvMap -> Module -> FCode CStub
282 -- Emit the declarations
283 initInfoTableProv infos itmap this_mod
284 = do
285 dflags <- getDynFlags
286 let ents = convertInfoProvMap dflags infos this_mod itmap
287 -- Output the actual IPE data
288 mapM_ emitInfoTableProv ents
289 -- Create the C stub which initialises the IPE map
290 return (ipInitCode dflags this_mod ents)
291
292 --- Info Table Prov stuff
293 emitInfoTableProv :: InfoProvEnt -> FCode ()
294 emitInfoTableProv ip = do
295 { dflags <- getDynFlags
296 ; let mod = infoProvModule ip
297 ; let (src, label) = maybe ("", "") (\(s, l) -> (showPpr dflags s, l)) (infoTableProv ip)
298 ; platform <- getPlatform
299 ; let mk_string = newByteStringCLit . utf8EncodeString
300 ; label <- mk_string label
301 ; modl <- newByteStringCLit (bytesFS $ moduleNameFS
302 $ moduleName
303 $ mod)
304
305 ; ty_string <- mk_string (infoTableType ip)
306 ; loc <- mk_string src
307 ; table_name <- mk_string (showPpr dflags (pprCLabel platform CStyle (infoTablePtr ip)))
308 ; closure_type <- mk_string
309 (showPpr dflags (text $ show $ infoProvEntClosureType ip))
310 ; let
311 lits = [ CmmLabel (infoTablePtr ip), -- Info table pointer
312 table_name, -- char *table_name
313 closure_type, -- char *closure_desc -- Filled in from the InfoTable
314 ty_string, -- char *ty_string
315 label, -- char *label,
316 modl, -- char *module,
317 loc, -- char *srcloc,
318 zero platform -- struct _InfoProvEnt *link
319 ]
320 ; emitDataLits (mkIPELabel ip) lits
321 }
322 -- ---------------------------------------------------------------------------
323 -- Set the current cost centre stack
324
325 emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
326 emitSetCCC cc tick push
327 = do profile <- targetProfile <$> getDynFlags
328 let platform = profilePlatform profile
329 if not (profileIsProfiling profile)
330 then return ()
331 else do tmp <- newTemp (ccsType platform)
332 pushCostCentre tmp cccsExpr cc
333 when tick $ emit (bumpSccCount platform (CmmReg (CmmLocal tmp)))
334 when push $ emit (storeCurCCS (CmmReg (CmmLocal tmp)))
335
336 pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
337 pushCostCentre result ccs cc
338 = emitRtsCallWithResult result AddrHint
339 rtsUnitId
340 (fsLit "pushCostCentre") [(ccs,AddrHint),
341 (CmmLit (mkCCostCentre cc), AddrHint)]
342 False
343
344 bumpSccCount :: Platform -> CmmExpr -> CmmAGraph
345 bumpSccCount platform ccs
346 = addToMem (rEP_CostCentreStack_scc_count platform)
347 (cmmOffsetB platform ccs (pc_OFFSET_CostCentreStack_scc_count (platformConstants platform))) 1
348
349 -----------------------------------------------------------------------------
350 --
351 -- Lag/drag/void stuff
352 --
353 -----------------------------------------------------------------------------
354
355 --
356 -- Initial value for the LDV field in a static closure
357 --
358 staticLdvInit :: Platform -> CmmLit
359 staticLdvInit = zeroCLit
360
361 --
362 -- Initial value of the LDV field in a dynamic closure
363 --
364 dynLdvInit :: Platform -> CmmExpr
365 dynLdvInit platform = -- (era << LDV_SHIFT) | LDV_STATE_CREATE
366 CmmMachOp (mo_wordOr platform) [
367 CmmMachOp (mo_wordShl platform) [loadEra platform, mkIntExpr platform (pc_LDV_SHIFT (platformConstants platform))],
368 CmmLit (mkWordCLit platform (pc_ILDV_STATE_CREATE (platformConstants platform)))
369 ]
370
371 --
372 -- Initialise the LDV word of a new closure
373 --
374 ldvRecordCreate :: CmmExpr -> FCode ()
375 ldvRecordCreate closure = do
376 platform <- getPlatform
377 emit $ mkStore (ldvWord platform closure) (dynLdvInit platform)
378
379 --
380 -- | Called when a closure is entered, marks the closure as having
381 -- been "used". The closure is not an "inherently used" one. The
382 -- closure is not @IND@ because that is not considered for LDV profiling.
383 --
384 ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
385 ldvEnterClosure closure_info node_reg = do
386 platform <- getPlatform
387 let tag = funTag platform closure_info
388 -- don't forget to subtract node's tag
389 ldvEnter (cmmOffsetB platform (CmmReg node_reg) (-tag))
390
391 ldvEnter :: CmmExpr -> FCode ()
392 -- Argument is a closure pointer
393 ldvEnter cl_ptr = do
394 platform <- getPlatform
395 let constants = platformConstants platform
396 -- don't forget to subtract node's tag
397 ldv_wd = ldvWord platform cl_ptr
398 new_ldv_wd = cmmOrWord platform
399 (cmmAndWord platform (CmmLoad ldv_wd (bWord platform))
400 (CmmLit (mkWordCLit platform (pc_ILDV_CREATE_MASK constants))))
401 (cmmOrWord platform (loadEra platform) (CmmLit (mkWordCLit platform (pc_ILDV_STATE_USE constants))))
402 ifProfiling $
403 -- if (era > 0) {
404 -- LDVW((c)) = (LDVW((c)) & LDV_CREATE_MASK) |
405 -- era | LDV_STATE_USE }
406 emit =<< mkCmmIfThenElse (CmmMachOp (mo_wordUGt platform) [loadEra platform, CmmLit (zeroCLit platform)])
407 (mkStore ldv_wd new_ldv_wd)
408 mkNop
409
410 loadEra :: Platform -> CmmExpr
411 loadEra platform = CmmMachOp (MO_UU_Conv (cIntWidth platform) (wordWidth platform))
412 [CmmLoad (mkLblExpr (mkRtsCmmDataLabel (fsLit "era")))
413 (cInt platform)]
414
415 -- | Takes the address of a closure, and returns
416 -- the address of the LDV word in the closure
417 ldvWord :: Platform -> CmmExpr -> CmmExpr
418 ldvWord platform closure_ptr
419 = cmmOffsetB platform closure_ptr (pc_OFFSET_StgHeader_ldvw (platformConstants platform))