module StgCmmProf (
initCostCentres, ccType, ccsType,
mkCCostCentre, mkCCostCentreStack,
dynProfHdr, profDynAlloc, profAlloc, staticProfHdr, initUpdFrameProf,
enterCostCentreThunk, enterCostCentreFun,
costCentreFrom,
storeCurCCS,
emitSetCCC,
saveCurrentCostCentre, restoreCurrentCostCentre,
ldvEnter, ldvEnterClosure, ldvRecordCreate
) where
import GhcPrelude
import StgCmmClosure
import StgCmmUtils
import StgCmmMonad
import SMRep
import MkGraph
import Cmm
import CmmUtils
import CLabel
import CostCentre
import DynFlags
import FastString
import Module
import Outputable
import Control.Monad
import Data.Char (ord)
ccsType :: DynFlags -> CmmType
ccsType :: DynFlags -> CmmType
ccsType = DynFlags -> CmmType
bWord
ccType :: DynFlags -> CmmType
ccType :: DynFlags -> CmmType
ccType = DynFlags -> CmmType
bWord
storeCurCCS :: CmmExpr -> CmmAGraph
storeCurCCS :: CmmExpr -> CmmAGraph
storeCurCCS e :: CmmExpr
e = CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cccsReg CmmExpr
e
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre :: CostCentre -> CmmLit
mkCCostCentre cc :: CostCentre
cc = CLabel -> CmmLit
CmmLabel (CostCentre -> CLabel
mkCCLabel CostCentre
cc)
mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack :: CostCentreStack -> CmmLit
mkCCostCentreStack ccs :: CostCentreStack
ccs = CLabel -> CmmLit
CmmLabel (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs)
costCentreFrom :: DynFlags
-> CmmExpr
-> CmmExpr
costCentreFrom :: DynFlags -> CmmExpr -> CmmExpr
costCentreFrom dflags :: DynFlags
dflags cl :: CmmExpr
cl = CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
cl (DynFlags -> ByteOff
oFFSET_StgHeader_ccs DynFlags
dflags)) (DynFlags -> CmmType
ccsType DynFlags
dflags)
staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr :: DynFlags -> CostCentreStack -> [CmmLit]
staticProfHdr dflags :: DynFlags
dflags ccs :: CostCentreStack
ccs
= DynFlags -> [CmmLit] -> [CmmLit]
forall a. DynFlags -> [a] -> [a]
ifProfilingL DynFlags
dflags [CostCentreStack -> CmmLit
mkCCostCentreStack CostCentreStack
ccs, DynFlags -> CmmLit
staticLdvInit DynFlags
dflags]
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
dynProfHdr :: DynFlags -> CmmExpr -> [CmmExpr]
dynProfHdr dflags :: DynFlags
dflags ccs :: CmmExpr
ccs = DynFlags -> [CmmExpr] -> [CmmExpr]
forall a. DynFlags -> [a] -> [a]
ifProfilingL DynFlags
dflags [CmmExpr
ccs, DynFlags -> CmmExpr
dynLdvInit DynFlags
dflags]
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf :: CmmExpr -> FCode ()
initUpdFrameProf frame :: CmmExpr
frame
= FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmExpr -> CmmExpr -> FCode ()
emitStore (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset DynFlags
dflags CmmExpr
frame (DynFlags -> ByteOff
oFFSET_StgHeader_ccs DynFlags
dflags)) CmmExpr
cccsExpr
saveCurrentCostCentre :: FCode (Maybe LocalReg)
saveCurrentCostCentre :: FCode (Maybe LocalReg)
saveCurrentCostCentre
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
then Maybe LocalReg -> FCode (Maybe LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocalReg
forall a. Maybe a
Nothing
else do LocalReg
local_cc <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
ccType DynFlags
dflags)
CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
local_cc) CmmExpr
cccsExpr
Maybe LocalReg -> FCode (Maybe LocalReg)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
local_cc)
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre :: Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Nothing
= () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
restoreCurrentCostCentre (Just local_cc :: LocalReg
local_cc)
= CmmAGraph -> FCode ()
emit (CmmExpr -> CmmAGraph
storeCurCCS (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
local_cc)))
profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc :: SMRep -> CmmExpr -> FCode ()
profDynAlloc rep :: SMRep
rep ccs :: CmmExpr
ccs
= FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmExpr -> CmmExpr -> FCode ()
profAlloc (DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> SMRep -> ByteOff
heapClosureSizeW DynFlags
dflags SMRep
rep)) CmmExpr
ccs
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc :: CmmExpr -> CmmExpr -> FCode ()
profAlloc words :: CmmExpr
words ccs :: CmmExpr
ccs
= FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let alloc_rep :: CmmType
alloc_rep = DynFlags -> CmmType
rEP_CostCentreStack_mem_alloc DynFlags
dflags
CmmAGraph -> FCode ()
emit (CmmType -> CmmExpr -> CmmExpr -> CmmAGraph
addToMemE CmmType
alloc_rep
(DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
ccs (DynFlags -> ByteOff
oFFSET_CostCentreStack_mem_alloc DynFlags
dflags))
(MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
wordWidth DynFlags
dflags) (CmmType -> Width
typeWidth CmmType
alloc_rep)) ([CmmExpr] -> CmmExpr) -> [CmmExpr] -> CmmExpr
forall a b. (a -> b) -> a -> b
$
[MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
dflags) [CmmExpr
words,
DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> ByteOff
profHdrSize DynFlags
dflags)]]))
enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk :: CmmExpr -> FCode ()
enterCostCentreThunk closure :: CmmExpr
closure =
FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmAGraph
storeCurCCS (DynFlags -> CmmExpr -> CmmExpr
costCentreFrom DynFlags
dflags CmmExpr
closure)
enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun :: CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun ccs :: CostCentreStack
ccs closure :: CmmExpr
closure =
FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
if CostCentreStack -> Bool
isCurrentCCS CostCentreStack
ccs
then do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
UnitId
-> FastString -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCall UnitId
rtsUnitId (String -> FastString
fsLit "enterFunCCS")
[(CmmExpr
baseExpr, ForeignHint
AddrHint),
(DynFlags -> CmmExpr -> CmmExpr
costCentreFrom DynFlags
dflags CmmExpr
closure, ForeignHint
AddrHint)] Bool
False
else () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ifProfiling :: FCode () -> FCode ()
ifProfiling :: FCode () -> FCode ()
ifProfiling code :: FCode ()
code
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
then FCode ()
code
else () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
ifProfilingL :: DynFlags -> [a] -> [a]
ifProfilingL :: DynFlags -> [a] -> [a]
ifProfilingL dflags :: DynFlags
dflags xs :: [a]
xs
| GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags = [a]
xs
| Bool
otherwise = []
initCostCentres :: CollectedCCs -> FCode ()
initCostCentres :: CollectedCCs -> FCode ()
initCostCentres (local_CCs :: [CostCentre]
local_CCs, singleton_CCSs :: [CostCentreStack]
singleton_CCSs)
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do (CostCentre -> FCode ()) -> [CostCentre] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentre -> FCode ()
emitCostCentreDecl [CostCentre]
local_CCs
(CostCentreStack -> FCode ()) -> [CostCentreStack] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ CostCentreStack -> FCode ()
emitCostCentreStackDecl [CostCentreStack]
singleton_CCSs
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl :: CostCentre -> FCode ()
emitCostCentreDecl cc :: CostCentre
cc = do
{ DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let is_caf :: CmmLit
is_caf | CostCentre -> Bool
isCafCC CostCentre
cc = DynFlags -> ByteOff -> CmmLit
mkIntCLit DynFlags
dflags (Char -> ByteOff
ord 'c')
| Bool
otherwise = DynFlags -> CmmLit
zero DynFlags
dflags
; CmmLit
label <- [Word8] -> FCode CmmLit
newByteStringCLit (FastString -> [Word8]
bytesFS (FastString -> [Word8]) -> FastString -> [Word8]
forall a b. (a -> b) -> a -> b
$ CostCentre -> FastString
costCentreUserNameFS CostCentre
cc)
; CmmLit
modl <- [Word8] -> FCode CmmLit
newByteStringCLit (FastString -> [Word8]
bytesFS (FastString -> [Word8]) -> FastString -> [Word8]
forall a b. (a -> b) -> a -> b
$ ModuleName -> FastString
Module.moduleNameFS
(ModuleName -> FastString) -> ModuleName -> FastString
forall a b. (a -> b) -> a -> b
$ Module -> ModuleName
Module.moduleName
(Module -> ModuleName) -> Module -> ModuleName
forall a b. (a -> b) -> a -> b
$ CostCentre -> Module
cc_mod CostCentre
cc)
; CmmLit
loc <- [Word8] -> FCode CmmLit
newByteStringCLit ([Word8] -> FCode CmmLit) -> [Word8] -> FCode CmmLit
forall a b. (a -> b) -> a -> b
$ FastString -> [Word8]
bytesFS (FastString -> [Word8]) -> FastString -> [Word8]
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString (String -> FastString) -> String -> FastString
forall a b. (a -> b) -> a -> b
$
DynFlags -> SrcSpan -> String
forall a. Outputable a => DynFlags -> a -> String
showPpr DynFlags
dflags (CostCentre -> SrcSpan
costCentreSrcSpan CostCentre
cc)
; let
lits :: [CmmLit]
lits = [ DynFlags -> CmmLit
zero DynFlags
dflags,
CmmLit
label,
CmmLit
modl,
CmmLit
loc,
CmmLit
zero64,
DynFlags -> CmmLit
zero DynFlags
dflags,
CmmLit
is_caf,
DynFlags -> CmmLit
zero DynFlags
dflags
]
; CLabel -> [CmmLit] -> FCode ()
emitDataLits (CostCentre -> CLabel
mkCCLabel CostCentre
cc) [CmmLit]
lits
}
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl :: CostCentreStack -> FCode ()
emitCostCentreStackDecl ccs :: CostCentreStack
ccs
= case CostCentreStack -> Maybe CostCentre
maybeSingletonCCS CostCentreStack
ccs of
Just cc :: CostCentre
cc ->
do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let mk_lits :: CostCentre -> [CmmLit]
mk_lits cc :: CostCentre
cc = DynFlags -> CmmLit
zero DynFlags
dflags CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
CostCentre -> CmmLit
mkCCostCentre CostCentre
cc CmmLit -> [CmmLit] -> [CmmLit]
forall a. a -> [a] -> [a]
:
ByteOff -> CmmLit -> [CmmLit]
forall a. ByteOff -> a -> [a]
replicate (DynFlags -> ByteOff
sizeof_ccs_words DynFlags
dflags ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- 2) (DynFlags -> CmmLit
zero DynFlags
dflags)
CLabel -> [CmmLit] -> FCode ()
emitDataLits (CostCentreStack -> CLabel
mkCCSLabel CostCentreStack
ccs) (CostCentre -> [CmmLit]
mk_lits CostCentre
cc)
Nothing -> String -> SDoc -> FCode ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic "emitCostCentreStackDecl" (CostCentreStack -> SDoc
forall a. Outputable a => a -> SDoc
ppr CostCentreStack
ccs)
zero :: DynFlags -> CmmLit
zero :: DynFlags -> CmmLit
zero dflags :: DynFlags
dflags = DynFlags -> ByteOff -> CmmLit
mkIntCLit DynFlags
dflags 0
zero64 :: CmmLit
zero64 :: CmmLit
zero64 = Integer -> Width -> CmmLit
CmmInt 0 Width
W64
sizeof_ccs_words :: DynFlags -> Int
sizeof_ccs_words :: DynFlags -> ByteOff
sizeof_ccs_words dflags :: DynFlags
dflags
| ByteOff
ms ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
== 0 = ByteOff
ws
| Bool
otherwise = ByteOff
ws ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ 1
where
(ws :: ByteOff
ws,ms :: ByteOff
ms) = DynFlags -> ByteOff
sIZEOF_CostCentreStack DynFlags
dflags ByteOff -> ByteOff -> (ByteOff, ByteOff)
forall a. Integral a => a -> a -> (a, a)
`divMod` DynFlags -> ByteOff
wORD_SIZE DynFlags
dflags
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC :: CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC cc :: CostCentre
cc tick :: Bool
tick push :: Bool
push
= do DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
if Bool -> Bool
not (GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags)
then () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else do LocalReg
tmp <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
ccsType DynFlags
dflags)
LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre LocalReg
tmp CmmExpr
cccsExpr CostCentre
cc
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tick (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraph -> FCode ()
emit (DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
push (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmAGraph -> FCode ()
emit (CmmExpr -> CmmAGraph
storeCurCCS (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre :: LocalReg -> CmmExpr -> CostCentre -> FCode ()
pushCostCentre result :: LocalReg
result ccs :: CmmExpr
ccs cc :: CostCentre
cc
= LocalReg
-> ForeignHint
-> UnitId
-> FastString
-> [(CmmExpr, ForeignHint)]
-> Bool
-> FCode ()
emitRtsCallWithResult LocalReg
result ForeignHint
AddrHint
UnitId
rtsUnitId
(String -> FastString
fsLit "pushCostCentre") [(CmmExpr
ccs,ForeignHint
AddrHint),
(CmmLit -> CmmExpr
CmmLit (CostCentre -> CmmLit
mkCCostCentre CostCentre
cc), ForeignHint
AddrHint)]
Bool
False
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount :: DynFlags -> CmmExpr -> CmmAGraph
bumpSccCount dflags :: DynFlags
dflags ccs :: CmmExpr
ccs
= CmmType -> CmmExpr -> ByteOff -> CmmAGraph
addToMem (DynFlags -> CmmType
rEP_CostCentreStack_scc_count DynFlags
dflags)
(DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
ccs (DynFlags -> ByteOff
oFFSET_CostCentreStack_scc_count DynFlags
dflags)) 1
staticLdvInit :: DynFlags -> CmmLit
staticLdvInit :: DynFlags -> CmmLit
staticLdvInit = DynFlags -> CmmLit
zeroCLit
dynLdvInit :: DynFlags -> CmmExpr
dynLdvInit :: DynFlags -> CmmExpr
dynLdvInit dflags :: DynFlags
dflags =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordOr DynFlags
dflags) [
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordShl DynFlags
dflags) [DynFlags -> CmmExpr
loadEra DynFlags
dflags, DynFlags -> ByteOff -> CmmExpr
mkIntExpr DynFlags
dflags (DynFlags -> ByteOff
lDV_SHIFT DynFlags
dflags)],
CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_STATE_CREATE DynFlags
dflags))
]
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate :: CmmExpr -> FCode ()
ldvRecordCreate closure :: CmmExpr
closure = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> CmmExpr
ldvWord DynFlags
dflags CmmExpr
closure) (DynFlags -> CmmExpr
dynLdvInit DynFlags
dflags)
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure :: ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure closure_info :: ClosureInfo
closure_info node_reg :: CmmReg
node_reg = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let tag :: ByteOff
tag = DynFlags -> ClosureInfo -> ByteOff
funTag DynFlags
dflags ClosureInfo
closure_info
CmmExpr -> FCode ()
ldvEnter (DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
node_reg) (-ByteOff
tag))
ldvEnter :: CmmExpr -> FCode ()
ldvEnter :: CmmExpr -> FCode ()
ldvEnter cl_ptr :: CmmExpr
cl_ptr = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
ldv_wd :: CmmExpr
ldv_wd = DynFlags -> CmmExpr -> CmmExpr
ldvWord DynFlags
dflags CmmExpr
cl_ptr
new_ldv_wd :: CmmExpr
new_ldv_wd = DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord DynFlags
dflags (DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord DynFlags
dflags (CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
ldv_wd (DynFlags -> CmmType
bWord DynFlags
dflags))
(CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_CREATE_MASK DynFlags
dflags))))
(DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOrWord DynFlags
dflags (DynFlags -> CmmExpr
loadEra DynFlags
dflags) (CmmLit -> CmmExpr
CmmLit (DynFlags -> Integer -> CmmLit
mkWordCLit DynFlags
dflags (DynFlags -> Integer
iLDV_STATE_USE DynFlags
dflags))))
FCode () -> FCode ()
ifProfiling (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThenElse (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordUGt DynFlags
dflags) [DynFlags -> CmmExpr
loadEra DynFlags
dflags, CmmLit -> CmmExpr
CmmLit (DynFlags -> CmmLit
zeroCLit DynFlags
dflags)])
(CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
ldv_wd CmmExpr
new_ldv_wd)
CmmAGraph
mkNop
loadEra :: DynFlags -> CmmExpr
loadEra :: DynFlags -> CmmExpr
loadEra dflags :: DynFlags
dflags = MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_UU_Conv (DynFlags -> Width
cIntWidth DynFlags
dflags) (DynFlags -> Width
wordWidth DynFlags
dflags))
[CmmExpr -> CmmType -> CmmExpr
CmmLoad (CLabel -> CmmExpr
mkLblExpr (UnitId -> FastString -> CLabel
mkCmmDataLabel UnitId
rtsUnitId (String -> FastString
fsLit "era")))
(DynFlags -> CmmType
cInt DynFlags
dflags)]
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
ldvWord :: DynFlags -> CmmExpr -> CmmExpr
ldvWord dflags :: DynFlags
dflags closure_ptr :: CmmExpr
closure_ptr
= DynFlags -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
closure_ptr (DynFlags -> ByteOff
oFFSET_StgHeader_ldvw DynFlags
dflags)