module StgCmmTicky (
withNewTickyCounterFun,
withNewTickyCounterLNE,
withNewTickyCounterThunk,
withNewTickyCounterStdThunk,
withNewTickyCounterCon,
tickyDynAlloc,
tickyAllocHeap,
tickyAllocPrim,
tickyAllocThunk,
tickyAllocPAP,
tickyHeapCheck,
tickyStackCheck,
tickyUnknownCall, tickyDirectCall,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
tickyEnterStaticCon,
tickyEnterViaNode,
tickyEnterFun,
tickyEnterThunk, tickyEnterStdThunk,
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
import PrelNames
import TcType
import Type
import TyCon
import Data.Maybe
import qualified Data.Char
import Control.Monad ( unless, when )
data TickyClosureType
= TickyFun
Bool
| TickyCon
| TickyThunk
Bool
Bool
| 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
withNewTickyCounterThunk
:: Bool
-> Bool
-> Name
-> FCode a
-> FCode a
withNewTickyCounterThunk isStatic isUpdatable name code = do
b <- tickyDynThunkIsOn
if isStatic || not b
then code
else withNewTickyCounter (TickyThunk isUpdatable False) name [] code
withNewTickyCounterStdThunk
:: Bool
-> Name
-> FCode a
-> FCode a
withNewTickyCounterStdThunk isUpdatable name code = do
b <- tickyDynThunkIsOn
if not b
then code
else withNewTickyCounter (TickyThunk isUpdatable True) name [] code
withNewTickyCounterCon
:: Name
-> FCode a
-> FCode a
withNewTickyCounterCon name code = do
b <- tickyDynThunkIsOn
if not b
then code
else withNewTickyCounter TickyCon name [] code
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
; 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
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
[ mkIntCLit dflags 0,
mkIntCLit dflags (length args),
mkIntCLit dflags 0,
fun_descr_lit,
arg_descr_lit,
zeroCLit dflags,
zeroCLit dflags,
zeroCLit dflags
]
}
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
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
; unless static $ 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 -> 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
registerTickyCtrAtEntryDyn :: CLabel -> FCode ()
registerTickyCtrAtEntryDyn ctr_lbl = do
already_registered <- tickyAllocdIsOn
when (not already_registered) $ registerTickyCtr ctr_lbl
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr ctr_lbl = do
dflags <- getDynFlags
let
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 }
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 $
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"
tickyDynAlloc :: Maybe Id -> SMRep -> LambdaFormInfo -> FCode ()
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
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 ->
VirtualHpOffset -> FCode ()
tickyAllocHeap genuine hp
= ifTicky $
do { dflags <- getDynFlags
; ticky_ctr <- getTickyCtrLabel
; emit $ catAGraphs $
if hp == 0 then []
else let !bytes = wORD_SIZE dflags * hp in [
addToMem (rEP_StgEntCounter_allocs dflags)
(CmmLit (cmmLabelOffB ticky_ctr (oFFSET_StgEntCounter_allocs dflags)))
bytes,
addToMemLbl (bWord dflags)
(mkCmmDataLabel rtsUnitId (fsLit "ALLOC_HEAP_tot"))
bytes,
if not genuine then mkNop
else addToMemLbl (bWord dflags)
(mkCmmDataLabel rtsUnitId (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")
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)
showTypeCategory :: Type -> Char
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'