module StgCmmTicky (
emitTickyCounter,
tickyDynAlloc,
tickyAllocHeap,
tickyAllocPrim,
tickyAllocThunk,
tickyAllocPAP,
tickySlowCall, tickyDirectCall,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
tickyEnterStaticCon,
tickyEnterViaNode,
tickyEnterFun,
tickyEnterThunk,
tickyUpdateBhCaf,
tickyBlackHole,
tickyUnboxedTupleReturn, tickyVectoredReturn,
tickyReturnOldCon, tickyReturnNewCon,
tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
tickyUnknownCall, tickySlowCallPat,
staticTickyHdr,
) where
#include "HsVersions.h"
#include "../includes/DerivedConstants.h"
import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
import SMRep
import StgSyn
import Cmm
import MkZipCfgCmm
import CmmUtils
import CLabel
import Module
import Name
import Id
import BasicTypes
import FastString
import Constants
import Outputable
import DynFlags
import PrelNames
import TcType
import TyCon
import Data.Maybe
staticTickyHdr :: [CmmLit]
staticTickyHdr = []
emitTickyCounter :: ClosureInfo -> [Id] -> FCode ()
emitTickyCounter cl_info args
= ifTicky $
do { mod_name <- getModuleName
; fun_descr_lit <- mkStringCLit (fun_descr mod_name)
; arg_descr_lit <- mkStringCLit arg_descr
; emitDataLits ticky_ctr_label
[ mkIntCLit 0,
mkIntCLit (length args),
mkIntCLit 0,
fun_descr_lit,
arg_descr_lit,
zeroCLit,
zeroCLit,
zeroCLit
] }
where
name = closureName cl_info
ticky_ctr_label = mkRednCountsLabel name $ clHasCafRefs cl_info
arg_descr = map (showTypeCategory . idType) args
fun_descr mod_name = ppr_for_ticky_name mod_name name
ppr_for_ticky_name :: Module -> Name -> String
ppr_for_ticky_name mod_name name
| isInternalName name = showSDocDebug (ppr name <+> (parens (ppr mod_name)))
| otherwise = showSDocDebug (ppr name)
tickyPushUpdateFrame, tickyUpdateFrameOmitted :: FCode ()
tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
tickyEnterStaticThunk, tickyEnterViaNode :: FCode ()
tickyEnterDynCon = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_CON_ctr")
tickyEnterDynThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_DYN_THK_ctr")
tickyEnterStaticCon = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_CON_ctr")
tickyEnterStaticThunk = ifTicky $ bumpTickyCounter (fsLit "ENT_STATIC_THK_ctr")
tickyEnterViaNode = ifTicky $ bumpTickyCounter (fsLit "ENT_VIA_NODE_ctr")
tickyEnterThunk :: ClosureInfo -> FCode ()
tickyEnterThunk cl_info
| isStaticClosure cl_info = tickyEnterStaticThunk
| otherwise = tickyEnterDynThunk
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 { bumpTickyCounter ctr
; fun_ctr_lbl <- getTickyCtrLabel
; registerTickyCtr fun_ctr_lbl
; bumpTickyCounter' (cmmLabelOffB fun_ctr_lbl oFFSET_StgEntCounter_entry_count)
}
where
ctr | isStaticClosure cl_info = (fsLit "ENT_STATIC_FUN_DIRECT_ctr")
| otherwise = (fsLit "ENT_DYN_FUN_DIRECT_ctr")
registerTickyCtr :: CLabel -> FCode ()
registerTickyCtr ctr_lbl
= emit (mkCmmIfThen test (catAGraphs register_stmts))
where
test = CmmMachOp (MO_Eq wordWidth)
[CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp)) bWord,
CmmLit (mkIntCLit 0)]
register_stmts
= [ mkStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
(CmmLoad ticky_entry_ctrs bWord)
, mkStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
, mkStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> 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 :: Int -> FCode ()
tickyUnboxedTupleReturn arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
tickyVectoredReturn :: Int -> FCode ()
tickyVectoredReturn family_size
= ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
tickyDirectCall :: Arity -> [StgArg] -> FCode ()
tickyDirectCall arity args
| arity == length args = 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 = return ()
tickyDynAlloc :: ClosureInfo -> FCode ()
tickyDynAlloc cl_info
= ifTicky $
case smRepClosureType (closureSMRep cl_info) of
Just Constr -> tick_alloc_con
Just ConstrNoCaf -> tick_alloc_con
Just Fun -> tick_alloc_fun
Just Thunk -> tick_alloc_thk
Just ThunkSelector -> tick_alloc_thk
Nothing -> return ()
where
_cl_size = closureSize cl_info
_slop_size = slopSize cl_info
tick_alloc_thk
| closureUpdReqd cl_info = tick_alloc_up_thk
| otherwise = tick_alloc_se_thk
tick_alloc_con = return ()
tick_alloc_fun = return ()
tick_alloc_up_thk = return ()
tick_alloc_se_thk = return ()
tickyAllocPrim :: CmmExpr -> CmmExpr -> CmmExpr -> FCode ()
tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
tickyAllocThunk :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
tickyAllocPAP :: CmmExpr -> CmmExpr -> FCode ()
tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
tickyAllocHeap :: VirtualHpOffset -> FCode ()
tickyAllocHeap hp
= ifTicky $
do { ticky_ctr <- getTickyCtrLabel
; emit $ catAGraphs $
if hp == 0 then []
else [
addToMem REP_StgEntCounter_allocs
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_ctr")) 1,
addToMemLbl cLong (mkCmmDataLabel rtsPackageId (fsLit "ALLOC_HEAP_tot")) hp] }
ifTicky :: FCode () -> FCode ()
ifTicky code = do dflags <- getDynFlags
if doingTickyProfiling dflags then code
else nopC
bumpTickyCounter :: FastString -> FCode ()
bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
bumpTickyCounter' :: CmmLit -> FCode ()
bumpTickyCounter' lhs = emit (addToMem cLong (CmmLit lhs) 1)
bumpHistogram :: FastString -> Int -> FCode ()
bumpHistogram _lbl _n
= return ()
showTypeCategory :: Type -> Char
showTypeCategory ty
= if isDictTy ty
then '+'
else
case tcSplitTyConApp_maybe ty of
Nothing -> if isJust (tcSplitFunTy_maybe ty)
then '>'
else '.'
Just (tycon, _) ->
let utc = getUnique tycon in
if utc == charDataConKey then 'C'
else if utc == intDataConKey then 'I'
else if utc == floatDataConKey then 'F'
else if utc == doubleDataConKey then 'D'
else if utc == charPrimTyConKey then 'c'
else if (utc == intPrimTyConKey || utc == wordPrimTyConKey
|| utc == addrPrimTyConKey) then 'i'
else if utc == floatPrimTyConKey then 'f'
else if utc == doublePrimTyConKey then 'd'
else if isPrimTyCon tycon then 'A'
else if isEnumerationTyCon tycon then 'E'
else if isTupleTyCon tycon then 'T'
else if isJust (tyConSingleDataCon_maybe tycon) then 'S'
else if utc == listTyConKey then 'L'
else 'M'