Module hierarchy: StgToCmm (#13009)

Add StgToCmm module hierarchy. Platform modules that are used in several
other places (NCG, LLVM codegen, Cmm transformations) are put into
GHC.Platform.

1 files changed, 682 insertions, 0 deletions

diff --git a/compiler/GHC/StgToCmm/Ticky.hs b/compiler/GHC/StgToCmm/Ticky.hs
new file mode 100644
index 0000000000..06ef520c0d
--- /dev/null
+++ b/compiler/GHC/StgToCmm/Ticky.hs
@@ -0,0 +1,682 @@
+{-# LANGUAGE BangPatterns #-}
+
+-----------------------------------------------------------------------------
+--
+-- Code generation for ticky-ticky profiling
+--
+-- (c) The University of Glasgow 2004-2006
+--
+-----------------------------------------------------------------------------
+
+{- OVERVIEW: ticky ticky profiling
+
+Please see
+https://gitlab.haskell.org/ghc/ghc/wikis/debugging/ticky-ticky and also
+edit it and the rest of this comment to keep them up-to-date if you
+change ticky-ticky. Thanks!
+
+ *** All allocation ticky numbers are in bytes. ***
+
+Some of the relevant source files:
+
+       ***not necessarily an exhaustive list***
+
+  * some codeGen/ modules import this one
+
+  * this module imports cmm/CLabel.hs to manage labels
+
+  * cmm/CmmParse.y expands some macros using generators defined in
+    this module
+
+  * includes/stg/Ticky.h declares all of the global counters
+
+  * includes/rts/Ticky.h declares the C data type for an
+    STG-declaration's counters
+
+  * some macros defined in includes/Cmm.h (and used within the RTS's
+    CMM code) update the global ticky counters
+
+  * at the end of execution rts/Ticky.c generates the final report
+    +RTS -r<report-file> -RTS
+
+The rts/Ticky.c function that generates the report includes an
+STG-declaration's ticky counters if
+
+  * that declaration was entered, or
+
+  * it was allocated (if -ticky-allocd)
+
+On either of those events, the counter is "registered" by adding it to
+a linked list; cf the CMM generated by registerTickyCtr.
+
+Ticky-ticky profiling has evolved over many years. Many of the
+counters from its most sophisticated days are no longer
+active/accurate. As the RTS has changed, sometimes the ticky code for
+relevant counters was not accordingly updated. Unfortunately, neither
+were the comments.
+
+As of March 2013, there still exist deprecated code and comments in
+the code generator as well as the RTS because:
+
+  * I don't know what is out-of-date versus merely commented out for
+    momentary convenience, and
+
+  * someone else might know how to repair it!
+
+-}
+
+module GHC.StgToCmm.Ticky (
+  withNewTickyCounterFun,
+  withNewTickyCounterLNE,
+  withNewTickyCounterThunk,
+  withNewTickyCounterStdThunk,
+  withNewTickyCounterCon,
+
+  tickyDynAlloc,
+  tickyAllocHeap,
+
+  tickyAllocPrim,
+  tickyAllocThunk,
+  tickyAllocPAP,
+  tickyHeapCheck,
+  tickyStackCheck,
+
+  tickyUnknownCall, tickyDirectCall,
+
+  tickyPushUpdateFrame,
+  tickyUpdateFrameOmitted,
+
+  tickyEnterDynCon,
+  tickyEnterStaticCon,
+  tickyEnterViaNode,
+
+  tickyEnterFun,
+  tickyEnterThunk, tickyEnterStdThunk,        -- dynamic non-value
+                                              -- thunks only
+  tickyEnterLNE,
+
+  tickyUpdateBhCaf,
+  tickyBlackHole,
+  tickyUnboxedTupleReturn,
+  tickyReturnOldCon, tickyReturnNewCon,
+
+  tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
+  tickySlowCall, tickySlowCallPat,
+  ) where
+
+import GhcPrelude
+
+import GHC.StgToCmm.ArgRep    ( slowCallPattern , toArgRep , argRepString )
+import GHC.StgToCmm.Closure
+import GHC.StgToCmm.Utils
+import GHC.StgToCmm.Monad
+
+import StgSyn
+import CmmExpr
+import MkGraph
+import CmmUtils
+import CLabel
+import SMRep
+
+import Module
+import Name
+import Id
+import BasicTypes
+import FastString
+import Outputable
+import Util
+
+import DynFlags
+
+-- Turgid imports for showTypeCategory
+import PrelNames
+import TcType
+import Type
+import TyCon
+
+import Data.Maybe
+import qualified Data.Char
+import Control.Monad ( when )
+
+-----------------------------------------------------------------------------
+--
+-- Ticky-ticky profiling
+--
+-----------------------------------------------------------------------------
+
+data TickyClosureType
+    = TickyFun
+        Bool -- True <-> single entry
+    | TickyCon
+    | TickyThunk
+        Bool -- True <-> updateable
+        Bool -- True <-> standard thunk (AP or selector), has no entry counter
+    | TickyLNE
+
+withNewTickyCounterFun :: Bool -> Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterFun single_entry = withNewTickyCounter (TickyFun single_entry)
+
+withNewTickyCounterLNE :: Name  -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounterLNE nm args code = do
+  b <- tickyLNEIsOn
+  if not b then code else withNewTickyCounter TickyLNE nm args code
+
+thunkHasCounter :: Bool -> FCode Bool
+thunkHasCounter isStatic = do
+  b <- tickyDynThunkIsOn
+  pure (not isStatic && b)
+
+withNewTickyCounterThunk
+  :: Bool -- ^ static
+  -> Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterThunk isStatic isUpdatable name code = do
+    has_ctr <- thunkHasCounter isStatic
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
+
+withNewTickyCounterStdThunk
+  :: Bool -- ^ updateable
+  -> Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterStdThunk isUpdatable name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
+
+withNewTickyCounterCon
+  :: Name
+  -> FCode a
+  -> FCode a
+withNewTickyCounterCon name code = do
+    has_ctr <- thunkHasCounter False
+    if not has_ctr
+      then code
+      else withNewTickyCounter TickyCon name [] code
+
+-- args does not include the void arguments
+withNewTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode a -> FCode a
+withNewTickyCounter cloType name args m = do
+  lbl <- emitTickyCounter cloType name args
+  setTickyCtrLabel lbl m
+
+emitTickyCounter :: TickyClosureType -> Name -> [NonVoid Id] -> FCode CLabel
+emitTickyCounter cloType name args
+  = let ctr_lbl = mkRednCountsLabel name in
+    (>> return ctr_lbl) $
+    ifTicky $ do
+        { dflags <- getDynFlags
+        ; parent <- getTickyCtrLabel
+        ; mod_name <- getModuleName
+
+          -- When printing the name of a thing in a ticky file, we
+          -- want to give the module name even for *local* things.  We
+          -- print just "x (M)" rather that "M.x" to distinguish them
+          -- from the global kind.
+        ; let ppr_for_ticky_name :: SDoc
+              ppr_for_ticky_name =
+                let n = ppr name
+                    ext = case cloType of
+                              TickyFun single_entry -> parens $ hcat $ punctuate comma $
+                                  [text "fun"] ++ [text "se"|single_entry]
+                              TickyCon -> parens (text "con")
+                              TickyThunk upd std -> parens $ hcat $ punctuate comma $
+                                  [text "thk"] ++ [text "se"|not upd] ++ [text "std"|std]
+                              TickyLNE | isInternalName name -> parens (text "LNE")
+                                       | otherwise -> panic "emitTickyCounter: how is this an external LNE?"
+                    p = case hasHaskellName parent of
+                            -- NB the default "top" ticky ctr does not
+                            -- have a Haskell name
+                          Just pname -> text "in" <+> ppr (nameUnique pname)
+                          _ -> empty
+                in if isInternalName name
+                   then n <+> parens (ppr mod_name) <+> ext <+> p
+                   else n <+> ext <+> p
+
+        ; fun_descr_lit <- newStringCLit $ showSDocDebug dflags ppr_for_ticky_name
+        ; arg_descr_lit <- newStringCLit $ map (showTypeCategory . idType . fromNonVoid) args
+        ; emitDataLits ctr_lbl
+        -- Must match layout of includes/rts/Ticky.h's StgEntCounter
+        --
+        -- krc: note that all the fields are I32 now; some were I16
+        -- before, but the code generator wasn't handling that
+        -- properly and it led to chaos, panic and disorder.
+            [ mkIntCLit dflags 0,               -- registered?
+              mkIntCLit dflags (length args),   -- Arity
+              mkIntCLit dflags 0,               -- Heap allocated for this thing
+              fun_descr_lit,
+              arg_descr_lit,
+              zeroCLit dflags,          -- Entries into this thing
+              zeroCLit dflags,          -- Heap allocated by this thing
+              zeroCLit dflags                   -- Link to next StgEntCounter
+            ]
+        }
+
+-- -----------------------------------------------------------------------------
+-- Ticky stack frames
+
+tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
+tickyPushUpdateFrame    = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
+tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky entries
+
+-- NB the name-specific entries are only available for names that have
+-- dedicated Cmm code. As far as I know, this just rules out
+-- constructor thunks. For them, there is no CMM code block to put the
+-- bump of name-specific ticky counter into. On the other hand, we can
+-- still track allocation their allocation.
+
+tickyEnterDynCon, tickyEnterStaticCon, tickyEnterViaNode :: FCode ()
+tickyEnterDynCon      = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
+tickyEnterStaticCon   = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
+tickyEnterViaNode     = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
+
+tickyEnterThunk :: ClosureInfo -> FCode ()
+tickyEnterThunk cl_info
+  = ifTicky $ do
+    { bumpTickyCounter ctr
+    ; has_ctr <- thunkHasCounter static
+    ; when has_ctr $ do
+      ticky_ctr_lbl <- getTickyCtrLabel
+      registerTickyCtrAtEntryDyn ticky_ctr_lbl
+      bumpTickyEntryCount ticky_ctr_lbl }
+  where
+    updatable = closureSingleEntry cl_info
+    static    = isStaticClosure cl_info
+
+    ctr | static    = if updatable then fsLit "ENT_STATIC_THK_SINGLE_ctr"
+                                   else fsLit "ENT_STATIC_THK_MANY_ctr"
+        | otherwise = if updatable then fsLit "ENT_DYN_THK_SINGLE_ctr"
+                                   else fsLit "ENT_DYN_THK_MANY_ctr"
+
+tickyEnterStdThunk :: ClosureInfo -> FCode ()
+tickyEnterStdThunk = tickyEnterThunk
+
+tickyBlackHole :: Bool{-updatable-} -> FCode ()
+tickyBlackHole updatable
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | updatable = (fsLit "UPD_BH_SINGLE_ENTRY_ctr")
+        | otherwise = (fsLit "UPD_BH_UPDATABLE_ctr")
+
+tickyUpdateBhCaf :: ClosureInfo -> FCode ()
+tickyUpdateBhCaf cl_info
+  = ifTicky (bumpTickyCounter ctr)
+  where
+    ctr | closureUpdReqd cl_info = (fsLit "UPD_CAF_BH_SINGLE_ENTRY_ctr")
+        | otherwise              = (fsLit "UPD_CAF_BH_UPDATABLE_ctr")
+
+tickyEnterFun :: ClosureInfo -> FCode ()
+tickyEnterFun cl_info = ifTicky $ do
+  ctr_lbl <- getTickyCtrLabel
+
+  if isStaticClosure cl_info
+    then do bumpTickyCounter (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
+            registerTickyCtr ctr_lbl
+    else do bumpTickyCounter (fsLit "ENT_DYN_FUN_DIRECT_ctr")
+            registerTickyCtrAtEntryDyn ctr_lbl
+
+  bumpTickyEntryCount ctr_lbl
+
+tickyEnterLNE :: FCode ()
+tickyEnterLNE = ifTicky $ do
+  bumpTickyCounter (fsLit "ENT_LNE_ctr")
+  ifTickyLNE $ do
+    ctr_lbl <- getTickyCtrLabel
+    registerTickyCtr ctr_lbl
+    bumpTickyEntryCount ctr_lbl
+
+-- needn't register a counter upon entry if
+--
+-- 1) it's for a dynamic closure, and
+--
+-- 2) -ticky-allocd is on
+--
+-- since the counter was registered already upon being alloc'd
+registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
+registerTickyCtrAtEntryDyn ctr_lbl = do
+  already_registered <- tickyAllocdIsOn
+  when (not already_registered) $ registerTickyCtr ctr_lbl
+
+registerTickyCtr :: CLabel -> FCode ()
+-- Register a ticky counter
+--   if ( ! f_ct.registeredp ) {
+--          f_ct.link = ticky_entry_ctrs;       /* hook this one onto the front of the list */
+--          ticky_entry_ctrs = & (f_ct);        /* mark it as "registered" */
+--          f_ct.registeredp = 1 }
+registerTickyCtr ctr_lbl = do
+  dflags <- getDynFlags
+  let
+    -- krc: code generator doesn't handle Not, so we test for Eq 0 instead
+    test = CmmMachOp (MO_Eq (wordWidth dflags))
+              [CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags))) (bWord dflags),
+               zeroExpr dflags]
+    register_stmts
+      = [ mkStore (CmmLit (cmmLabelOffB ctr_lbl (oFFSET_StgEntCounter_link dflags)))
+                   (CmmLoad ticky_entry_ctrs (bWord dflags))
+        , mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
+        , mkStore (CmmLit (cmmLabelOffB ctr_lbl
+                                (oFFSET_StgEntCounter_registeredp dflags)))
+                   (mkIntExpr dflags 1) ]
+    ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsUnitId (fsLit "ticky_entry_ctrs"))
+  emit =<< mkCmmIfThen test (catAGraphs register_stmts)
+
+tickyReturnOldCon, tickyReturnNewCon :: RepArity -> FCode ()
+tickyReturnOldCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_OLD_ctr")
+                 ; bumpHistogram    (fsLit "RET_OLD_hst") arity }
+tickyReturnNewCon arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_NEW_ctr")
+                 ; bumpHistogram    (fsLit "RET_NEW_hst") arity }
+
+tickyUnboxedTupleReturn :: RepArity -> FCode ()
+tickyUnboxedTupleReturn arity
+  = ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
+                 ; bumpHistogram    (fsLit "RET_UNBOXED_TUP_hst") arity }
+
+-- -----------------------------------------------------------------------------
+-- Ticky calls
+
+-- Ticks at a *call site*:
+tickyDirectCall :: RepArity -> [StgArg] -> FCode ()
+tickyDirectCall arity args
+  | args `lengthIs` arity = tickyKnownCallExact
+  | otherwise = do tickyKnownCallExtraArgs
+                   tickySlowCallPat (map argPrimRep (drop arity args))
+
+tickyKnownCallTooFewArgs :: FCode ()
+tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
+
+tickyKnownCallExact :: FCode ()
+tickyKnownCallExact      = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
+
+tickyKnownCallExtraArgs :: FCode ()
+tickyKnownCallExtraArgs  = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
+
+tickyUnknownCall :: FCode ()
+tickyUnknownCall         = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
+
+-- Tick for the call pattern at slow call site (i.e. in addition to
+-- tickyUnknownCall, tickyKnownCallExtraArgs, etc.)
+tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
+tickySlowCall _ [] = return ()
+tickySlowCall lf_info args = do
+ -- see Note [Ticky for slow calls]
+ if isKnownFun lf_info
+   then tickyKnownCallTooFewArgs
+   else tickyUnknownCall
+ tickySlowCallPat (map argPrimRep args)
+
+tickySlowCallPat :: [PrimRep] -> FCode ()
+tickySlowCallPat args = ifTicky $
+  let argReps = map toArgRep args
+      (_, n_matched) = slowCallPattern argReps
+  in if n_matched > 0 && args `lengthIs` n_matched
+     then bumpTickyLbl $ mkRtsSlowFastTickyCtrLabel $ concatMap (map Data.Char.toLower . argRepString) argReps
+     else bumpTickyCounter $ fsLit "VERY_SLOW_CALL_ctr"
+
+{-
+
+Note [Ticky for slow calls]
+~~~~~~~~~~~~~~~~~~~~~~~~~~~
+Terminology is unfortunately a bit mixed up for these calls. codeGen
+uses "slow call" to refer to unknown calls and under-saturated known
+calls.
+
+Nowadays, though (ie as of the eval/apply paper), the significantly
+slower calls are actually just a subset of these: the ones with no
+built-in argument pattern (cf GHC.StgToCmm.ArgRep.slowCallPattern)
+
+So for ticky profiling, we split slow calls into
+"SLOW_CALL_fast_<pattern>_ctr" (those matching a built-in pattern) and
+VERY_SLOW_CALL_ctr (those without a built-in pattern; these are very
+bad for both space and time).
+
+-}
+
+-- -----------------------------------------------------------------------------
+-- Ticky allocation
+
+tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
+-- Called when doing a dynamic heap allocation; the LambdaFormInfo
+-- used to distinguish between closure types
+--
+-- TODO what else to count while we're here?
+tickyDynAlloc mb_id rep lf = ifTicky $ getDynFlags >>= \dflags ->
+  let bytes = wORD_SIZE dflags * heapClosureSizeW dflags rep
+
+      countGlobal tot ctr = do
+        bumpTickyCounterBy tot bytes
+        bumpTickyCounter   ctr
+      countSpecific = ifTickyAllocd $ case mb_id of
+        Nothing -> return ()
+        Just id -> do
+          let ctr_lbl = mkRednCountsLabel (idName id)
+          registerTickyCtr ctr_lbl
+          bumpTickyAllocd ctr_lbl bytes
+
+  -- TODO are we still tracking "good stuff" (_gds) versus
+  -- administrative (_adm) versus slop (_slp)? I'm going with all _gds
+  -- for now, since I don't currently know neither if we do nor how to
+  -- distinguish. NSF Mar 2013
+
+  in case () of
+    _ | isConRep rep   ->
+          ifTickyDynThunk countSpecific >>
+          countGlobal (fsLit "ALLOC_CON_gds") (fsLit "ALLOC_CON_ctr")
+      | isThunkRep rep ->
+          ifTickyDynThunk countSpecific >>
+          if lfUpdatable lf
+          then countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_UP_THK_ctr")
+          else countGlobal (fsLit "ALLOC_THK_gds") (fsLit "ALLOC_SE_THK_ctr")
+      | isFunRep   rep ->
+          countSpecific >>
+          countGlobal (fsLit "ALLOC_FUN_gds") (fsLit "ALLOC_FUN_ctr")
+      | otherwise      -> panic "How is this heap object not a con, thunk, or fun?"
+
+
+
+tickyAllocHeap ::
+  Bool -> -- is this a genuine allocation? As opposed to
+          -- GHC.StgToCmm.Layout.adjustHpBackwards
+  VirtualHpOffset -> FCode ()
+-- Called when doing a heap check [TICK_ALLOC_HEAP]
+-- Must be lazy in the amount of allocation!
+tickyAllocHeap genuine hp
+  = ifTicky $
+    do  { dflags <- getDynFlags
+        ; ticky_ctr <- getTickyCtrLabel
+        ; emit $ catAGraphs $
+            -- only test hp from within the emit so that the monadic
+            -- computation itself is not strict in hp (cf knot in
+            -- GHC.StgToCmm.Monad.getHeapUsage)
+          if hp == 0 then []
+          else let !bytes = wORD_SIZE dflags * hp in [
+            -- Bump the allocation total in the closure's StgEntCounter
+            addToMem (rEP_StgEntCounter_allocs dflags)
+                     (CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
+                     bytes,
+            -- Bump the global allocation total ALLOC_HEAP_tot
+            addToMemLbl (bWord dflags)
+                        (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
+                        bytes,
+            -- Bump the global allocation counter ALLOC_HEAP_ctr
+            if not genuine then mkNop
+            else addToMemLbl (bWord dflags)
+                             (mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_ctr"))
+                             1
+            ]}
+
+
+--------------------------------------------------------------------------------
+-- these three are only called from CmmParse.y (ie ultimately from the RTS)
+
+-- the units are bytes
+
+tickyAllocPrim :: CmmExpr  -- ^ size of the full header, in bytes
+               -> CmmExpr  -- ^ size of the payload, in bytes
+               -> CmmExpr -> FCode ()
+tickyAllocPrim _hdr _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PRIM_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_adm") _hdr
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PRIM_slp") _slop
+
+tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocThunk _goods _slop = ifTicky $ do
+    -- TODO is it ever called with a Single-Entry thunk?
+  bumpTickyCounter    (fsLit "ALLOC_UP_THK_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_THK_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_THK_slp") _slop
+
+tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
+tickyAllocPAP _goods _slop = ifTicky $ do
+  bumpTickyCounter    (fsLit "ALLOC_PAP_ctr")
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_gds") _goods
+  bumpTickyCounterByE (fsLit "ALLOC_PAP_slp") _slop
+
+tickyHeapCheck :: FCode ()
+tickyHeapCheck = ifTicky $ bumpTickyCounter (fsLit "HEAP_CHK_ctr")
+
+tickyStackCheck :: FCode ()
+tickyStackCheck = ifTicky $ bumpTickyCounter (fsLit "STK_CHK_ctr")
+
+-- -----------------------------------------------------------------------------
+-- Ticky utils
+
+ifTicky :: FCode () -> FCode ()
+ifTicky code =
+  getDynFlags >>= \dflags -> when (gopt Opt_Ticky dflags) code
+
+tickyAllocdIsOn :: FCode Bool
+tickyAllocdIsOn = gopt Opt_Ticky_Allocd `fmap` getDynFlags
+
+tickyLNEIsOn :: FCode Bool
+tickyLNEIsOn = gopt Opt_Ticky_LNE `fmap` getDynFlags
+
+tickyDynThunkIsOn :: FCode Bool
+tickyDynThunkIsOn = gopt Opt_Ticky_Dyn_Thunk `fmap` getDynFlags
+
+ifTickyAllocd :: FCode () -> FCode ()
+ifTickyAllocd code = tickyAllocdIsOn >>= \b -> when b code
+
+ifTickyLNE :: FCode () -> FCode ()
+ifTickyLNE code = tickyLNEIsOn >>= \b -> when b code
+
+ifTickyDynThunk :: FCode () -> FCode ()
+ifTickyDynThunk code = tickyDynThunkIsOn >>= \b -> when b code
+
+bumpTickyCounter :: FastString -> FCode ()
+bumpTickyCounter lbl = bumpTickyLbl (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterBy :: FastString -> Int -> FCode ()
+bumpTickyCounterBy lbl = bumpTickyLblBy (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
+bumpTickyCounterByE lbl = bumpTickyLblByE (mkCmmDataLabel rtsUnitId lbl)
+
+bumpTickyEntryCount :: CLabel -> FCode ()
+bumpTickyEntryCount lbl = do
+  dflags <- getDynFlags
+  bumpTickyLit (cmmLabelOffB lbl (oFFSET_StgEntCounter_entry_count dflags))
+
+bumpTickyAllocd :: CLabel -> Int -> FCode ()
+bumpTickyAllocd lbl bytes = do
+  dflags <- getDynFlags
+  bumpTickyLitBy (cmmLabelOffB lbl (oFFSET_StgEntCounter_allocd dflags)) bytes
+
+bumpTickyLbl :: CLabel -> FCode ()
+bumpTickyLbl lhs = bumpTickyLitBy (cmmLabelOffB lhs 0) 1
+
+bumpTickyLblBy :: CLabel -> Int -> FCode ()
+bumpTickyLblBy lhs = bumpTickyLitBy (cmmLabelOffB lhs 0)
+
+bumpTickyLblByE :: CLabel -> CmmExpr -> FCode ()
+bumpTickyLblByE lhs = bumpTickyLitByE (cmmLabelOffB lhs 0)
+
+bumpTickyLit :: CmmLit -> FCode ()
+bumpTickyLit lhs = bumpTickyLitBy lhs 1
+
+bumpTickyLitBy :: CmmLit -> Int -> FCode ()
+bumpTickyLitBy lhs n = do
+  dflags <- getDynFlags
+  emit (addToMem (bWord dflags) (CmmLit lhs) n)
+
+bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
+bumpTickyLitByE lhs e = do
+  dflags <- getDynFlags
+  emit (addToMemE (bWord dflags) (CmmLit lhs) e)
+
+bumpHistogram :: FastString -> Int -> FCode ()
+bumpHistogram lbl n = do
+    dflags <- getDynFlags
+    let offset = n `min` (tICKY_BIN_COUNT dflags - 1)
+    emit (addToMem (bWord dflags)
+           (cmmIndexExpr dflags
+                (wordWidth dflags)
+                (CmmLit (CmmLabel (mkCmmDataLabel rtsUnitId lbl)))
+                (CmmLit (CmmInt (fromIntegral offset) (wordWidth dflags))))
+           1)
+
+------------------------------------------------------------------
+-- Showing the "type category" for ticky-ticky profiling
+
+showTypeCategory :: Type -> Char
+  {-
+        +           dictionary
+
+        >           function
+
+        {C,I,F,D,W} char, int, float, double, word
+        {c,i,f,d,w} unboxed ditto
+
+        T           tuple
+
+        P           other primitive type
+        p           unboxed ditto
+
+        L           list
+        E           enumeration type
+        S           other single-constructor type
+        M           other multi-constructor data-con type
+
+        .           other type
+
+        -           reserved for others to mark as "uninteresting"
+
+  Accurate as of Mar 2013, but I eliminated the Array category instead
+  of updating it, for simplicity. It's in P/p, I think --NSF
+
+    -}
+showTypeCategory ty
+  | isDictTy ty = '+'
+  | otherwise = case tcSplitTyConApp_maybe ty of
+  Nothing -> '.'
+  Just (tycon, _) ->
+    (if isUnliftedTyCon tycon then Data.Char.toLower else id) $
+    let anyOf us = getUnique tycon `elem` us in
+    case () of
+      _ | anyOf [funTyConKey] -> '>'
+        | anyOf [charPrimTyConKey, charTyConKey] -> 'C'
+        | anyOf [doublePrimTyConKey, doubleTyConKey] -> 'D'
+        | anyOf [floatPrimTyConKey, floatTyConKey] -> 'F'
+        | anyOf [intPrimTyConKey, int32PrimTyConKey, int64PrimTyConKey,
+                 intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey
+                ] -> 'I'
+        | anyOf [wordPrimTyConKey, word32PrimTyConKey, word64PrimTyConKey, wordTyConKey,
+                 word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey
+                ] -> 'W'
+        | anyOf [listTyConKey] -> 'L'
+        | isTupleTyCon tycon       -> 'T'
+        | isPrimTyCon tycon        -> 'P'
+        | isEnumerationTyCon tycon -> 'E'
+        | isJust (tyConSingleDataCon_maybe tycon) -> 'S'
+        | otherwise -> 'M' -- oh, well...