3f3c3c5a19be9308112f267da104c976f0e778a8
[ghc.git] / compiler / codeGen / StgCmmTicky.hs
1 -----------------------------------------------------------------------------
2 --
3 -- Code generation for ticky-ticky profiling
4 --
5 -- (c) The University of Glasgow 2004-2006
6 --
7 -----------------------------------------------------------------------------
8
9 {- OVERVIEW: ticky ticky profiling
10
11 Please see
12 http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky and also
13 edit it and the rest of this comment to keep them up-to-date if you
14 change ticky-ticky. Thanks!
15
16 *** All allocation ticky numbers are in bytes. ***
17
18 Some of the relevant source files:
19
20 ***not necessarily an exhaustive list***
21
22 * some codeGen/ modules import this one
23
24 * this module imports cmm/CLabel.hs to manage labels
25
26 * cmm/CmmParse.y expands some macros using generators defined in
27 this module
28
29 * includes/stg/Ticky.h declares all of the global counters
30
31 * includes/rts/Ticky.h declares the C data type for an
32 STG-declaration's counters
33
34 * some macros defined in includes/Cmm.h (and used within the RTS's
35 CMM code) update the global ticky counters
36
37 * at the end of execution rts/Ticky.c generates the final report
38 +RTS -r<report-file> -RTS
39
40 The rts/Ticky.c function that generates the report includes an
41 STG-declaration's ticky counters if
42
43 * that declaration was entered, or
44
45 * it was allocated (if -ticky-allocd)
46
47 On either of those events, the counter is "registered" by adding it to
48 a linked list; cf the CMM generated by registerTickyCtr.
49
50 Ticky-ticky profiling has evolved over many years. Many of the
51 counters from its most sophisticated days are no longer
52 active/accurate. As the RTS has changed, sometimes the ticky code for
53 relevant counters was not accordingly updated. Unfortunately, neither
54 were the comments.
55
56 As of March 2013, there still exist deprecated code and comments in
57 the code generator as well as the RTS because:
58
59 * I don't know what is out-of-date versus merely commented out for
60 momentary convenience, and
61
62 * someone else might know how to repair it!
63
64 -}
65
66 module StgCmmTicky (
67 withNewTickyCounterFun,
68 withNewTickyCounterLNE,
69 withNewTickyCounterThunk,
70 withNewTickyCounterStdThunk,
71
72 tickyDynAlloc,
73 tickyAllocHeap,
74
75 tickyAllocPrim,
76 tickyAllocThunk,
77 tickyAllocPAP,
78 tickyHeapCheck,
79 tickyStackCheck,
80
81 tickyUnknownCall, tickyDirectCall,
82
83 tickyPushUpdateFrame,
84 tickyUpdateFrameOmitted,
85
86 tickyEnterDynCon,
87 tickyEnterStaticCon,
88 tickyEnterViaNode,
89
90 tickyEnterFun,
91 tickyEnterThunk, tickyEnterStdThunk, -- dynamic non-value
92 -- thunks only
93 tickyEnterLNE,
94
95 tickyUpdateBhCaf,
96 tickyBlackHole,
97 tickyUnboxedTupleReturn, tickyVectoredReturn,
98 tickyReturnOldCon, tickyReturnNewCon,
99
100 tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
101 tickySlowCall, tickySlowCallPat,
102 ) where
103
104 #include "HsVersions.h"
105
106 import StgCmmArgRep ( slowCallPattern , toArgRep , argRepString )
107 import StgCmmEnv ( NonVoid, unsafe_stripNV )
108 import StgCmmClosure
109 import StgCmmUtils
110 import StgCmmMonad
111
112 import StgSyn
113 import CmmExpr
114 import MkGraph
115 import CmmUtils
116 import CLabel
117 import SMRep
118
119 import Module
120 import Name
121 import Id
122 import BasicTypes
123 import FastString
124 import Outputable
125
126 import DynFlags
127
128 -- Turgid imports for showTypeCategory
129 import PrelNames
130 import TcType
131 import Type
132 import TyCon
133
134 import Data.Maybe
135 import qualified Data.Char
136 import Control.Monad ( unless, when )
137
138 -----------------------------------------------------------------------------
139 --
140 -- Ticky-ticky profiling
141 --
142 -----------------------------------------------------------------------------
143
144 data TickyClosureType = TickyFun | TickyThunk | TickyLNE
145
146 withNewTickyCounterFun, withNewTickyCounterLNE :: Name -> [NonVoid Id] -> FCode a -> FCode a
147 withNewTickyCounterFun = withNewTickyCounter TickyFun
148
149 withNewTickyCounterLNE nm args code = do
150 b <- tickyLNEIsOn
151 if not b then code else withNewTickyCounter TickyLNE nm args code
152
153 withNewTickyCounterThunk,withNewTickyCounterStdThunk ::
154 Bool -> Name -> FCode a -> FCode a
155 withNewTickyCounterThunk isStatic name code = do
156 b <- tickyDynThunkIsOn
157 if isStatic || not b -- ignore static thunks
158 then code
159 else withNewTickyCounter TickyThunk name [] code
160
161 withNewTickyCounterStdThunk = withNewTickyCounterThunk
162
163 -- args does not include the void arguments
164 withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
165 withNewTickyCounter cloType name args m = do
166 lbl <- emitTickyCounter cloType name args
167 setTickyCtrLabel lbl m
168
169 emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
170 emitTickyCounter cloType name args
171 = let ctr_lbl = mkRednCountsLabel name in
172 (>> return ctr_lbl) $
173 ifTicky $ do
174 { dflags <- getDynFlags
175 ; parent <- getTickyCtrLabel
176 ; mod_name <- getModuleName
177
178 -- When printing the name of a thing in a ticky file, we
179 -- want to give the module name even for *local* things. We
180 -- print just "x (M)" rather that "M.x" to distinguish them
181 -- from the global kind.
182 ; let ppr_for_ticky_name :: SDoc
183 ppr_for_ticky_name =
184 let n = ppr name
185 p = case hasHaskellName parent of
186 -- NB the default "top" ticky ctr does not
187 -- have a Haskell name
188 Just pname -> text "in" <+> ppr (nameUnique pname)
189 _ -> empty
190 in (<+> p) $ if isInternalName name
191 then let s = n <+> (parens (ppr mod_name))
192 in case cloType of
193 TickyFun -> s
194 TickyThunk -> s <+> parens (text "thk")
195 TickyLNE -> s <+> parens (text "LNE")
196 else case cloType of
197 TickyFun -> n
198 TickyThunk -> n <+> parens (text "thk")
199 TickyLNE -> panic "emitTickyCounter: how is this an external LNE?"
200
201 ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
202 ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . unsafe_stripNV) args
203 ; emitDataLits ctr_lbl
204 -- Must match layout of includes/rts/Ticky.h's StgEntCounter
205 --
206 -- krc: note that all the fields are I32 now; some were I16
207 -- before, but the code generator wasn't handling that
208 -- properly and it led to chaos, panic and disorder.
209 [ mkIntCLit dflags 0, -- registered?
210 mkIntCLit dflags (length args), -- Arity
211 mkIntCLit dflags 0, -- Heap allocated for this thing
212 fun_descr_lit,
213 arg_descr_lit,
214 zeroCLit dflags, -- Entries into this thing
215 zeroCLit dflags, -- Heap allocated by this thing
216 zeroCLit dflags -- Link to next StgEntCounter
217 ]
218 }
219
220 -- -----------------------------------------------------------------------------
221 -- Ticky stack frames
222
223 tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
224 tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
225 tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
226
227 -- -----------------------------------------------------------------------------
228 -- Ticky entries
229
230 -- NB the name-specific entries are only available for names that have
231 -- dedicated Cmm code. As far as I know, this just rules out
232 -- constructor thunks. For them, there is no CMM code block to put the
233 -- bump of name-specific ticky counter into. On the other hand, we can
234 -- still track allocation their allocation.
235
236 tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
237 tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
238 tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
239 tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
240
241 tickyEnterThunk :: ClosureInfo -> FCode ()
242 tickyEnterThunk cl_info
243 = ifTicky $ do
244 { bumpTickyCounter ctr
245 ; unless static $ do
246 ticky_ctr_lbl <- getTickyCtrLabel
247 registerTickyCtrAtEntryDyn ticky_ctr_lbl
248 bumpTickyEntryCount ticky_ctr_lbl }
249 where
250 updatable = closureSingleEntry cl_info
251 static = isStaticClosure cl_info
252
253 ctr | static = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
254 else fsLit "ENT_STATIC_THK_MANY_ctr"
255 | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
256 else fsLit "ENT_DYN_THK_MANY_ctr"
257
258 tickyEnterStdThunk :: ClosureInfo -> FCode ()
259 tickyEnterStdThunk = tickyEnterThunk
260
261 tickyBlackHole :: Bool{-updatable-} -> FCode ()
262 tickyBlackHole updatable
263 = ifTicky (bumpTickyCounter ctr)
264 where
265 ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
266 | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
267
268 tickyUpdateBhCaf :: ClosureInfo -> FCode ()
269 tickyUpdateBhCaf cl_info
270 = ifTicky (bumpTickyCounter ctr)
271 where
272 ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
273 | otherwise = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
274
275 tickyEnterFun :: ClosureInfo -> FCode ()
276 tickyEnterFun cl_info = ifTicky $ do
277 ctr_lbl <- getTickyCtrLabel
278
279 if isStaticClosure cl_info
280 then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
281 registerTickyCtr ctr_lbl
282 else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
283 registerTickyCtrAtEntryDyn ctr_lbl
284
285 bumpTickyEntryCount ctr_lbl
286
287 tickyEnterLNE :: FCode ()
288 tickyEnterLNE = ifTicky $ do
289 bumpTickyCounter (fsLit "ENT_LNE_ctr")
290 ifTickyLNE $ do
291 ctr_lbl <- getTickyCtrLabel
292 registerTickyCtr ctr_lbl
293 bumpTickyEntryCount ctr_lbl
294
295 -- needn't register a counter upon entry if
296 --
297 -- 1) it's for a dynamic closure, and
298 --
299 -- 2) -ticky-allocd is on
300 --
301 -- since the counter was registered already upon being alloc'd
302 registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
303 registerTickyCtrAtEntryDyn ctr_lbl = do
304 already_registered <- tickyAllocdIsOn
305 when (not already_registered) $ registerTickyCtr ctr_lbl
306
307 registerTickyCtr :: CLabel -> FCode ()
308 -- Register a ticky counter
309 -- if ( ! f_ct.registeredp ) {
310 -- f_ct.link = ticky_entry_ctrs; /* hook this one onto the front of the list */
311 -- ticky_entry_ctrs = & (f_ct); /* mark it as "registered" */
312 -- f_ct.registeredp = 1 }
313 registerTickyCtr ctr_lbl = do
314 dflags <- getDynFlags
315 let
316 -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
317 test = CmmMachOp (MO_Eq (wordWidth dflags))
318 [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
319 (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
320 zeroExpr dflags]
321 register_stmts
322 = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
323 (CmmLoad ticky_entry_ctrs (bWord dflags))
324 , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
325 , mkStore (CmmLit (cmmLabelOffB ctr_lbl
326 (oFFSET_StgEntCounter_registeredp dflags)))
327 (mkIntExpr dflags 1) ]
328 ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
329 emit =<< mkCmmIfThen test (catAGraphs register_stmts)
330
331 tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
332 tickyReturnOldCon arity
333 = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
334 ; bumpHistogram (fsLit "RET_OLD_hst") arity }
335 tickyReturnNewCon arity
336 = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
337 ; bumpHistogram (fsLit "RET_NEW_hst") arity }
338
339 tickyUnboxedTupleReturn :: RepArity -> FCode ()
340 tickyUnboxedTupleReturn arity
341 = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
342 ; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
343
344 tickyVectoredReturn :: Int -> FCode ()
345 tickyVectoredReturn family_size
346 = ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
347 ; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
348
349 -- -----------------------------------------------------------------------------
350 -- Ticky calls
351
352 -- Ticks at a *call site*:
353 tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
354 tickyDirectCall arity args
355 | arity == length args = tickyKnownCallExact
356 | otherwise = do tickyKnownCallExtraArgs
357 tickySlowCallPat (map argPrimRep (drop arity args))
358
359 tickyKnownCallTooFewArgs :: FCode ()
360 tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
361
362 tickyKnownCallExact :: FCode ()
363 tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
364
365 tickyKnownCallExtraArgs :: FCode ()
366 tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
367
368 tickyUnknownCall :: FCode ()
369 tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
370
371 -- Tick for the call pattern at slow call site (i.e. in addition to
372 -- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
373 tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
374 tickySlowCall _ [] = return ()
375 tickySlowCall lf_info args = do
376 -- see Note [Ticky for slow calls]
377 if isKnownFun lf_info
378 then tickyKnownCallTooFewArgs
379 else tickyUnknownCall
380 tickySlowCallPat (map argPrimRep args)
381
382 tickySlowCallPat :: [PrimRep] -> FCode ()
383 tickySlowCallPat args = ifTicky $
384 let argReps = map toArgRep args
385 (_, n_matched) = slowCallPattern argReps
386 in if n_matched > 0 && n_matched == length args
387 then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
388 else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
389
390 {-
391
392 Note [Ticky for slow calls]
393 ~~~~~~~~~~~~~~~~~~~~~~~~~~~
394 Terminology is unfortunately a bit mixed up for these calls. codeGen
395 uses "slow call" to refer to unknown calls and under-saturated known
396 calls.
397
398 Nowadays, though (ie as of the eval/apply paper), the significantly
399 slower calls are actually just a subset of these: the ones with no
400 built-in argument pattern (cf StgCmmArgRep.slowCallPattern)
401
402 So for ticky profiling, we split slow calls into
403 "SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
404 VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
405 bad for both space and time).
406
407 -}
408
409 -- -----------------------------------------------------------------------------
410 -- Ticky allocation
411
412 tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
413 -- Called when doing a dynamic heap allocation; the LambdaFormInfo
414 -- used to distinguish between closure types
415 --
416 -- TODO what else to count while we're here?
417 tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
418 let bytes = wORD_SIZE dflags * heapClosureSize dflags rep
419
420 countGlobal tot ctr = do
421 bumpTickyCounterBy tot bytes
422 bumpTickyCounter ctr
423 countSpecific = ifTickyAllocd $ case mb_id of
424 Nothing -> return ()
425 Just id -> do
426 let ctr_lbl = mkRednCountsLabel (idName id)
427 registerTickyCtr ctr_lbl
428 bumpTickyAllocd ctr_lbl bytes
429
430 -- TODO are we still tracking "good stuff" (_gds) versus
431 -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
432 -- for now, since I don't currently know neither if we do nor how to
433 -- distinguish. NSF Mar 2013
434
435 in case () of
436 _ | isConRep rep ->
437 ifTickyDynThunk countSpecific >>
438 countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
439 | isThunkRep rep ->
440 ifTickyDynThunk countSpecific >>
441 if lfUpdatable lf
442 then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
443 else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
444 | isFunRep rep ->
445 countSpecific >>
446 countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
447 | otherwise -> panic "How is this heap object not a con, thunk, or fun?"
448
449
450
451 tickyAllocHeap ::
452 Bool -> -- is this a genuine allocation? As opposed to
453 -- StgCmmLayout.adjustHpBackwards
454 VirtualHpOffset -> FCode ()
455 -- Called when doing a heap check [TICK_ALLOC_HEAP]
456 -- Must be lazy in the amount of allocation!
457 tickyAllocHeap genuine hp
458 = ifTicky $
459 do { dflags <- getDynFlags
460 ; ticky_ctr <- getTickyCtrLabel
461 ; emit $ catAGraphs $
462 -- only test hp from within the emit so that the monadic
463 -- computation itself is not strict in hp (cf knot in
464 -- StgCmmMonad.getHeapUsage)
465 if hp == 0 then []
466 else let !bytes = wORD_SIZE dflags * hp in [
467 -- Bump the allocation total in the closure's StgEntCounter
468 addToMem (rEP_StgEntCounter_allocs dflags)
469 (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
470 bytes,
471 -- Bump the global allocation total ALLOC_HEAP_tot
472 addToMemLbl (cLong dflags)
473 (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot"))
474 bytes,
475 -- Bump the global allocation counter ALLOC_HEAP_ctr
476 if not genuine then mkNop
477 else addToMemLbl (cLong dflags)
478 (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr"))
479 1
480 ]}
481
482
483 --------------------------------------------------------------------------------
484 -- these three are only called from CmmParse.y (ie ultimately from the RTS)
485
486 -- the units are bytes
487
488 tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
489 tickyAllocPrim _hdr _goods _slop = ifTicky $ do
490 bumpTickyCounter (fsLit "ALLOC_PRIM_ctr")
491 bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
492 bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
493 bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
494
495 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
496 tickyAllocThunk _goods _slop = ifTicky $ do
497 -- TODO is it ever called with a Single-Entry thunk?
498 bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr")
499 bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
500 bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
501
502 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
503 tickyAllocPAP _goods _slop = ifTicky $ do
504 bumpTickyCounter (fsLit "ALLOC_PAP_ctr")
505 bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
506 bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
507
508 tickyHeapCheck :: FCode ()
509 tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
510
511 tickyStackCheck :: FCode ()
512 tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
513
514 -- -----------------------------------------------------------------------------
515 -- Ticky utils
516
517 ifTicky :: FCode () -> FCode ()
518 ifTicky code =
519 getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
520
521 tickyAllocdIsOn :: FCode Bool
522 tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
523
524 tickyLNEIsOn :: FCode Bool
525 tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
526
527 tickyDynThunkIsOn :: FCode Bool
528 tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
529
530 ifTickyAllocd :: FCode () -> FCode ()
531 ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
532
533 ifTickyLNE :: FCode () -> FCode ()
534 ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
535
536 ifTickyDynThunk :: FCode () -> FCode ()
537 ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
538
539 bumpTickyCounter :: FastString -> FCode ()
540 bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageId lbl)
541
542 bumpTickyCounterBy :: FastString -> Int -> FCode ()
543 bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageId lbl)
544
545 bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
546 bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageId lbl)
547
548 bumpTickyEntryCount :: CLabel -> FCode ()
549 bumpTickyEntryCount lbl = do
550 dflags <- getDynFlags
551 bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
552
553 bumpTickyAllocd :: CLabel -> Int -> FCode ()
554 bumpTickyAllocd lbl bytes = do
555 dflags <- getDynFlags
556 bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
557
558 bumpTickyLbl :: CLabel -> FCode ()
559 bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
560
561 bumpTickyLblBy :: CLabel -> Int -> FCode ()
562 bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
563
564 bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
565 bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
566
567 bumpTickyLit :: CmmLit -> FCode ()
568 bumpTickyLit lhs = bumpTickyLitBy lhs 1
569
570 bumpTickyLitBy :: CmmLit -> Int -> FCode ()
571 bumpTickyLitBy lhs n = do
572 dflags <- getDynFlags
573 emit (addToMem (bWord dflags) (CmmLit lhs) n)
574
575 bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
576 bumpTickyLitByE lhs e = do
577 dflags <- getDynFlags
578 emit (addToMemE (bWord dflags) (CmmLit lhs) e)
579
580 bumpHistogram :: FastString -> Int -> FCode ()
581 bumpHistogram _lbl _n
582 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
583 = return () -- TEMP SPJ Apr 07
584 -- six years passed - still temp? JS Aug 2013
585
586 {-
587 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
588 bumpHistogramE lbl n
589 = do t <- newTemp cLong
590 emitAssign (CmmLocal t) n
591 emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
592 (mkAssign (CmmLocal t) eight))
593 emit (addToMem cLong
594 (cmmIndexExpr cLongWidth
595 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
596 (CmmReg (CmmLocal t)))
597 1)
598 where
599 eight = CmmLit (CmmInt 8 cLongWidth)
600 -}
601
602 ------------------------------------------------------------------
603 -- Showing the "type category" for ticky-ticky profiling
604
605 showTypeCategory :: Type -> Char
606 {-
607 + dictionary
608
609 > function
610
611 {C,I,F,D,W} char, int, float, double, word
612 {c,i,f,d,w} unboxed ditto
613
614 T tuple
615
616 P other primitive type
617 p unboxed ditto
618
619 L list
620 E enumeration type
621 S other single-constructor type
622 M other multi-constructor data-con type
623
624 . other type
625
626 - reserved for others to mark as "uninteresting"
627
628 Accurate as of Mar 2013, but I eliminated the Array category instead
629 of updating it, for simplicity. It's in P/p, I think --NSF
630
631 -}
632 showTypeCategory ty
633 | isDictTy ty = '+'
634 | otherwise = case tcSplitTyConApp_maybe ty of
635 Nothing -> '.'
636 Just (tycon, _) ->
637 (if isUnLiftedTyCon tycon then Data.Char.toLower else \x -> x) $
638 let anyOf us = getUnique tycon `elem` us in
639 case () of
640 _ | anyOf [funTyConKey] -> '>'
641 | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
642 | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
643 | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
644 | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
645 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
646 ] -> 'I'
647 | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
648 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
649 ] -> 'W'
650 | anyOf [listTyConKey] -> 'L'
651 | isTupleTyCon tycon -> 'T'
652 | isPrimTyCon tycon -> 'P'
653 | isEnumerationTyCon tycon -> 'E'
654 | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
655 | otherwise -> 'M' -- oh, well...