module CgTicky (
emitTickyCounter,
tickyDynAlloc,
tickyAllocHeap,
tickyAllocPrim,
tickyAllocThunk,
tickyAllocPAP,
tickyPushUpdateFrame,
tickyUpdateFrameOmitted,
tickyEnterDynCon,
tickyEnterStaticCon,
tickyEnterViaNode,
tickyEnterFun,
tickyEnterThunk,
tickyUpdateBhCaf,
tickyBlackHole,
tickyUnboxedTupleReturn, tickyVectoredReturn,
tickyReturnOldCon, tickyReturnNewCon,
tickyKnownCallTooFewArgs, tickyKnownCallExact, tickyKnownCallExtraArgs,
tickyUnknownCall, tickySlowCallPat,
staticTickyHdr,
) where
#include "../includes/DerivedConstants.h"
import ClosureInfo
import CgUtils
import CgMonad
import SMRep
import Cmm
import CmmUtils
import CLabel
import Name
import Id
import IdInfo
import BasicTypes
import FastString
import Constants
import Outputable
import Module
import PrelNames
import TcType
import TyCon
import DynFlags
import Data.Maybe
staticTickyHdr :: [CmmLit]
staticTickyHdr = []
emitTickyCounter :: ClosureInfo -> [Id] -> Int -> Code
emitTickyCounter cl_info args on_stk
= 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 on_stk,
fun_descr_lit,
arg_descr_lit,
zeroCLit,
zeroCLit,
zeroCLit
] }
where
name = closureName cl_info
ticky_ctr_label = mkRednCountsLabel name NoCafRefs
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 :: Code
tickyPushUpdateFrame = ifTicky $ bumpTickyCounter (fsLit "UPDF_PUSHED_ctr")
tickyUpdateFrameOmitted = ifTicky $ bumpTickyCounter (fsLit "UPDF_OMITTED_ctr")
tickyEnterDynCon, tickyEnterDynThunk, tickyEnterStaticCon,
tickyEnterStaticThunk, tickyEnterViaNode :: Code
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 -> Code
tickyEnterThunk cl_info
| isStaticClosure cl_info = tickyEnterStaticThunk
| otherwise = tickyEnterDynThunk
tickyBlackHole :: Bool -> Code
tickyBlackHole updatable
= ifTicky (bumpTickyCounter ctr)
where
ctr | updatable = fsLit "UPD_BH_SINGLE_ENTRY_ctr"
| otherwise = fsLit "UPD_BH_UPDATABLE_ctr"
tickyUpdateBhCaf :: ClosureInfo -> Code
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 -> Code
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 -> Code
registerTickyCtr ctr_lbl
= emitIf test (stmtsC register_stmts)
where
test = CmmMachOp (MO_Eq wordWidth)
[CmmLoad (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp)) bWord,
CmmLit (mkIntCLit 0)]
register_stmts
= [ CmmStore (CmmLit (cmmLabelOffB ctr_lbl oFFSET_StgEntCounter_link))
(CmmLoad ticky_entry_ctrs bWord)
, CmmStore ticky_entry_ctrs (mkLblExpr ctr_lbl)
, CmmStore (CmmLit (cmmLabelOffB ctr_lbl
oFFSET_StgEntCounter_registeredp))
(CmmLit (mkIntCLit 1)) ]
ticky_entry_ctrs = mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "ticky_entry_ctrs"))
tickyReturnOldCon, tickyReturnNewCon :: Arity -> Code
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 -> Code
tickyUnboxedTupleReturn arity
= ifTicky $ do { bumpTickyCounter (fsLit "RET_UNBOXED_TUP_ctr")
; bumpHistogram (fsLit "RET_UNBOXED_TUP_hst") arity }
tickyVectoredReturn :: Int -> Code
tickyVectoredReturn family_size
= ifTicky $ do { bumpTickyCounter (fsLit "VEC_RETURN_ctr")
; bumpHistogram (fsLit "RET_VEC_RETURN_hst") family_size }
tickyKnownCallTooFewArgs, tickyKnownCallExact,
tickyKnownCallExtraArgs, tickyUnknownCall :: Code
tickyKnownCallTooFewArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_TOO_FEW_ARGS_ctr")
tickyKnownCallExact = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_ctr")
tickyKnownCallExtraArgs = ifTicky $ bumpTickyCounter (fsLit "KNOWN_CALL_EXTRA_ARGS_ctr")
tickyUnknownCall = ifTicky $ bumpTickyCounter (fsLit "UNKNOWN_CALL_ctr")
tickySlowCallPat :: [CgRep] -> Code
tickySlowCallPat _args = return ()
tickyDynAlloc :: ClosureInfo -> Code
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 -> Code
tickyAllocPrim _hdr _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPrim" empty (return ())
tickyAllocThunk :: CmmExpr -> CmmExpr -> Code
tickyAllocThunk _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocThunk" empty (return ())
tickyAllocPAP :: CmmExpr -> CmmExpr -> Code
tickyAllocPAP _goods _slop = ifTicky $ pprTrace "ToDo: tickyAllocPAP" empty (return ())
tickyAllocHeap :: VirtualHpOffset -> Code
tickyAllocHeap hp
= ifTicky $
do { ticky_ctr <- getTickyCtrLabel
; stmtsC $
if hp == 0 then []
else [
addToMem (typeWidth REP_StgEntCounter_allocs)
(CmmLit (cmmLabelOffB ticky_ctr
oFFSET_StgEntCounter_allocs)) hp,
addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_ctr") 1,
addToMemLbl cLongWidth (mkCmmDataLabel rtsPackageId $ fsLit "ALLOC_HEAP_tot") hp] }
ifTicky :: Code -> Code
ifTicky code = do dflags <- getDynFlags
if doingTickyProfiling dflags then code
else nopC
addToMemLbl :: Width -> CLabel -> Int -> CmmStmt
addToMemLbl rep lbl n = addToMem rep (CmmLit (CmmLabel lbl)) n
bumpTickyCounter :: FastString -> Code
bumpTickyCounter lbl = bumpTickyCounter' (cmmLabelOffB (mkCmmDataLabel rtsPackageId lbl) 0)
bumpTickyCounter' :: CmmLit -> Code
bumpTickyCounter' lhs = stmtC (addToMemLong (CmmLit lhs) 1)
bumpHistogram :: FastString -> Int -> Code
bumpHistogram _lbl _n
= return ()
addToMemLong :: CmmExpr -> Int -> CmmStmt
addToMemLong = addToMem cLongWidth
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'