compiler/codeGen/StgCmmTicky.hs

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