Simplify and tidy up the handling of tuple names
[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 * heapClosureSizeW 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 -- ^ size of the full header, in bytes
489 -> CmmExpr -- ^ size of the payload, in bytes
490 -> CmmExpr -> FCode ()
491 tickyAllocPrim _hdr _goods _slop = ifTicky $ do
492 bumpTickyCounter (fsLit "ALLOC_PRIM_ctr")
493 bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
494 bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
495 bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
496
497 tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
498 tickyAllocThunk _goods _slop = ifTicky $ do
499 -- TODO is it ever called with a Single-Entry thunk?
500 bumpTickyCounter (fsLit "ALLOC_UP_THK_ctr")
501 bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
502 bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
503
504 tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
505 tickyAllocPAP _goods _slop = ifTicky $ do
506 bumpTickyCounter (fsLit "ALLOC_PAP_ctr")
507 bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
508 bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
509
510 tickyHeapCheck :: FCode ()
511 tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
512
513 tickyStackCheck :: FCode ()
514 tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
515
516 -- -----------------------------------------------------------------------------
517 -- Ticky utils
518
519 ifTicky :: FCode () -> FCode ()
520 ifTicky code =
521 getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
522
523 tickyAllocdIsOn :: FCode Bool
524 tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
525
526 tickyLNEIsOn :: FCode Bool
527 tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
528
529 tickyDynThunkIsOn :: FCode Bool
530 tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
531
532 ifTickyAllocd :: FCode () -> FCode ()
533 ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
534
535 ifTickyLNE :: FCode () -> FCode ()
536 ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
537
538 ifTickyDynThunk :: FCode () -> FCode ()
539 ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
540
541 bumpTickyCounter :: FastString -> FCode ()
542 bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsPackageId lbl)
543
544 bumpTickyCounterBy :: FastString -> Int -> FCode ()
545 bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsPackageId lbl)
546
547 bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
548 bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsPackageId lbl)
549
550 bumpTickyEntryCount :: CLabel -> FCode ()
551 bumpTickyEntryCount lbl = do
552 dflags <- getDynFlags
553 bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
554
555 bumpTickyAllocd :: CLabel -> Int -> FCode ()
556 bumpTickyAllocd lbl bytes = do
557 dflags <- getDynFlags
558 bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
559
560 bumpTickyLbl :: CLabel -> FCode ()
561 bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
562
563 bumpTickyLblBy :: CLabel -> Int -> FCode ()
564 bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
565
566 bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
567 bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
568
569 bumpTickyLit :: CmmLit -> FCode ()
570 bumpTickyLit lhs = bumpTickyLitBy lhs 1
571
572 bumpTickyLitBy :: CmmLit -> Int -> FCode ()
573 bumpTickyLitBy lhs n = do
574 dflags <- getDynFlags
575 emit (addToMem (bWord dflags) (CmmLit lhs) n)
576
577 bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
578 bumpTickyLitByE lhs e = do
579 dflags <- getDynFlags
580 emit (addToMemE (bWord dflags) (CmmLit lhs) e)
581
582 bumpHistogram :: FastString -> Int -> FCode ()
583 bumpHistogram _lbl _n
584 -- = bumpHistogramE lbl (CmmLit (CmmInt (fromIntegral n) cLongWidth))
585 = return () -- TEMP SPJ Apr 07
586 -- six years passed - still temp? JS Aug 2013
587
588 {-
589 bumpHistogramE :: LitString -> CmmExpr -> FCode ()
590 bumpHistogramE lbl n
591 = do t <- newTemp cLong
592 emitAssign (CmmLocal t) n
593 emit (mkCmmIfThen (CmmMachOp (MO_U_Le cLongWidth) [CmmReg (CmmLocal t), eight])
594 (mkAssign (CmmLocal t) eight))
595 emit (addToMem cLong
596 (cmmIndexExpr cLongWidth
597 (CmmLit (CmmLabel (mkRtsDataLabel lbl)))
598 (CmmReg (CmmLocal t)))
599 1)
600 where
601 eight = CmmLit (CmmInt 8 cLongWidth)
602 -}
603
604 ------------------------------------------------------------------
605 -- Showing the "type category" for ticky-ticky profiling
606
607 showTypeCategory :: Type -> Char
608 {-
609 + dictionary
610
611 > function
612
613 {C,I,F,D,W} char, int, float, double, word
614 {c,i,f,d,w} unboxed ditto
615
616 T tuple
617
618 P other primitive type
619 p unboxed ditto
620
621 L list
622 E enumeration type
623 S other single-constructor type
624 M other multi-constructor data-con type
625
626 . other type
627
628 - reserved for others to mark as "uninteresting"
629
630 Accurate as of Mar 2013, but I eliminated the Array category instead
631 of updating it, for simplicity. It's in P/p, I think --NSF
632
633 -}
634 showTypeCategory ty
635 | isDictTy ty = '+'
636 | otherwise = case tcSplitTyConApp_maybe ty of
637 Nothing -> '.'
638 Just (tycon, _) ->
639 (if isUnLiftedTyCon tycon then Data.Char.toLower else \x -> x) $
640 let anyOf us = getUnique tycon `elem` us in
641 case () of
642 _ | anyOf [funTyConKey] -> '>'
643 | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
644 | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
645 | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
646 | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
647 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
648 ] -> 'I'
649 | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
650 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
651 ] -> 'W'
652 | anyOf [listTyConKey] -> 'L'
653 | isTupleTyCon tycon -> 'T'
654 | isPrimTyCon tycon -> 'P'
655 | isEnumerationTyCon tycon -> 'E'
656 | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
657 | otherwise -> 'M' -- oh, well...