module StgCmmProf (
initCostCentres, ccType, ccsType,
mkCCostCentre, mkCCostCentreStack,
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentre, enterCostCentrePAP, enterCostCentreThunk,
chooseDynCostCentres,
costCentreFrom,
curCCS, curCCSAddr,
emitSetCCC, emitCCS,
saveCurrentCostCentre, restoreCurrentCostCentre,
ldvEnter, ldvEnterClosure, ldvRecordCreate
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
#include "../includes/rts/Constants.h"
#include "../includes/DerivedConstants.h"
import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
import SMRep
import MkZipCfgCmm
import Cmm
import CmmUtils
import CLabel
import Id
import qualified Module
import CostCentre
import StgSyn
import StaticFlags
import FastString
import Module
import Constants
import Outputable
import Data.Char
import Control.Monad
ccsType :: CmmType
ccsType = bWord
ccType :: CmmType
ccType = bWord
curCCS :: CmmExpr
curCCS = CmmLoad curCCSAddr ccsType
curCCSAddr :: CmmExpr
curCCSAddr = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCCS")))
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc = CmmLabel (mkCCLabel cc)
mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack ccs = CmmLabel (mkCCSLabel ccs)
costCentreFrom :: CmmExpr
-> CmmExpr
costCentreFrom cl = CmmLoad (cmmOffsetB cl oFFSET_StgHeader_ccs) ccsType
staticProfHdr :: CostCentreStack -> [CmmLit]
staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
staticLdvInit]
dynProfHdr :: CmmExpr -> [CmmExpr]
dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf frame_amode
= ifProfiling $
emit (mkStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
saveCurrentCostCentre :: FCode (Maybe LocalReg)
saveCurrentCostCentre
| not opt_SccProfilingOn
= return Nothing
| otherwise
= do { local_cc <- newTemp ccType
; emit (mkAssign (CmmLocal local_cc) curCCS)
; return (Just local_cc) }
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Nothing
= return ()
restoreCurrentCostCentre (Just local_cc)
= emit (mkStore curCCSAddr (CmmReg (CmmLocal local_cc)))
profDynAlloc :: ClosureInfo -> CmmExpr -> FCode ()
profDynAlloc cl_info ccs
= ifProfiling $
profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc words ccs
= ifProfiling $
emit (addToMemE alloc_rep
(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
(CmmMachOp (MO_UU_Conv wordWidth (typeWidth alloc_rep)) $
[CmmMachOp mo_wordSub [words,
CmmLit (mkIntCLit profHdrSize)]]))
where
alloc_rep = REP_CostCentreStack_mem_alloc
chooseDynCostCentres :: CostCentreStack
-> [Id]
-> StgExpr
-> FCode (CmmExpr, CmmExpr)
chooseDynCostCentres ccs args body = do
use_ccs <- emitCCS ccs
let blame_ccs
| null args && isBox body = CmmLit (mkCCostCentreStack overheadCCS)
| otherwise = use_ccs
return (use_ccs, blame_ccs)
emitCCS :: CostCentreStack -> FCode CmmExpr
emitCCS ccs = push_em (ccsExpr ccs') (reverse cc's)
where
(cc's, ccs') = decomposeCCS ccs
push_em ccs [] = return ccs
push_em ccs (cc:rest) = do
tmp <- newTemp ccsType
pushCostCentre tmp ccs cc
push_em (CmmReg (CmmLocal tmp)) rest
ccsExpr :: CostCentreStack -> CmmExpr
ccsExpr ccs
| isCurrentCCS ccs = curCCS
| otherwise = CmmLit (mkCCostCentreStack ccs)
isBox :: StgExpr -> Bool
isBox (StgApp _ []) = True
isBox _ = False
enterCostCentre
:: ClosureInfo
-> CostCentreStack
-> StgExpr
-> FCode ()
enterCostCentre closure_info ccs body
= ifProfiling $
ASSERT2(not (noCCSAttached ccs), ppr (closureName closure_info) <+> ppr ccs)
enter_cost_centre closure_info ccs body
enter_cost_centre :: ClosureInfo -> CostCentreStack -> StgExpr -> FCode ()
enter_cost_centre closure_info ccs body
| isSubsumedCCS ccs
= ASSERT(isToplevClosure closure_info)
ASSERT(re_entrant)
enter_ccs_fsub
| isDerivedFromCurrentCCS ccs
= do {
if re_entrant && not is_box
then
enter_ccs_fun node_ccs
else
emit (mkStore curCCSAddr node_ccs)
; when (not (isCurrentCCS ccs)) $
emit (bumpSccCount curCCS)
}
| isCafCCS ccs
= ASSERT(isToplevClosure closure_info)
ASSERT(not re_entrant)
do {
emit (mkStore curCCSAddr enc_ccs)
; emit (bumpSccCount node_ccs)
}
| otherwise
= panic "enterCostCentre"
where
enc_ccs = CmmLit (mkCCostCentreStack ccs)
re_entrant = closureReEntrant closure_info
node_ccs = costCentreFrom (cmmOffsetB (CmmReg nodeReg) (node_tag))
is_box = isBox body
node_tag = funTag closure_info
enterCostCentrePAP :: CmmExpr -> FCode ()
enterCostCentrePAP closure =
ifProfiling $ do
enter_ccs_fun (costCentreFrom closure)
enteringPAP 1
enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk closure =
ifProfiling $ do
emit $ mkStore curCCSAddr (costCentreFrom closure)
enter_ccs_fun :: CmmExpr -> FCode ()
enter_ccs_fun stack = emitRtsCall rtsPackageId (fsLit "EnterFunCCS") [(stack,AddrHint)] False
enter_ccs_fsub :: FCode ()
enter_ccs_fsub = enteringPAP 0
enteringPAP :: Integer -> FCode ()
enteringPAP n
= emit (mkStore (CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "entering_PAP"))))
(CmmLit (CmmInt n cIntWidth)))
ifProfiling :: FCode () -> FCode ()
ifProfiling code
| opt_SccProfilingOn = code
| otherwise = nopC
ifProfilingL :: [a] -> [a]
ifProfilingL xs
| opt_SccProfilingOn = xs
| otherwise = []
initCostCentres :: CollectedCCs -> FCode CmmAGraph
initCostCentres (local_CCs, ___extern_CCs, singleton_CCSs)
= getCode $ whenC opt_SccProfilingOn $
do { mapM_ emitCostCentreDecl local_CCs
; mapM_ emitCostCentreStackDecl singleton_CCSs
; emit $ catAGraphs $ map mkRegisterCC local_CCs
; emit $ catAGraphs $ map mkRegisterCCS singleton_CCSs }
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc = do
{ label <- mkStringCLit (costCentreUserName cc)
; modl <- mkStringCLit (Module.moduleNameString
(Module.moduleName (cc_mod cc)))
; let lits = [ zero,
label,
modl,
zero,
zero64,
subsumed,
zero
]
; emitDataLits (mkCCLabel cc) lits
}
where
subsumed | isCafCC cc = mkIntCLit (ord 'c')
| otherwise = mkIntCLit (ord 'B')
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs
= case maybeSingletonCCS ccs of
Just cc -> emitDataLits (mkCCSLabel ccs) (mk_lits cc)
Nothing -> pprPanic "emitCostCentreStackDecl" (ppr ccs)
where
mk_lits cc = zero :
mkCCostCentre cc :
replicate (sizeof_ccs_words 2) zero
zero :: CmmLit
zero = mkIntCLit 0
zero64 :: CmmLit
zero64 = CmmInt 0 W64
sizeof_ccs_words :: Int
sizeof_ccs_words
| ms == 0 = ws
| otherwise = ws + 1
where
(ws,ms) = SIZEOF_CostCentreStack `divMod` wORD_SIZE
mkRegisterCC :: CostCentre -> CmmAGraph
mkRegisterCC cc
= withTemp cInt $ \tmp ->
catAGraphs [
mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_link)
(CmmLoad cC_LIST bWord),
mkStore cC_LIST cc_lit,
mkAssign (CmmLocal tmp) (CmmLoad cC_ID cInt),
mkStore (cmmOffsetB cc_lit oFFSET_CostCentre_ccID) (CmmReg (CmmLocal tmp)),
mkStore cC_ID (cmmRegOffB (CmmLocal tmp) 1)
]
where
cc_lit = CmmLit (CmmLabel (mkCCLabel cc))
mkRegisterCCS :: CostCentreStack -> CmmAGraph
mkRegisterCCS ccs
= withTemp cInt $ \ tmp ->
catAGraphs [
mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_prevStack)
(CmmLoad cCS_LIST bWord),
mkStore cCS_LIST ccs_lit,
mkAssign (CmmLocal tmp) (CmmLoad cCS_ID cInt),
mkStore (cmmOffsetB ccs_lit oFFSET_CostCentreStack_ccsID) (CmmReg (CmmLocal tmp)),
mkStore cCS_ID (cmmRegOffB (CmmLocal tmp) 1)
]
where
ccs_lit = CmmLit (CmmLabel (mkCCSLabel ccs))
cC_LIST, cC_ID :: CmmExpr
cC_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_LIST")))
cC_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CC_ID")))
cCS_LIST, cCS_ID :: CmmExpr
cCS_LIST = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_LIST")))
cCS_ID = CmmLit (CmmLabel (mkCmmDataLabel rtsPackageId (fsLit "CCS_ID")))
emitSetCCC :: CostCentre -> FCode ()
emitSetCCC cc
| not opt_SccProfilingOn = nopC
| otherwise = do
tmp <- newTemp ccsType
ASSERT( sccAbleCostCentre cc )
pushCostCentre tmp curCCS cc
emit (mkStore curCCSAddr (CmmReg (CmmLocal tmp)))
when (isSccCountCostCentre cc) $
emit (bumpSccCount curCCS)
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
rtsPackageId
(fsLit "PushCostCentre") [(ccs,AddrHint),
(CmmLit (mkCCostCentre cc), AddrHint)]
False
bumpSccCount :: CmmExpr -> CmmAGraph
bumpSccCount ccs
= addToMem REP_CostCentreStack_scc_count
(cmmOffsetB ccs oFFSET_CostCentreStack_scc_count) 1
staticLdvInit :: CmmLit
staticLdvInit = zeroCLit
dynLdvInit :: CmmExpr
dynLdvInit =
CmmMachOp mo_wordOr [
CmmMachOp mo_wordShl [loadEra, CmmLit (mkIntCLit lDV_SHIFT) ],
CmmLit (mkWordCLit lDV_STATE_CREATE)
]
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure = emit $ mkStore (ldvWord closure) dynLdvInit
ldvEnterClosure :: ClosureInfo -> FCode ()
ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (tag))
where tag = funTag closure_info
ldvEnter :: CmmExpr -> FCode ()
ldvEnter cl_ptr
= ifProfiling $
emit (mkCmmIfThenElse (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
(mkStore ldv_wd new_ldv_wd)
mkNop)
where
ldv_wd = ldvWord cl_ptr
new_ldv_wd = cmmOrWord (cmmAndWord (CmmLoad ldv_wd bWord)
(CmmLit (mkWordCLit lDV_CREATE_MASK)))
(cmmOrWord loadEra (CmmLit (mkWordCLit lDV_STATE_USE)))
loadEra :: CmmExpr
loadEra = CmmMachOp (MO_UU_Conv cIntWidth wordWidth)
[CmmLoad (mkLblExpr (mkCmmDataLabel rtsPackageId (fsLit "era"))) cInt]
ldvWord :: CmmExpr -> CmmExpr
ldvWord closure_ptr = cmmOffsetB closure_ptr oFFSET_StgHeader_ldvw
lDV_SHIFT :: Int
lDV_SHIFT = LDV_SHIFT
lDV_CREATE_MASK :: StgWord
lDV_CREATE_MASK = LDV_CREATE_MASK
lDV_STATE_CREATE :: StgWord
lDV_STATE_CREATE = LDV_STATE_CREATE
lDV_STATE_USE :: StgWord
lDV_STATE_USE = LDV_STATE_USE