ghc-8.8.1: codeGen/StgCmmTicky.hs
{-# LANGUAGE BangPatterns #-}
-----------------------------------------------------------------------------
--
-- Code generation for ticky-ticky profiling
--
-- (c) The University of Glasgow 2004-2006
--
-----------------------------------------------------------------------------
{- OVERVIEW: ticky ticky profiling
Please see
http://ghc.haskell.org/trac/ghc/wiki/Debugging/TickyTicky 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 StgCmmTicky (
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 StgCmmArgRep ( slowCallPattern , toArgRep , argRepString )
import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
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 StgCmmArgRep.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
-- StgCmmLayout.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
-- StgCmmMonad.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...