module GHC.StgToCmm.Bind (
cgTopRhsClosure,
cgBind,
emitBlackHoleCode,
pushUpdateFrame, emitUpdateFrame
) where
import GHC.Prelude hiding ((<*>))
import GHC.Platform
import GHC.Platform.Profile
import GHC.StgToCmm.Expr
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Env
import GHC.StgToCmm.DataCon
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Prof (ldvEnterClosure, enterCostCentreFun, enterCostCentreThunk,
initUpdFrameProf)
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Foreign (emitPrimCall)
import GHC.Cmm.Graph
import GHC.Core ( AltCon(..) )
import GHC.Cmm.BlockId
import GHC.Runtime.Heap.Layout
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Stg.Syntax
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
import GHC.Unit.Module
import GHC.Data.List.SetOps
import GHC.Utils.Misc
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish ( tickishIsCode )
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Driver.Session
import GHC.Driver.Ppr
import Control.Monad
cgTopRhsClosure :: Platform
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> (CgIdInfo, FCode ())
cgTopRhsClosure :: Platform
-> RecFlag
-> Id
-> CostCentreStack
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> (CgIdInfo, FCode ())
cgTopRhsClosure Platform
platform RecFlag
rec Id
id CostCentreStack
ccs UpdateFlag
upd_flag [Id]
args CgStgExpr
body =
let closure_label :: CLabel
closure_label = Name -> CafInfo -> CLabel
mkLocalClosureLabel (Id -> Name
idName Id
id) (Id -> CafInfo
idCafInfo Id
id)
cg_id_info :: CgIdInfo
cg_id_info = Platform -> Id -> LambdaFormInfo -> CmmLit -> CgIdInfo
litIdInfo Platform
platform Id
id LambdaFormInfo
lf_info (CLabel -> CmmLit
CmmLabel CLabel
closure_label)
lf_info :: LambdaFormInfo
lf_info = Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo Platform
platform Id
id TopLevelFlag
TopLevel [] UpdateFlag
upd_flag [Id]
args
in (CgIdInfo
cg_id_info, LambdaFormInfo -> CLabel -> FCode ()
gen_code LambdaFormInfo
lf_info CLabel
closure_label)
where
gen_code :: LambdaFormInfo -> CLabel -> FCode ()
gen_code LambdaFormInfo
_ CLabel
closure_label
| StgApp Id
f [] <- CgStgExpr
body, [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args, RecFlag -> Bool
isNonRec RecFlag
rec
= do
CgIdInfo
cg_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
f
CLabel -> CmmInfoTable -> CostCentreStack -> [CmmLit] -> FCode ()
emitDataCon CLabel
closure_label CmmInfoTable
indStaticInfoTable CostCentreStack
ccs [CmmExpr -> CmmLit
unLit (CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
cg_info)]
gen_code LambdaFormInfo
lf_info CLabel
_closure_label
= do { Profile
profile <- FCode Profile
getProfile
; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let name :: Name
name = Id -> Name
idName Id
id
; Module
mod_name <- FCode Module
getModuleName
; let descr :: String
descr = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name Name
name
closure_info :: ClosureInfo
closure_info = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
True Id
id LambdaFormInfo
lf_info ByteOff
0 ByteOff
0 String
descr
; let fv_details :: [(NonVoid Id, ByteOff)]
header :: ClosureHeader
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(ByteOff
_, ByteOff
_, [(NonVoid Id, ByteOff)]
fv_details) = Profile
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (ByteOff, ByteOff, [(NonVoid Id, ByteOff)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (ByteOff, ByteOff, [(NonVoid a, ByteOff)])
mkVirtHeapOffsets Profile
profile ClosureHeader
header []
; FCode () -> FCode ()
forkClosureBody (Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [Id]
-> CgStgExpr
-> [(NonVoid Id, ByteOff)]
-> FCode ()
closureCodeBody Bool
True Id
id ClosureInfo
closure_info CostCentreStack
ccs
[Id]
args CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details)
; () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return () }
unLit :: CmmExpr -> CmmLit
unLit (CmmLit CmmLit
l) = CmmLit
l
unLit CmmExpr
_ = String -> CmmLit
forall a. String -> a
panic String
"unLit"
cgBind :: CgStgBinding -> FCode ()
cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs)
= do { (CgIdInfo
info, FCode CmmAGraph
fcode) <- Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs Id
BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs
; CgIdInfo -> FCode ()
addBindC CgIdInfo
info
; CmmAGraph
init <- FCode CmmAGraph
fcode
; CmmAGraph -> FCode ()
emit CmmAGraph
init }
cgBind (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs)
= do { [(CgIdInfo, FCode CmmAGraph)]
r <- [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ([FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)])
-> [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall a b. (a -> b) -> a -> b
$ (Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph))
-> [(Id, GenStgRhs 'CodeGen)]
-> [FCode (CgIdInfo, FCode CmmAGraph)]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
; let ([CgIdInfo]
id_infos, [FCode CmmAGraph]
fcodes) = [(CgIdInfo, FCode CmmAGraph)] -> ([CgIdInfo], [FCode CmmAGraph])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode CmmAGraph)]
r
; [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
id_infos
; ([CmmAGraph]
inits, CmmAGraph
body) <- FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph)
forall a. FCode a -> FCode (a, CmmAGraph)
getCodeR (FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph))
-> FCode [CmmAGraph] -> FCode ([CmmAGraph], CmmAGraph)
forall a b. (a -> b) -> a -> b
$ [FCode CmmAGraph] -> FCode [CmmAGraph]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [FCode CmmAGraph]
fcodes
; CmmAGraph -> FCode ()
emit ([CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph]
inits CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
body) }
cgRhs :: Id
-> CgStgRhs
-> FCode (
CgIdInfo
, FCode CmmAGraph
)
cgRhs :: Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs Id
id (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
mn [StgTickish]
_ts [StgArg]
args)
= Name
-> DataCon
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a. Name -> DataCon -> FCode a -> FCode a
withNewTickyCounterCon (Id -> Name
idName Id
id) DataCon
con (FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph))
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a b. (a -> b) -> a -> b
$
Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon Id
id ConstructorNumber
mn Bool
True CostCentreStack
cc DataCon
con ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
args)
cgRhs Id
id (StgRhsClosure XRhsClosure 'CodeGen
fvs CostCentreStack
cc UpdateFlag
upd_flag [BinderP 'CodeGen]
args CgStgExpr
body)
= do Profile
profile <- FCode Profile
getProfile
Profile
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure Profile
profile Id
id CostCentreStack
cc ([Id] -> [NonVoid Id]
nonVoidIds (DVarSet -> [Id]
dVarSetElems DVarSet
XRhsClosure 'CodeGen
fvs)) UpdateFlag
upd_flag [Id]
[BinderP 'CodeGen]
args CgStgExpr
body
mkRhsClosure :: Profile -> Id -> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure :: Profile
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure Profile
profile Id
bndr CostCentreStack
_cc
[NonVoid Id
the_fv]
UpdateFlag
upd_flag
[]
CgStgExpr
expr
| let strip :: GenStgExpr p -> GenStgExpr p
strip = (StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
forall (p :: StgPass).
(StgTickish -> Bool) -> GenStgExpr p -> GenStgExpr p
stripStgTicksTopE (Bool -> Bool
not (Bool -> Bool) -> (StgTickish -> Bool) -> StgTickish -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgTickish -> Bool
forall (pass :: TickishPass). GenTickish pass -> Bool
tickishIsCode)
, StgCase (StgApp Id
scrutinee [])
BinderP 'CodeGen
_
(AlgAlt TyCon
_)
[(DataAlt DataCon
_, [BinderP 'CodeGen]
params, CgStgExpr
sel_expr)] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
expr
, StgApp Id
selectee [] <- CgStgExpr -> CgStgExpr
forall {p :: StgPass}. GenStgExpr p -> GenStgExpr p
strip CgStgExpr
sel_expr
, Id
the_fv Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
scrutinee
, let (ByteOff
_, ByteOff
_, [(NonVoid Id, ByteOff)]
params_w_offsets) = Profile
-> [NonVoid (PrimRep, Id)]
-> (ByteOff, ByteOff, [(NonVoid Id, ByteOff)])
forall a.
Profile
-> [NonVoid (PrimRep, a)]
-> (ByteOff, ByteOff, [(NonVoid a, ByteOff)])
mkVirtConstrOffsets Profile
profile ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps ([Id] -> [NonVoid Id]
assertNonVoidIds [Id]
[BinderP 'CodeGen]
params))
, Just ByteOff
the_offset <- [(NonVoid Id, ByteOff)] -> NonVoid Id -> Maybe ByteOff
forall a b. Eq a => Assoc a b -> a -> Maybe b
assocMaybe [(NonVoid Id, ByteOff)]
params_w_offsets (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
selectee)
, let offset_into_int :: ByteOff
offset_into_int = Platform -> ByteOff -> ByteOff
bytesToWordsRoundUp (Profile -> Platform
profilePlatform Profile
profile) ByteOff
the_offset
ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
- Profile -> ByteOff
fixedHdrSizeW Profile
profile
, ByteOff
offset_into_int ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
<= PlatformConstants -> ByteOff
pc_MAX_SPEC_SELECTEE_SIZE (Profile -> PlatformConstants
profileConstants Profile
profile)
=
let lf_info :: LambdaFormInfo
lf_info = Id -> ByteOff -> Bool -> LambdaFormInfo
mkSelectorLFInfo Id
bndr ByteOff
offset_into_int (UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag)
in Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [Id -> StgArg
StgVarArg Id
the_fv]
mkRhsClosure Profile
profile Id
bndr CostCentreStack
_cc
[NonVoid Id]
fvs
UpdateFlag
upd_flag
[]
(StgApp Id
fun_id [StgArg]
args)
| [StgArg]
args [StgArg] -> ByteOff -> Bool
forall a. [a] -> ByteOff -> Bool
`lengthIs` (ByteOff
n_fvsByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
-ByteOff
1)
, (NonVoid Id -> Bool) -> [NonVoid Id] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (PrimRep -> Bool
isGcPtrRep (PrimRep -> Bool) -> (NonVoid Id -> PrimRep) -> NonVoid Id -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Id -> PrimRep
idPrimRep (Id -> PrimRep) -> (NonVoid Id -> Id) -> NonVoid Id -> PrimRep
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid) [NonVoid Id]
fvs
, UpdateFlag -> Bool
isUpdatable UpdateFlag
upd_flag
, ByteOff
n_fvs ByteOff -> ByteOff -> Bool
forall a. Ord a => a -> a -> Bool
<= PlatformConstants -> ByteOff
pc_MAX_SPEC_AP_SIZE (Profile -> PlatformConstants
profileConstants Profile
profile)
, Bool -> Bool
not (Profile -> Bool
profileIsProfiling Profile
profile)
, Id -> ByteOff
idArity Id
fun_id ByteOff -> ByteOff -> Bool
forall a. Eq a => a -> a -> Bool
== ByteOff
unknownArity
= Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [StgArg]
payload
where
n_fvs :: ByteOff
n_fvs = [NonVoid Id] -> ByteOff
forall (t :: * -> *) a. Foldable t => t a -> ByteOff
length [NonVoid Id]
fvs
lf_info :: LambdaFormInfo
lf_info = Id -> UpdateFlag -> ByteOff -> LambdaFormInfo
mkApLFInfo Id
bndr UpdateFlag
upd_flag ByteOff
n_fvs
payload :: [StgArg]
payload = Id -> StgArg
StgVarArg Id
fun_id StgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
: [StgArg]
args
mkRhsClosure Profile
profile Id
bndr CostCentreStack
cc [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args CgStgExpr
body
= do { let lf_info :: LambdaFormInfo
lf_info = Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo (Profile -> Platform
profilePlatform Profile
profile) Id
bndr TopLevelFlag
NotTopLevel [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args
; (CgIdInfo
id_info, LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
id_info, LambdaFormInfo -> LocalReg -> FCode CmmAGraph
gen_code LambdaFormInfo
lf_info LocalReg
reg) }
where
gen_code :: LambdaFormInfo -> LocalReg -> FCode CmmAGraph
gen_code LambdaFormInfo
lf_info LocalReg
reg
= do {
; let reduced_fvs :: [NonVoid Id]
reduced_fvs = (NonVoid Id -> Bool) -> [NonVoid Id] -> [NonVoid Id]
forall a. (a -> Bool) -> [a] -> [a]
filter (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr NonVoid Id -> NonVoid Id -> Bool
forall a. Eq a => a -> a -> Bool
/=) [NonVoid Id]
fvs
; Profile
profile <- FCode Profile
getProfile
; let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
; Module
mod_name <- FCode Module
getModuleName
; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let name :: Name
name = Id -> Name
idName Id
bndr
descr :: String
descr = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name Name
name
fv_details :: [(NonVoid Id, ByteOff)]
header :: ClosureHeader
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(ByteOff
tot_wds, ByteOff
ptr_wds, [(NonVoid Id, ByteOff)]
fv_details)
= Profile
-> ClosureHeader
-> [NonVoid (PrimRep, Id)]
-> (ByteOff, ByteOff, [(NonVoid Id, ByteOff)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (ByteOff, ByteOff, [(NonVoid a, ByteOff)])
mkVirtHeapOffsets Profile
profile ClosureHeader
header ([NonVoid Id] -> [NonVoid (PrimRep, Id)]
addIdReps [NonVoid Id]
reduced_fvs)
closure_info :: ClosureInfo
closure_info = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
False
Id
bndr LambdaFormInfo
lf_info ByteOff
tot_wds ByteOff
ptr_wds
String
descr
; FCode () -> FCode ()
forkClosureBody (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [Id]
-> CgStgExpr
-> [(NonVoid Id, ByteOff)]
-> FCode ()
closureCodeBody Bool
False Id
bndr ClosureInfo
closure_info CostCentreStack
cc [Id]
args
CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details
; let use_cc :: CmmExpr
use_cc = CmmExpr
cccsExpr; blame_cc :: CmmExpr
blame_cc = CmmExpr
cccsExpr
; CmmAGraph -> FCode ()
emit (FastString -> CmmAGraph
mkComment (FastString -> CmmAGraph) -> FastString -> CmmAGraph
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
"calling allocDynClosure")
; let toVarArg :: (NonVoid Id, b) -> (NonVoid StgArg, b)
toVarArg (NonVoid Id
a, b
off) = (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid (Id -> StgArg
StgVarArg Id
a), b
off)
; let info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
; CmmExpr
hp_plus_n <- Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, ByteOff)]
-> FCode CmmExpr
allocDynClosure (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr) CmmInfoTable
info_tbl LambdaFormInfo
lf_info CmmExpr
use_cc CmmExpr
blame_cc
(((NonVoid Id, ByteOff) -> (NonVoid StgArg, ByteOff))
-> [(NonVoid Id, ByteOff)] -> [(NonVoid StgArg, ByteOff)]
forall a b. (a -> b) -> [a] -> [b]
map (NonVoid Id, ByteOff) -> (NonVoid StgArg, ByteOff)
forall {b}. (NonVoid Id, b) -> (NonVoid StgArg, b)
toVarArg [(NonVoid Id, ByteOff)]
fv_details)
; CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit Platform
platform LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }
cgRhsStdThunk
:: Id
-> LambdaFormInfo
-> [StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk :: Id
-> LambdaFormInfo -> [StgArg] -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhsStdThunk Id
bndr LambdaFormInfo
lf_info [StgArg]
payload
= do { (CgIdInfo
id_info, LocalReg
reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
; (CgIdInfo, FCode CmmAGraph) -> FCode (CgIdInfo, FCode CmmAGraph)
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
id_info, LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg)
}
where
gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg
= Bool -> Name -> FCode CmmAGraph -> FCode CmmAGraph
forall a. Bool -> Name -> FCode a -> FCode a
withNewTickyCounterStdThunk (LambdaFormInfo -> Bool
lfUpdatable LambdaFormInfo
lf_info) (Id -> Name
idName Id
bndr) (FCode CmmAGraph -> FCode CmmAGraph)
-> FCode CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$
do
{
Module
mod_name <- FCode Module
getModuleName
; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Profile
profile <- FCode Profile
getProfile
; let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
header :: ClosureHeader
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(ByteOff
tot_wds, ByteOff
ptr_wds, [(NonVoid StgArg, ByteOff)]
payload_w_offsets)
= Profile
-> ClosureHeader
-> [NonVoid (PrimRep, StgArg)]
-> (ByteOff, ByteOff, [(NonVoid StgArg, ByteOff)])
forall a.
Profile
-> ClosureHeader
-> [NonVoid (PrimRep, a)]
-> (ByteOff, ByteOff, [(NonVoid a, ByteOff)])
mkVirtHeapOffsets Profile
profile ClosureHeader
header
([NonVoid StgArg] -> [NonVoid (PrimRep, StgArg)]
addArgReps ([StgArg] -> [NonVoid StgArg]
nonVoidStgArgs [StgArg]
payload))
descr :: String
descr = DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name (Id -> Name
idName Id
bndr)
closure_info :: ClosureInfo
closure_info = Profile
-> Bool
-> Id
-> LambdaFormInfo
-> ByteOff
-> ByteOff
-> String
-> ClosureInfo
mkClosureInfo Profile
profile Bool
False
Id
bndr LambdaFormInfo
lf_info ByteOff
tot_wds ByteOff
ptr_wds
String
descr
; let use_cc :: CmmExpr
use_cc = CmmExpr
cccsExpr; blame_cc :: CmmExpr
blame_cc = CmmExpr
cccsExpr
; let info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
; CmmExpr
hp_plus_n <- Maybe Id
-> CmmInfoTable
-> LambdaFormInfo
-> CmmExpr
-> CmmExpr
-> [(NonVoid StgArg, ByteOff)]
-> FCode CmmExpr
allocDynClosure (Id -> Maybe Id
forall a. a -> Maybe a
Just Id
bndr) CmmInfoTable
info_tbl LambdaFormInfo
lf_info
CmmExpr
use_cc CmmExpr
blame_cc [(NonVoid StgArg, ByteOff)]
payload_w_offsets
; CmmAGraph -> FCode CmmAGraph
forall (m :: * -> *) a. Monad m => a -> m a
return (Platform -> LocalReg -> LambdaFormInfo -> CmmExpr -> CmmAGraph
mkRhsInit Platform
platform LocalReg
reg LambdaFormInfo
lf_info CmmExpr
hp_plus_n) }
mkClosureLFInfo :: Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo :: Platform
-> Id
-> TopLevelFlag
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> LambdaFormInfo
mkClosureLFInfo Platform
platform Id
bndr TopLevelFlag
top [NonVoid Id]
fvs UpdateFlag
upd_flag [Id]
args
| [Id] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args =
Type -> TopLevelFlag -> [Id] -> UpdateFlag -> LambdaFormInfo
mkLFThunk (Id -> Type
idType Id
bndr) TopLevelFlag
top ((NonVoid Id -> Id) -> [NonVoid Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid [NonVoid Id]
fvs) UpdateFlag
upd_flag
| Bool
otherwise =
TopLevelFlag -> [Id] -> [Id] -> ArgDescr -> LambdaFormInfo
mkLFReEntrant TopLevelFlag
top ((NonVoid Id -> Id) -> [NonVoid Id] -> [Id]
forall a b. (a -> b) -> [a] -> [b]
map NonVoid Id -> Id
forall a. NonVoid a -> a
fromNonVoid [NonVoid Id]
fvs) [Id]
args (Platform -> [Id] -> ArgDescr
mkArgDescr Platform
platform [Id]
args)
closureCodeBody :: Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [Id]
-> CgStgExpr
-> [(NonVoid Id, ByteOff)]
-> FCode ()
closureCodeBody :: Bool
-> Id
-> ClosureInfo
-> CostCentreStack
-> [Id]
-> CgStgExpr
-> [(NonVoid Id, ByteOff)]
-> FCode ()
closureCodeBody Bool
top_lvl Id
bndr ClosureInfo
cl_info CostCentreStack
cc [] CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details
= Bool -> Bool -> Name -> FCode () -> FCode ()
forall a. Bool -> Bool -> Name -> FCode a -> FCode a
withNewTickyCounterThunk
(ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info)
(ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info)
(ClosureInfo -> Name
closureName ClosureInfo
cl_info) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [] (((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
\(ByteOff
_, LocalReg
node, [LocalReg]
_) -> ClosureInfo
-> [(NonVoid Id, ByteOff)]
-> CostCentreStack
-> LocalReg
-> CgStgExpr
-> FCode ()
thunkCode ClosureInfo
cl_info [(NonVoid Id, ByteOff)]
fv_details CostCentreStack
cc LocalReg
node CgStgExpr
body
where
lf_info :: LambdaFormInfo
lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
cl_info Id
bndr CostCentreStack
cc
closureCodeBody Bool
top_lvl Id
bndr ClosureInfo
cl_info CostCentreStack
cc args :: [Id]
args@(Id
arg0:[Id]
_) CgStgExpr
body [(NonVoid Id, ByteOff)]
fv_details
= let nv_args :: [NonVoid Id]
nv_args = [Id] -> [NonVoid Id]
nonVoidIds [Id]
args
arity :: ByteOff
arity = [Id] -> ByteOff
forall (t :: * -> *) a. Foldable t => t a -> ByteOff
length [Id]
args
in
Bool -> Name -> [NonVoid Id] -> FCode () -> FCode ()
forall a. Bool -> Name -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun (Id -> Bool
isOneShotBndr Id
arg0) (ClosureInfo -> Name
closureName ClosureInfo
cl_info)
[NonVoid Id]
nv_args (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do {
; let
lf_info :: LambdaFormInfo
lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
info_tbl :: CmmInfoTable
info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
cl_info Id
bndr CostCentreStack
cc
; Bool
-> Id
-> LambdaFormInfo
-> CmmInfoTable
-> [NonVoid Id]
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ())
-> FCode ()
emitClosureProcAndInfoTable Bool
top_lvl Id
bndr LambdaFormInfo
lf_info CmmInfoTable
info_tbl [NonVoid Id]
nv_args (((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ())
-> ((ByteOff, LocalReg, [LocalReg]) -> FCode ()) -> FCode ()
forall a b. (a -> b) -> a -> b
$
\(ByteOff
_offset, LocalReg
node, [LocalReg]
arg_regs) -> do
{ Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode Id
bndr ClosureInfo
cl_info [LocalReg]
arg_regs
; Profile
profile <- FCode Profile
getProfile
; Platform
platform <- FCode Platform
getPlatform
; let node_points :: Bool
node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
node' :: Maybe LocalReg
node' = if Bool
node_points then LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
node else Maybe LocalReg
forall a. Maybe a
Nothing
; BlockId
loop_header_id <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
; SelfLoopInfo -> FCode () -> FCode ()
forall a. SelfLoopInfo -> FCode a -> FCode a
withSelfLoop (Id
bndr, BlockId
loop_header_id, [LocalReg]
arg_regs) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{
; ClosureInfo
-> Maybe LocalReg -> ByteOff -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
node' ByteOff
arity [LocalReg]
arg_regs (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
node_points (ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure ClosureInfo
cl_info (LocalReg -> CmmReg
CmmLocal LocalReg
node))
; ClosureInfo -> FCode ()
tickyEnterFun ClosureInfo
cl_info
; CostCentreStack -> CmmExpr -> FCode ()
enterCostCentreFun CostCentreStack
cc
(MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordSub Platform
platform)
[ CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)
, Platform -> ByteOff -> CmmExpr
mkIntExpr Platform
platform (Platform -> ClosureInfo -> ByteOff
funTag Platform
platform ClosureInfo
cl_info) ])
; [(LocalReg, ByteOff)]
fv_bindings <- ((NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff))
-> [(NonVoid Id, ByteOff)] -> FCode [(LocalReg, ByteOff)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv [(NonVoid Id, ByteOff)]
fv_details
; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
node_points (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info [(LocalReg, ByteOff)]
fv_bindings
; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
body
}}}
}
bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv :: (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv (NonVoid Id
id, ByteOff
off) = do { LocalReg
reg <- NonVoid Id -> FCode LocalReg
rebindToReg NonVoid Id
id; (LocalReg, ByteOff) -> FCode (LocalReg, ByteOff)
forall (m :: * -> *) a. Monad m => a -> m a
return (LocalReg
reg, ByteOff
off) }
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs :: LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info = ((LocalReg, ByteOff) -> FCode ())
-> [(LocalReg, ByteOff)] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\ (LocalReg
reg, ByteOff
off) ->
do Platform
platform <- FCode Platform
getPlatform
let tag :: ByteOff
tag = Platform -> LambdaFormInfo -> ByteOff
lfDynTag Platform
platform LambdaFormInfo
lf_info
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Platform -> LocalReg -> LocalReg -> ByteOff -> ByteOff -> CmmAGraph
mkTaggedObjectLoad Platform
platform LocalReg
reg LocalReg
node ByteOff
off ByteOff
tag)
mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode :: Id -> ClosureInfo -> [LocalReg] -> FCode ()
mkSlowEntryCode Id
bndr ClosureInfo
cl_info [LocalReg]
arg_regs
| Just (ByteOff
_, ArgGen Liveness
_) <- ClosureInfo -> Maybe (ByteOff, ArgDescr)
closureFunInfo ClosureInfo
cl_info
= do Profile
profile <- FCode Profile
getProfile
Platform
platform <- FCode Platform
getPlatform
let node :: LocalReg
node = Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
slow_lbl :: CLabel
slow_lbl = Platform -> ClosureInfo -> CLabel
closureSlowEntryLabel Platform
platform ClosureInfo
cl_info
fast_lbl :: CLabel
fast_lbl = Platform -> ClosureInfo -> CLabel
closureLocalEntryLabel Platform
platform ClosureInfo
cl_info
jump :: CmmAGraph
jump = Profile
-> Convention -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall
(CLabel -> CmmExpr
mkLblExpr CLabel
fast_lbl)
((LocalReg -> CmmExpr) -> [LocalReg] -> [CmmExpr]
forall a b. (a -> b) -> [a] -> [b]
map (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> (LocalReg -> CmmReg) -> LocalReg -> CmmExpr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LocalReg -> CmmReg
CmmLocal) (LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs))
(Platform -> ByteOff
initUpdFrameOff Platform
platform)
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
Convention
-> Maybe CmmInfoTable
-> CLabel
-> [LocalReg]
-> CmmAGraphScoped
-> FCode ()
emitProcWithConvention Convention
Slow Maybe CmmInfoTable
forall a. Maybe a
Nothing CLabel
slow_lbl
(LocalReg
node LocalReg -> [LocalReg] -> [LocalReg]
forall a. a -> [a] -> [a]
: [LocalReg]
arg_regs) (CmmAGraph
jump, CmmTickScope
tscope)
| Bool
otherwise = () -> FCode ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
thunkCode :: ClosureInfo -> [(NonVoid Id, ByteOff)] -> CostCentreStack
-> LocalReg -> CgStgExpr -> FCode ()
thunkCode :: ClosureInfo
-> [(NonVoid Id, ByteOff)]
-> CostCentreStack
-> LocalReg
-> CgStgExpr
-> FCode ()
thunkCode ClosureInfo
cl_info [(NonVoid Id, ByteOff)]
fv_details CostCentreStack
_cc LocalReg
node CgStgExpr
body
= do { Profile
profile <- FCode Profile
getProfile
; let node_points :: Bool
node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info)
node' :: Maybe LocalReg
node' = if Bool
node_points then LocalReg -> Maybe LocalReg
forall a. a -> Maybe a
Just LocalReg
node else Maybe LocalReg
forall a. Maybe a
Nothing
; ClosureInfo -> CmmReg -> FCode ()
ldvEnterClosure ClosureInfo
cl_info (LocalReg -> CmmReg
CmmLocal LocalReg
node)
; ClosureInfo
-> Maybe LocalReg -> ByteOff -> [LocalReg] -> FCode () -> FCode ()
entryHeapCheck ClosureInfo
cl_info Maybe LocalReg
node' ByteOff
0 [] (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{
; ClosureInfo -> FCode ()
tickyEnterThunk ClosureInfo
cl_info
; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
cl_info Bool -> Bool -> Bool
&& Bool
node_points)
(LocalReg -> FCode ()
blackHoleIt LocalReg
node)
; ClosureInfo -> LocalReg -> FCode () -> FCode ()
setupUpdate ClosureInfo
cl_info LocalReg
node (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
do { CmmExpr -> FCode ()
enterCostCentreThunk (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg)
; let lf_info :: LambdaFormInfo
lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
; [(LocalReg, ByteOff)]
fv_bindings <- ((NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff))
-> [(NonVoid Id, ByteOff)] -> FCode [(LocalReg, ByteOff)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (NonVoid Id, ByteOff) -> FCode (LocalReg, ByteOff)
bind_fv [(NonVoid Id, ByteOff)]
fv_details
; LocalReg -> LambdaFormInfo -> [(LocalReg, ByteOff)] -> FCode ()
load_fvs LocalReg
node LambdaFormInfo
lf_info [(LocalReg, ByteOff)]
fv_bindings
; FCode ReturnKind -> FCode ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void (FCode ReturnKind -> FCode ()) -> FCode ReturnKind -> FCode ()
forall a b. (a -> b) -> a -> b
$ CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
body }}}
blackHoleIt :: LocalReg -> FCode ()
blackHoleIt :: LocalReg -> FCode ()
blackHoleIt LocalReg
node_reg
= CmmExpr -> FCode ()
emitBlackHoleCode (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node_reg))
emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode :: CmmExpr -> FCode ()
emitBlackHoleCode CmmExpr
node = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Profile
profile <- FCode Profile
getProfile
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
let eager_blackholing :: Bool
eager_blackholing = Bool -> Bool
not (Profile -> Bool
profileIsProfiling Profile
profile)
Bool -> Bool -> Bool
&& GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EagerBlackHoling DynFlags
dflags
Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
eager_blackholing (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
FCode () -> FCode ()
forall a. FCode a -> FCode ()
whenUpdRemSetEnabled (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmExpr -> FCode ()
emitUpdRemSetPushThunk CmmExpr
node
CmmExpr -> CmmExpr -> FCode ()
emitStore (Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetW Platform
platform CmmExpr
node (Profile -> ByteOff
fixedHdrSizeW Profile
profile)) CmmExpr
currentTSOExpr
[LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [] CallishMachOp
MO_WriteBarrier []
CmmExpr -> CmmExpr -> FCode ()
emitStore CmmExpr
node (CmmReg -> CmmExpr
CmmReg (GlobalReg -> CmmReg
CmmGlobal GlobalReg
EagerBlackholeInfo))
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
setupUpdate :: ClosureInfo -> LocalReg -> FCode () -> FCode ()
setupUpdate ClosureInfo
closure_info LocalReg
node FCode ()
body
| Bool -> Bool
not (LambdaFormInfo -> Bool
lfUpdatable (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
closure_info))
= FCode ()
body
| Bool -> Bool
not (ClosureInfo -> Bool
isStaticClosure ClosureInfo
closure_info)
= if Bool -> Bool
not (ClosureInfo -> Bool
closureUpdReqd ClosureInfo
closure_info)
then do FCode ()
tickyUpdateFrameOmitted; FCode ()
body
else do
FCode ()
tickyPushUpdateFrame
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let
bh :: Bool
bh = ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
closure_info Bool -> Bool -> Bool
&&
Bool -> Bool
not (DynFlags -> Bool
sccProfilingEnabled DynFlags
dflags) Bool -> Bool -> Bool
&&
GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_EagerBlackHoling DynFlags
dflags
lbl :: CLabel
lbl | Bool
bh = CLabel
mkBHUpdInfoLabel
| Bool
otherwise = CLabel
mkUpdInfoLabel
CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
lbl (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)) FCode ()
body
| Bool
otherwise
= do { ClosureInfo -> FCode ()
tickyUpdateBhCaf ClosureInfo
closure_info
; if ClosureInfo -> Bool
closureUpdReqd ClosureInfo
closure_info
then do
{ CmmExpr
upd_closure <- LocalReg -> FCode CmmExpr
link_caf LocalReg
node
; CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
mkBHUpdInfoLabel CmmExpr
upd_closure FCode ()
body }
else do {FCode ()
tickyUpdateFrameOmitted; FCode ()
body}
}
pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame :: CLabel -> CmmExpr -> FCode () -> FCode ()
pushUpdateFrame CLabel
lbl CmmExpr
updatee FCode ()
body
= do
ByteOff
updfr <- FCode ByteOff
getUpdFrameOff
Profile
profile <- FCode Profile
getProfile
let
hdr :: ByteOff
hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
frame :: ByteOff
frame = ByteOff
updfr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_SIZEOF_StgUpdateFrame_NoHdr (Profile -> PlatformConstants
profileConstants Profile
profile)
CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame (Area -> ByteOff -> CmmExpr
CmmStackSlot Area
Old ByteOff
frame) CLabel
lbl CmmExpr
updatee
ByteOff -> FCode () -> FCode ()
forall a. ByteOff -> FCode a -> FCode a
withUpdFrameOff ByteOff
frame FCode ()
body
emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame CmmExpr
frame CLabel
lbl CmmExpr
updatee = do
Profile
profile <- FCode Profile
getProfile
let
hdr :: ByteOff
hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
off_updatee :: ByteOff
off_updatee = ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_OFFSET_StgUpdateFrame_updatee (Platform -> PlatformConstants
platformConstants Platform
platform)
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
CmmExpr -> CmmExpr -> FCode ()
emitStore CmmExpr
frame (CLabel -> CmmExpr
mkLblExpr CLabel
lbl)
CmmExpr -> CmmExpr -> FCode ()
emitStore (Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform CmmExpr
frame ByteOff
off_updatee) CmmExpr
updatee
CmmExpr -> FCode ()
initUpdFrameProf CmmExpr
frame
link_caf :: LocalReg
-> FCode CmmExpr
link_caf :: LocalReg -> FCode CmmExpr
link_caf LocalReg
node = do
{ Profile
profile <- FCode Profile
getProfile
; let newCAF_lbl :: CLabel
newCAF_lbl = FastString
-> Maybe ByteOff -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel (String -> FastString
fsLit String
"newCAF") Maybe ByteOff
forall a. Maybe a
Nothing
ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction
; let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
; LocalReg
bh <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
; [(LocalReg, ForeignHint)]
-> CLabel -> [(CmmExpr, ForeignHint)] -> Bool -> FCode ()
emitRtsCallGen [(LocalReg
bh,ForeignHint
AddrHint)] CLabel
newCAF_lbl
[ (CmmExpr
baseExpr, ForeignHint
AddrHint),
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node), ForeignHint
AddrHint) ]
Bool
False
; ByteOff
updfr <- FCode ByteOff
getUpdFrameOff
; PtrOpts
ptr_opts <- FCode PtrOpts
getPtrOpts
; let target :: CmmExpr
target = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform (PtrOpts -> CmmExpr -> CmmExpr
closureInfoPtr PtrOpts
ptr_opts (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)))
; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen
(Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
bh)) (Platform -> CmmExpr
zeroExpr Platform
platform))
(Profile
-> Convention -> CmmExpr -> [CmmExpr] -> ByteOff -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall CmmExpr
target [] ByteOff
updfr)
; CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
bh)) }
closureDescription
:: DynFlags
-> Module
-> Name
-> String
closureDescription :: DynFlags -> Module -> Name -> String
closureDescription DynFlags
dflags Module
mod_name Name
name
= SDocContext -> SDoc -> String
showSDocDump (DynFlags -> PprStyle -> SDocContext
initSDocContext DynFlags
dflags PprStyle
defaultDumpStyle) (Char -> SDoc
char Char
'<' SDoc -> SDoc -> SDoc
<>
(if Name -> Bool
isExternalName Name
name
then Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name
else Module -> SDoc
pprModule Module
mod_name SDoc -> SDoc -> SDoc
<> Char -> SDoc
char Char
'.' SDoc -> SDoc -> SDoc
<> Name -> SDoc
forall a. Outputable a => a -> SDoc
ppr Name
name) SDoc -> SDoc -> SDoc
<>
Char -> SDoc
char Char
'>')