module GHC.StgToCmm.Ticky (
withNewTickyCounterFun,
withNewTickyCounterLNE,
withNewTickyCounterThunk,
withNewTickyCounterStdThunk,
withNewTickyCounterCon,
emitTickyCounterTag,
tickyDynAlloc,
tickyAllocHeap,
tickyAllocPrim,
tickyAllocThunk,
tickyAllocPAP,
tickyHeapCheck,
tickyStackCheck,
tickyDirectCall,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
tickyEnterFun,
tickyEnterThunk,
tickyEnterLNE,
tickyUpdateBhCaf,
tickyUnboxedTupleReturn,
tickyReturnOldCon, tickyReturnNewCon,
tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
tickySlowCall, tickySlowCallPat,
tickyTagged, tickyUntagged, tickyTagSkip
) where
import GHC.Prelude
import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.ArgRep ( slowCallPattern , toArgRep , argRepString )
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Config
import GHC.StgToCmm.Foreign ( emitPrimCall )
import GHC.StgToCmm.Lit ( newStringCLit )
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.Stg.Syntax
import GHC.Cmm.Expr
import GHC.Cmm.Graph
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Types.Name
import GHC.Types.Id
import GHC.Types.Basic
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Misc
import GHC.Utils.Monad (whenM)
import GHC.Builtin.Names
import GHC.Tc.Utils.TcType
import GHC.Core.DataCon
import GHC.Core.TyCon
import GHC.Core.Predicate
import Data.Maybe
import qualified Data.Char
import Control.Monad ( when, unless )
import GHC.Types.Id.Info
import GHC.Utils.Trace
import GHC.StgToCmm.Env (getCgInfo_maybe)
import Data.Coerce (coerce)
import GHC.Utils.Json
tickyArgArity :: TickyClosureType -> Int
tickyArgArity (TickyFun _ _fvs args) = length args
tickyArgArity (TickyLNE args) = length args
tickyArgArity (TickyCon{}) = 0
tickyArgArity (TickyThunk{}) = 0
tickyArgDesc :: TickyClosureType -> String
tickyArgDesc arg_info =
case arg_info of
TickyFun _ _fvs args -> map (showTypeCategory . idType . fromNonVoid) args
TickyLNE args -> map (showTypeCategory . idType . fromNonVoid) args
TickyThunk{} -> ""
TickyCon{} -> ""
tickyFvDesc :: TickyClosureType -> String
tickyFvDesc arg_info =
case arg_info of
TickyFun _ fvs _args -> map (showTypeCategory . idType . fromNonVoid) fvs
TickyLNE{} -> ""
TickyThunk _ _ fvs -> map (showTypeCategory . stgArgType) fvs
TickyCon{} -> ""
instance ToJson TickyClosureType where
json info = case info of
(TickyFun {}) -> mkInfo (tickyFvDesc info) (tickyArgDesc info) "fun"
(TickyLNE {}) -> mkInfo [] (tickyArgDesc info) "lne"
(TickyThunk uf _ _) -> mkInfo (tickyFvDesc info) [] ("thk" ++ if uf then "_u" else "")
(TickyCon{}) -> mkInfo [] [] "con"
where
mkInfo :: String -> String -> String -> JsonDoc
mkInfo fvs args ty =
JSObject
[("type", json "entCntr")
,("subTy", json ty)
,("fvs_c", json (length fvs))
,("fvs" , json fvs)
,("args", json args)
]
tickyEntryDescJson :: (SDocContext -> TickyClosureType -> String)
tickyEntryDescJson ctxt = renderWithContext ctxt . renderJSON . json
data TickyClosureType
= TickyFun
Bool
[NonVoid Id]
[NonVoid Id]
| TickyCon
DataCon
ConstructorNumber
| TickyThunk
Bool
Bool
[StgArg]
| TickyLNE
[NonVoid Id]
withNewTickyCounterFun :: Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun single_entry f fvs args = withNewTickyCounter (TickyFun single_entry fvs args) f
withNewTickyCounterLNE :: Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterLNE nm args code = do
b <- isEnabled stgToCmmTickyLNE
if not b then code else withNewTickyCounter (TickyLNE args) nm code
thunkHasCounter :: Bool -> FCode Bool
thunkHasCounter isStatic = (not isStatic &&) <$> isEnabled stgToCmmTickyDynThunk
withNewTickyCounterThunk
:: Bool
-> Bool
-> Id
-> [NonVoid Id]
-> FCode a
-> FCode a
withNewTickyCounterThunk isStatic isUpdatable name fvs code = do
has_ctr <- thunkHasCounter isStatic
if not has_ctr
then code
else withNewTickyCounter (TickyThunk isUpdatable False (map StgVarArg $ coerce fvs)) name code
withNewTickyCounterStdThunk
:: Bool
-> Id
-> [StgArg]
-> FCode a
-> FCode a
withNewTickyCounterStdThunk isUpdatable name fvs code = do
has_ctr <- thunkHasCounter False
if not has_ctr
then code
else withNewTickyCounter (TickyThunk isUpdatable True fvs) name code
withNewTickyCounterCon
:: Id
-> DataCon
-> ConstructorNumber
-> FCode a
-> FCode a
withNewTickyCounterCon name datacon info code = do
has_ctr <- thunkHasCounter False
if not has_ctr
then code
else withNewTickyCounter (TickyCon datacon info) name code
withNewTickyCounter :: TickyClosureType -> Id -> FCode a -> FCode a
withNewTickyCounter cloType name m = do
lbl <- emitTickyCounter cloType name
setTickyCtrLabel lbl m
emitTickyData :: Platform
-> CLabel
-> Arity
-> CmmLit
-> CmmLit
-> CmmLit
-> CmmLit
-> FCode ()
emitTickyData platform ctr_lbl arity fun_desc arg_desc json_desc info_tbl =
emitDataLits ctr_lbl
[ zeroCLit platform,
mkIntCLit platform arity,
zeroCLit platform,
fun_desc,
arg_desc,
json_desc,
info_tbl,
zeroCLit platform,
zeroCLit platform,
zeroCLit platform
]
emitTickyCounter :: TickyClosureType -> Id -> FCode CLabel
emitTickyCounter cloType tickee
= let name = idName tickee in
let ctr_lbl = mkRednCountsLabel name in
(>> return ctr_lbl) $
ifTicky $ do
{ cfg <- getStgToCmmConfig
; parent <- getTickyCtrLabel
; mod_name <- getModuleName
; let platform = stgToCmmPlatform cfg
ppr_for_ticky_name :: SDoc
ppr_for_ticky_name =
let ext = case cloType of
TickyFun single_entry _ _-> parens $ hcat $ punctuate comma $
[text "fun"] ++ [text "se"|single_entry]
TickyCon datacon _cn -> parens (text "con:" <+> ppr (dataConName datacon))
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
Just pname -> text "in" <+> ppr (nameUnique pname)
_ -> empty
in pprTickyName mod_name name <+> ext <+> p
; this_mod <- getModuleName
; let t = case cloType of
TickyCon {} -> "C"
TickyFun {} -> "F"
TickyThunk {} -> "T"
TickyLNE {} -> "L"
; info_lbl <- case cloType of
TickyCon dc mn -> case mn of
NoNumber -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) DefinitionSite
(Numbered n) -> return $! CmmLabel $ mkConInfoTableLabel (dataConName dc) (UsageSite this_mod n)
TickyFun {} ->
return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
TickyThunk _ std_thunk _fvs
| not std_thunk
-> return $! CmmLabel $ mkInfoTableLabel name NoCafRefs
| otherwise
-> do
lf_info <- getCgInfo_maybe name
profile <- getProfile
case lf_info of
Just (CgIdInfo { cg_lf = cg_lf })
| isLFThunk cg_lf
-> return $! CmmLabel $ mkClosureInfoTableLabel (profilePlatform profile) tickee cg_lf
_ -> pprTraceDebug "tickyThunkUnknown" (text t <> colon <> ppr name <+> ppr (mkInfoTableLabel name NoCafRefs))
return $! zeroCLit platform
TickyLNE {} -> return $! zeroCLit platform
; let ctx = defaultSDocContext {sdocPprDebug = True}
; fun_descr_lit <- newStringCLit $ renderWithContext ctx ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ tickyArgDesc cloType
; json_descr_lit <- newStringCLit $ tickyEntryDescJson ctx cloType
; emitTickyData platform ctr_lbl (tickyArgArity cloType) fun_descr_lit arg_descr_lit json_descr_lit info_lbl
}
emitTickyCounterTag :: Unique -> NonVoid Id -> FCode CLabel
emitTickyCounterTag unique (NonVoid id) =
let name = idName id
ctr_lbl = mkTagHitLabel name unique in
(>> return ctr_lbl) $
ifTickyTag $ do
{ platform <- getPlatform
; parent <- getTickyCtrLabel
; mod_name <- getModuleName
; let ppr_for_ticky_name :: SDoc
ppr_for_ticky_name =
let n = ppr name
ext = empty
p = case hasHaskellName parent of
Just pname -> text "at" <+> ppr (nameSrcLoc pname) <+>
text "in" <+> pprNameUnqualified name
_ -> empty
in if isInternalName name
then n <+> parens (ppr mod_name) <+> ext <+> p
else n <+> ext <+> p
; sdoc_context <- stgToCmmContext <$> getStgToCmmConfig
; fun_descr_lit <- newStringCLit $ renderWithContext sdoc_context ppr_for_ticky_name
; arg_descr_lit <- newStringCLit $ "infer"
; json_descr_lit <- newStringCLit $ "infer"
; emitTickyData platform ctr_lbl 0 fun_descr_lit arg_descr_lit json_descr_lit (zeroCLit platform)
}
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
tickyEnterDynCon :: FCode ()
tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_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 = not (closureUpdReqd 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"
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
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn ctr_lbl = do
already_registered <- isEnabled stgToCmmTickyAllocd
unless already_registered $ registerTickyCtr ctr_lbl
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr ctr_lbl = do
platform <- getPlatform
let constants = platformConstants platform
word_width = wordWidth platform
registeredp = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_registeredp constants))
register_stmts <- getCode $ do
old_head <- newTemp (bWord platform)
let ticky_entry_ctrs = mkLblExpr (mkRtsCmmDataLabel (fsLit "ticky_entry_ctrs"))
link = CmmLit (cmmLabelOffB ctr_lbl (pc_OFFSET_StgEntCounter_link constants))
emitPrimCall [old_head] (MO_Xchg word_width) [ticky_entry_ctrs, mkLblExpr ctr_lbl]
emitStore link (CmmReg $ CmmLocal old_head)
cas_test <- getCode $ do
old <- newTemp (bWord platform)
emitPrimCall [old] (MO_Cmpxchg word_width)
[registeredp, zeroExpr platform, mkIntExpr platform 1]
let locked = cmmEqWord platform (CmmReg $ CmmLocal old) (zeroExpr platform)
emit =<< mkCmmIfThen locked register_stmts
let test = cmmEqWord platform (cmmLoadBWord platform registeredp) (zeroExpr platform)
emit =<< mkCmmIfThen test cas_test
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 }
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")
tickySlowCall :: LambdaFormInfo -> [StgArg] -> FCode ()
tickySlowCall _ [] = return ()
tickySlowCall lf_info args = do
if isKnownFun lf_info
then tickyKnownCallTooFewArgs
else tickyUnknownCall
tickySlowCallPat (map argPrimRep args)
tickySlowCallPat :: [PrimRep] -> FCode ()
tickySlowCallPat args = ifTicky $ do
platform <- profilePlatform <$> getProfile
let argReps = map (toArgRep platform) args
(_, n_matched) = slowCallPattern argReps
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"
tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
tickyDynAlloc mb_id rep lf = ifTicky $ do
profile <- getProfile
let platform = profilePlatform profile
bytes = platformWordSizeInBytes platform * heapClosureSizeW profile 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
if | 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 ->
VirtualHpOffset -> FCode ()
tickyAllocHeap genuine hp
= ifTicky $
do { platform <- getPlatform
; ticky_ctr <- getTickyCtrLabel
; emit $ catAGraphs $
if hp == 0 then []
else let !bytes = platformWordSizeInBytes platform * hp in [
addToMem (rEP_StgEntCounter_allocs platform)
(CmmLit (cmmLabelOffB ticky_ctr (pc_OFFSET_StgEntCounter_allocs (platformConstants platform))))
bytes,
addToMemLbl (bWord platform)
(mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_tot"))
bytes,
if not genuine then mkNop
else addToMemLbl (bWord platform)
(mkRtsCmmDataLabel (fsLit "ALLOC_HEAP_ctr"))
1
]}
tickyAllocPrim :: CmmExpr
-> CmmExpr
-> 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
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")
tickyTagged :: FCode ()
tickyTagged = ifTickyTag $ bumpTickyCounter (fsLit "TAG_TAGGED_pred")
tickyUntagged :: CmmExpr -> FCode ()
tickyUntagged e = do
ifTickyTag $ bumpTickyCounter (fsLit "TAG_UNTAGGED_pred")
ifTickyTag $ bumpTickyCounterByE (fsLit "TAG_UNTAGGED_miss") e
tickyTagSkip :: Unique -> Id -> FCode ()
tickyTagSkip unique id = ifTickyTag $ do
let ctr_lbl = mkTagHitLabel (idName id) unique
registerTickyCtr ctr_lbl
bumpTickyTagSkip ctr_lbl
isEnabled :: (StgToCmmConfig -> Bool) -> FCode Bool
isEnabled = flip fmap getStgToCmmConfig
runIfFlag :: (StgToCmmConfig -> Bool) -> FCode () -> FCode ()
runIfFlag f = whenM (f <$> getStgToCmmConfig)
ifTicky :: FCode () -> FCode ()
ifTicky = runIfFlag stgToCmmDoTicky
ifTickyTag :: FCode () -> FCode ()
ifTickyTag = runIfFlag stgToCmmTickyTag
ifTickyAllocd :: FCode () -> FCode ()
ifTickyAllocd = runIfFlag stgToCmmTickyAllocd
ifTickyLNE :: FCode () -> FCode ()
ifTickyLNE = runIfFlag stgToCmmTickyLNE
ifTickyDynThunk :: FCode () -> FCode ()
ifTickyDynThunk = runIfFlag stgToCmmTickyDynThunk
bumpTickyCounter :: FastString -> FCode ()
bumpTickyCounter = bumpTickyLbl . mkRtsCmmDataLabel
bumpTickyCounterBy :: FastString -> Int -> FCode ()
bumpTickyCounterBy = bumpTickyLblBy . mkRtsCmmDataLabel
bumpTickyCounterByE :: FastString -> CmmExpr -> FCode ()
bumpTickyCounterByE lbl = bumpTickyLblByE (mkRtsCmmDataLabel lbl)
bumpTickyEntryCount :: CLabel -> FCode ()
bumpTickyEntryCount lbl = do
platform <- getPlatform
bumpTickyLit (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform)))
bumpTickyAllocd :: CLabel -> Int -> FCode ()
bumpTickyAllocd lbl bytes = do
platform <- getPlatform
bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) bytes
bumpTickyTagSkip :: CLabel -> FCode ()
bumpTickyTagSkip lbl = do
platform <- getPlatform
bumpTickyLitBy (cmmLabelOffB lbl (pc_OFFSET_StgEntCounter_entry_count (platformConstants platform))) 1
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
platform <- getPlatform
emit (addToMem (bWord platform) (CmmLit lhs) n)
bumpTickyLitByE :: CmmLit -> CmmExpr -> FCode ()
bumpTickyLitByE lhs e = do
platform <- getPlatform
emit (addToMemE (bWord platform) (CmmLit lhs) e)
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram lbl n = do
platform <- getPlatform
let offset = n `min` (pc_TICKY_BIN_COUNT (platformConstants platform) 1)
emit (addToMem (bWord platform)
(cmmIndexExpr platform
(wordWidth platform)
(CmmLit (CmmLabel (mkRtsCmmDataLabel lbl)))
(CmmLit (CmmInt (fromIntegral offset) (wordWidth platform))))
1)
showTypeCategory :: Type -> Char
showTypeCategory ty
| isDictTy ty = '+'
| otherwise = case tcSplitTyConApp_maybe ty of
Nothing -> '.'
Just (tycon, _) ->
let anyOf us = getUnique tycon `elem` us in
case () of
_ | anyOf [funTyConKey] -> '>'
| anyOf [charTyConKey] -> 'C'
| anyOf [charPrimTyConKey] -> 'c'
| anyOf [doubleTyConKey] -> 'D'
| anyOf [doublePrimTyConKey] -> 'd'
| anyOf [floatTyConKey] -> 'F'
| anyOf [floatPrimTyConKey] -> 'f'
| anyOf [intTyConKey, int8TyConKey, int16TyConKey, int32TyConKey, int64TyConKey] -> 'I'
| anyOf [intPrimTyConKey, int8PrimTyConKey, int16PrimTyConKey, int32PrimTyConKey, int64PrimTyConKey] -> 'i'
| anyOf [wordTyConKey, word8TyConKey, word16TyConKey, word32TyConKey, word64TyConKey] -> 'W'
| anyOf [wordPrimTyConKey, word8PrimTyConKey, word16PrimTyConKey, word32PrimTyConKey, word64PrimTyConKey] -> 'w'
| anyOf [listTyConKey] -> 'L'
| isUnboxedTupleTyCon tycon -> 't'
| isTupleTyCon tycon -> 'T'
| isPrimTyCon tycon -> 'P'
| isEnumerationTyCon tycon -> 'E'
| isJust (tyConSingleDataCon_maybe tycon) -> 'S'
| otherwise -> 'M'