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