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