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