module CgProf (
mkCCostCentre, mkCCostCentreStack,
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentreThunk,
enterCostCentreFun,
costCentreFrom,
curCCS, storeCurCCS,
emitCostCentreDecl, emitCostCentreStackDecl,
emitSetCCC,
ldvEnter, ldvEnterClosure, ldvRecordCreate
) where
#include "HsVersions.h"
#include "../includes/MachDeps.h"
#include "../includes/rts/Constants.h"
#include "../includes/dist-derivedconstants/header/DerivedConstants.h"
import ClosureInfo
import CgUtils
import CgMonad
import SMRep
import OldCmm
import OldCmmUtils
import CLabel
import qualified Module
import CostCentre
import StaticFlags
import FastString
import Module
import Constants
import Outputable
import Data.Char
import Control.Monad
curCCS :: CmmExpr
curCCS = CmmReg (CmmGlobal CCCS)
storeCurCCS :: CmmExpr -> CmmStmt
storeCurCCS e = CmmAssign (CmmGlobal CCCS) e
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) bWord
staticProfHdr :: CostCentreStack -> [CmmLit]
staticProfHdr ccs = ifProfilingL [mkCCostCentreStack ccs,
staticLdvInit]
dynProfHdr :: CmmExpr -> [CmmExpr]
dynProfHdr ccs = ifProfilingL [ccs, dynLdvInit]
initUpdFrameProf :: CmmExpr -> Code
initUpdFrameProf frame_amode
= ifProfiling $
stmtC (CmmStore (cmmOffsetB frame_amode oFFSET_StgHeader_ccs) curCCS)
profDynAlloc :: ClosureInfo -> CmmExpr -> Code
profDynAlloc cl_info ccs
= ifProfiling $
profAlloc (CmmLit (mkIntCLit (closureSize cl_info))) ccs
profAlloc :: CmmExpr -> CmmExpr -> Code
profAlloc words ccs
= ifProfiling $
stmtC (addToMemE alloc_rep
(cmmOffsetB ccs oFFSET_CostCentreStack_mem_alloc)
(CmmMachOp (MO_UU_Conv wordWidth alloc_rep) $
[CmmMachOp mo_wordSub [words,
CmmLit (mkIntCLit profHdrSize)]]))
where
alloc_rep = typeWidth REP_CostCentreStack_mem_alloc
enterCostCentreThunk :: CmmExpr -> Code
enterCostCentreThunk closure =
ifProfiling $ do
stmtC $ storeCurCCS (costCentreFrom closure)
enterCostCentreFun :: CostCentreStack -> CmmExpr -> [GlobalReg] -> Code
enterCostCentreFun ccs closure vols =
ifProfiling $ do
if isCurrentCCS ccs
then emitRtsCallWithVols rtsPackageId (fsLit "enterFunCCS")
[CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint,
CmmHinted (costCentreFrom closure) AddrHint] vols
else return ()
ifProfiling :: Code -> Code
ifProfiling code
| opt_SccProfilingOn = code
| otherwise = nopC
ifProfilingL :: [a] -> [a]
ifProfilingL xs
| opt_SccProfilingOn = xs
| otherwise = []
emitCostCentreDecl
:: CostCentre
-> Code
emitCostCentreDecl cc = do
{ label <- newByteStringCLit (bytesFS $ costCentreUserNameFS cc)
; modl <- newByteStringCLit (bytesFS $ Module.moduleNameFS
$ Module.moduleName
$ cc_mod cc)
; dflags <- getDynFlags
; loc <- newByteStringCLit $ bytesFS $ mkFastString $
showPpr dflags (costCentreSrcSpan cc)
; let
lits = [ zero,
label,
modl,
loc,
zero64,
zero,
is_caf,
zero
]
; emitDataLits (mkCCLabel cc) lits
}
where
is_caf | isCafCC cc = mkIntCLit (ord 'c')
| otherwise = zero
emitCostCentreStackDecl
:: CostCentreStack
-> Code
emitCostCentreStackDecl ccs
| Just cc <- maybeSingletonCCS ccs = do
{ let
lits = zero : mkCCostCentre cc : replicate (sizeof_ccs_words 2) zero
; emitDataLits (mkCCSLabel ccs) lits
}
| otherwise = pprPanic "emitCostCentreStackDecl" (ppr ccs)
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
emitSetCCC :: CostCentre -> Bool -> Bool -> Code
emitSetCCC cc tick push
| not opt_SccProfilingOn = nopC
| otherwise = do
tmp <- newTemp bWord
pushCostCentre tmp curCCS cc
when tick $ stmtC (bumpSccCount (CmmReg (CmmLocal tmp)))
when push $ stmtC (storeCurCCS (CmmReg (CmmLocal tmp)))
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> Code
pushCostCentre result ccs cc
= emitRtsCallWithResult result AddrHint
rtsPackageId
(fsLit "pushCostCentre") [CmmHinted ccs AddrHint,
CmmHinted (CmmLit (mkCCostCentre cc)) AddrHint]
bumpSccCount :: CmmExpr -> CmmStmt
bumpSccCount ccs
= addToMem (typeWidth 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 -> Code
ldvRecordCreate closure = stmtC $ CmmStore (ldvWord closure) dynLdvInit
ldvEnterClosure :: ClosureInfo -> Code
ldvEnterClosure closure_info = ldvEnter (cmmOffsetB (CmmReg nodeReg) (tag))
where tag = funTag closure_info
ldvEnter :: CmmExpr -> Code
ldvEnter cl_ptr
= ifProfiling $
emitIf (CmmMachOp mo_wordUGt [loadEra, CmmLit zeroCLit])
(stmtC (CmmStore ldv_wd new_ldv_wd))
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