module GHC.StgToCmm.Bind (
cgTopRhsClosure,
cgBind,
emitBlackHoleCode,
pushUpdateFrame, emitUpdateFrame
) where
import GHC.Prelude hiding ((<*>))
import GHC.Core ( AltCon(..) )
import GHC.Core.Opt.Arity( isOneShotBndr )
import GHC.Runtime.Heap.Layout
import GHC.Unit.Module
import GHC.Stg.Syntax
import GHC.Platform
import GHC.Platform.Profile
import GHC.Builtin.Names (unpackCStringName, unpackCStringUtf8Name)
import GHC.StgToCmm.Config
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.TagCheck
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.Cmm.BlockId
import GHC.Cmm
import GHC.Cmm.Info
import GHC.Cmm.Utils
import GHC.Cmm.CLabel
import GHC.Stg.Utils
import GHC.Types.CostCentre
import GHC.Types.Id
import GHC.Types.Id.Info
import GHC.Types.Name
import GHC.Types.Var.Set
import GHC.Types.Basic
import GHC.Types.Tickish ( tickishIsCode )
import GHC.Utils.Misc
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Data.FastString
import GHC.Data.List.SetOps
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
mkClosureLabel (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 -> FCode ()
gen_code LambdaFormInfo
_ CLabel
closure_label
| StgApp Id
f [] <- CgStgExpr
body
, [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args
, RecFlag -> Bool
isNonRec RecFlag
rec
= do
cg_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
f
emitDataCon closure_label indStaticInfoTable ccs [unLit (idInfoToAmode cg_info)]
gen_code LambdaFormInfo
_ CLabel
closure_label
| [Id] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Id]
args
, Just FCode (CmmInfoTable, CmmLit)
gen <- CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure CgStgExpr
body
= do (info, lit) <- FCode (CmmInfoTable, CmmLit)
gen
emitDecl $ CmmData (Section Data closure_label) $
CmmStatics closure_label info ccs [] [lit]
gen_code LambdaFormInfo
lf_info CLabel
_closure_label
= do { profile <- FCode Profile
getProfile
; let name = Id -> Name
idName Id
id
; mod_name <- getModuleName
; let descr = Module -> Name -> String
closureDescription Module
mod_name Name
name
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 = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(_, _, fv_details) = mkVirtHeapOffsets profile header []
; forkClosureBody (closureCodeBody True id closure_info ccs
args body fv_details)
; return () }
unLit :: CmmExpr -> CmmLit
unLit (CmmLit CmmLit
l) = CmmLit
l
unLit CmmExpr
_ = String -> CmmLit
forall a. HasCallStack => String -> a
panic String
"unLit"
isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure :: CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure CgStgExpr
body = case (StgTickish -> Bool) -> CgStgExpr -> CgStgExpr
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) CgStgExpr
body of
StgApp Id
f [StgArg
arg]
| Just CLabel
unpack <- Id -> Maybe CLabel
is_string_unpack_op Id
f
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. a -> Maybe a
Just (FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit)))
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a b. (a -> b) -> a -> b
$ do
arg' <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
case arg' of
CmmLit CmmLit
lit -> do
let info :: CmmInfoTable
info = CmmInfoTable
{ cit_lbl :: CLabel
cit_lbl = CLabel
unpack
, cit_rep :: SMRep
cit_rep = Bool -> ByteOff -> ByteOff -> ClosureTypeInfo -> SMRep
HeapRep Bool
True ByteOff
0 ByteOff
1 ClosureTypeInfo
Thunk
, cit_prof :: ProfilingInfo
cit_prof = ProfilingInfo
NoProfilingInfo
, cit_srt :: Maybe CLabel
cit_srt = Maybe CLabel
forall a. Maybe a
Nothing
, cit_clo :: Maybe (Id, CostCentreStack)
cit_clo = Maybe (Id, CostCentreStack)
forall a. Maybe a
Nothing
}
(CmmInfoTable, CmmLit) -> FCode (CmmInfoTable, CmmLit)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmInfoTable
info, CmmLit
lit)
CmmExpr
_ -> String -> FCode (CmmInfoTable, CmmLit)
forall a. HasCallStack => String -> a
panic String
"isUnpackCStringClosure: not a lit"
StgCase (StgLit Literal
l) BinderP 'CodeGen
b AltType
_ [GenStgAlt 'CodeGen
alt]
| Just FCode (CmmInfoTable, CmmLit)
gen <- CgStgExpr -> Maybe (FCode (CmmInfoTable, CmmLit))
isUnpackCStringClosure (GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. a -> Maybe a
Just (FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit)))
-> FCode (CmmInfoTable, CmmLit)
-> Maybe (FCode (CmmInfoTable, CmmLit))
forall a b. (a -> b) -> a -> b
$ do
e <- Literal -> FCode CmmExpr
cgLit Literal
l
addBindC (mkCgIdInfo b mkLFStringLit e)
gen
CgStgExpr
_ -> Maybe (FCode (CmmInfoTable, CmmLit))
forall a. Maybe a
Nothing
where
is_string_unpack_op :: Id -> Maybe CLabel
is_string_unpack_op Id
f
| Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringName = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
mkRtsUnpackCStringLabel
| Id -> Name
idName Id
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
unpackCStringUtf8Name = CLabel -> Maybe CLabel
forall a. a -> Maybe a
Just CLabel
mkRtsUnpackCStringUtf8Label
| Bool
otherwise = Maybe CLabel
forall a. Maybe a
Nothing
cgBind :: CgStgBinding -> FCode ()
cgBind :: CgStgBinding -> FCode ()
cgBind (StgNonRec BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs)
= do { (info, fcode) <- Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode CmmAGraph)
cgRhs Id
BinderP 'CodeGen
name GenStgRhs 'CodeGen
rhs
; addBindC info
; init <- fcode
; emit init }
cgBind (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs)
= do { r <- [FCode (CgIdInfo, FCode CmmAGraph)]
-> FCode [(CgIdInfo, FCode CmmAGraph)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [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 (id_infos, fcodes) = unzip r
; addBindsC id_infos
; (inits, body) <- getCodeR $ sequence fcodes
; emit (catAGraphs inits <*> 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 Type
_typ)
= Id
-> DataCon
-> ConstructorNumber
-> FCode (CgIdInfo, FCode CmmAGraph)
-> FCode (CgIdInfo, FCode CmmAGraph)
forall a. Id -> DataCon -> ConstructorNumber -> FCode a -> FCode a
withNewTickyCounterCon Id
id DataCon
con ConstructorNumber
mn (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 Type
_typ)
= do
profile <- FCode Profile
getProfile
check_tags <- stgToCmmDoTagCheck <$> getStgToCmmConfig
use_std_ap_thunk <- stgToCmmTickyAP <$> getStgToCmmConfig
mkRhsClosure profile use_std_ap_thunk check_tags id cc (nonVoidIds (dVarSetElems fvs)) upd_flag args body
mkRhsClosure :: Profile
-> Bool
-> Bool
-> Id -> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure :: Profile
-> Bool
-> Bool
-> Id
-> CostCentreStack
-> [NonVoid Id]
-> UpdateFlag
-> [Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode CmmAGraph)
mkRhsClosure Profile
profile Bool
_ Bool
_check_tags 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
_)
[GenStgAlt{ alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con = DataAlt DataCon
_
, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs = [BinderP 'CodeGen]
params
, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs = 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 Bool
use_std_ap Bool
check_tags Id
bndr CostCentreStack
_cc
[NonVoid Id]
fvs
UpdateFlag
upd_flag
[]
(StgApp Id
fun_id [StgArg]
args)
| Bool
use_std_ap
, [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
idPrimRepU (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
, Bool -> Bool
not Bool
check_tags
= 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 a. [a] -> 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 Bool
_use_ap Bool
_check_tags 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
; (id_info, reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
; return (id_info, gen_code lf_info 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 <- FCode Profile
getProfile
; let platform = Profile -> Platform
profilePlatform Profile
profile
; mod_name <- getModuleName
; let name = Id -> Name
idName Id
bndr
descr = Module -> Name -> String
closureDescription Module
mod_name Name
name
fv_details :: [(NonVoid Id, ByteOff)]
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(tot_wds, ptr_wds, fv_details)
= mkVirtHeapOffsets profile header (addIdReps reduced_fvs)
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
; forkClosureBody $
closureCodeBody False bndr closure_info cc args
body fv_details
; let use_cc = Platform -> CmmExpr
cccsExpr Platform
platform; blame_cc = Platform -> CmmExpr
cccsExpr Platform
platform
; emit (mkComment $ mkFastString "calling allocDynClosure")
; let 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 = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info use_cc blame_cc
(map toVarArg fv_details)
; return (mkRhsInit platform reg lf_info 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 { (id_info, reg) <- Id -> LambdaFormInfo -> FCode (CgIdInfo, LocalReg)
rhsIdInfo Id
bndr LambdaFormInfo
lf_info
; return (id_info, gen_code reg)
}
where
gen_code :: LocalReg -> FCode CmmAGraph
gen_code LocalReg
reg
= Bool -> Id -> [StgArg] -> FCode CmmAGraph -> FCode CmmAGraph
forall a. Bool -> Id -> [StgArg] -> FCode a -> FCode a
withNewTickyCounterStdThunk (LambdaFormInfo -> Bool
lfUpdatable LambdaFormInfo
lf_info) (Id
bndr) [StgArg]
payload (FCode CmmAGraph -> FCode CmmAGraph)
-> FCode CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$
do
{
mod_name <- FCode Module
getModuleName
; profile <- getProfile
; platform <- getPlatform
; let
header = if LambdaFormInfo -> Bool
isLFThunk LambdaFormInfo
lf_info then ClosureHeader
ThunkHeader else ClosureHeader
StdHeader
(tot_wds, ptr_wds, payload_w_offsets)
= mkVirtHeapOffsets profile header
(addArgReps (nonVoidStgArgs payload))
descr = Module -> Name -> String
closureDescription Module
mod_name (Id -> Name
idName Id
bndr)
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 = Platform -> CmmExpr
cccsExpr Platform
platform; blame_cc = Platform -> CmmExpr
cccsExpr Platform
platform
; let info_tbl = ClosureInfo -> Id -> CostCentreStack -> CmmInfoTable
mkCmmInfo ClosureInfo
closure_info Id
bndr CostCentreStack
currentCCS
; hp_plus_n <- allocDynClosure (Just bndr) info_tbl lf_info
use_cc blame_cc payload_w_offsets
; return (mkRhsInit platform reg lf_info 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 a. [a] -> 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 -> Id -> [NonVoid Id] -> FCode () -> FCode ()
forall a. Bool -> Bool -> Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterThunk
(ClosureInfo -> Bool
isStaticClosure ClosureInfo
cl_info)
(ClosureInfo -> Bool
closureUpdReqd ClosureInfo
cl_info)
(ClosureInfo -> Id
closureName ClosureInfo
cl_info)
(((NonVoid Id, ByteOff) -> NonVoid Id)
-> [(NonVoid Id, ByteOff)] -> [NonVoid Id]
forall a b. (a -> b) -> [a] -> [b]
map (NonVoid Id, ByteOff) -> NonVoid Id
forall a b. (a, b) -> a
fst [(NonVoid Id, ByteOff)]
fv_details) (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 a. [a] -> ByteOff
forall (t :: * -> *) a. Foldable t => t a -> ByteOff
length [Id]
args
in
Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode () -> FCode ()
forall a.
Bool -> Id -> [NonVoid Id] -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterFun (Id -> Bool
isOneShotBndr Id
arg0) (ClosureInfo -> Id
closureName ClosureInfo
cl_info) (((NonVoid Id, ByteOff) -> NonVoid Id)
-> [(NonVoid Id, ByteOff)] -> [NonVoid Id]
forall a b. (a -> b) -> [a] -> [b]
map (NonVoid Id, ByteOff) -> NonVoid Id
forall a b. (a, b) -> a
fst [(NonVoid Id, ByteOff)]
fv_details)
[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 <- FCode Profile
getProfile
; platform <- getPlatform
; let node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
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
; loop_header_id <- newBlockId
; let !self_loop_info = MkSelfLoopInfo
{ sli_id :: Id
sli_id = Id
bndr
, sli_arity :: ByteOff
sli_arity = ByteOff
arity
, sli_header_block :: BlockId
sli_header_block = BlockId
loop_header_id
, sli_registers :: [LocalReg]
sli_registers = [LocalReg]
arg_regs
}
; withSelfLoop self_loop_info $ do
{
; entryHeapCheck cl_info node' arity arg_regs $ do
{
when node_points (ldvEnterClosure cl_info (CmmLocal node))
; tickyEnterFun cl_info
; enterCostCentreFun cc
(CmmMachOp (mo_wordSub platform)
[ CmmReg (CmmLocal node)
, mkIntExpr platform (funTag platform cl_info) ])
; fv_bindings <- mapM bind_fv fv_details
; when node_points $ load_fvs node lf_info fv_bindings
; checkFunctionArgTags (text "TagCheck failed - Argument to local function:" <> ppr bndr) bndr args
; void $ cgExpr 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 { reg <- NonVoid Id -> FCode LocalReg
rebindToReg NonVoid Id
id; return (reg, 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 <- FCode Platform
getPlatform
let tag = Platform -> LambdaFormInfo -> ByteOff
lfDynTag Platform
platform LambdaFormInfo
lf_info
emit $ mkTaggedObjectLoad platform reg node off 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 cfg <- FCode StgToCmmConfig
getStgToCmmConfig
upd_frame <- getUpdFrameOff
let node = Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
slow_lbl = Platform -> ClosureInfo -> CLabel
closureSlowEntryLabel Platform
platform ClosureInfo
cl_info
fast_lbl = Platform -> ClosureInfo -> CLabel
closureLocalEntryLabel Platform
platform ClosureInfo
cl_info
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))
ByteOff
upd_frame
tscope <- getTickScope
emitProcWithConvention Slow Nothing slow_lbl
(node : arg_regs) (jump, tscope)
| Bool
otherwise = () -> FCode ()
forall a. a -> FCode a
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 <- FCode Profile
getProfile
; platform <- getPlatform
; let node_points = Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile (ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info)
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
; ldvEnterClosure cl_info (CmmLocal node)
; entryHeapCheck cl_info node' 0 [] $ do
{
; tickyEnterThunk cl_info
; when (blackHoleOnEntry cl_info && node_points)
(blackHoleIt node)
; setupUpdate cl_info node $
do { enterCostCentreThunk (CmmReg $ nodeReg platform)
; let lf_info = ClosureInfo -> LambdaFormInfo
closureLFInfo ClosureInfo
cl_info
; fv_bindings <- mapM bind_fv fv_details
; load_fvs node lf_info fv_bindings
; void $ cgExpr 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
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
let profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
platform = StgToCmmConfig -> Platform
stgToCmmPlatform StgToCmmConfig
cfg
is_eager_bh = StgToCmmConfig -> Bool
stgToCmmEagerBlackHole StgToCmmConfig
cfg
let eager_blackholing = Bool -> Bool
not (Profile -> Bool
profileIsProfiling Profile
profile) Bool -> Bool -> Bool
&& Bool
is_eager_bh
when eager_blackholing $ do
whenUpdRemSetEnabled $ emitUpdRemSetPushThunk node
emitAtomicStore platform MemOrderRelease
(cmmOffsetW platform node (fixedHdrSizeW profile))
(currentTSOExpr platform)
emitAtomicStore platform MemOrderRelease
node
(CmmReg (CmmGlobal $ GlobalRegUse EagerBlackholeInfo $ bWord platform))
emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
emitAtomicStore :: Platform -> MemoryOrdering -> CmmExpr -> CmmExpr -> FCode ()
emitAtomicStore Platform
platform MemoryOrdering
mord CmmExpr
addr CmmExpr
val =
[LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [] (Width -> MemoryOrdering -> CallishMachOp
MO_AtomicWrite Width
w MemoryOrdering
mord) [CmmExpr
addr, CmmExpr
val]
where
w :: Width
w = CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmType
cmmExprType Platform
platform CmmExpr
val
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
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
let
bh = ClosureInfo -> Bool
blackHoleOnEntry ClosureInfo
closure_info
Bool -> Bool -> Bool
&& Bool -> Bool
not (StgToCmmConfig -> Bool
stgToCmmSCCProfiling StgToCmmConfig
cfg)
Bool -> Bool -> Bool
&& StgToCmmConfig -> Bool
stgToCmmEagerBlackHole StgToCmmConfig
cfg
lbl | Bool
bh = CLabel
mkBHUpdInfoLabel
| Bool
otherwise = CLabel
mkUpdInfoLabel
pushOrigThunkInfoFrame closure_info
$ pushUpdateFrame lbl (CmmReg (CmmLocal node)) body
| Bool
otherwise
= do { ClosureInfo -> FCode ()
tickyUpdateBhCaf ClosureInfo
closure_info
; if ClosureInfo -> Bool
closureUpdReqd ClosureInfo
closure_info
then do
{ upd_closure <- LocalReg -> FCode CmmExpr
link_caf LocalReg
node
; pushOrigThunkInfoFrame closure_info
$ pushUpdateFrame mkBHUpdInfoLabel upd_closure 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
updfr <- FCode ByteOff
getUpdFrameOff
profile <- getProfile
let hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
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)
emitUpdateFrame (CmmStackSlot Old frame) lbl updatee
withUpdFrameOff frame body
emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame :: CmmExpr -> CLabel -> CmmExpr -> FCode ()
emitUpdateFrame CmmExpr
frame CLabel
lbl CmmExpr
updatee = do
profile <- FCode Profile
getProfile
let
hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
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 = Profile -> Platform
profilePlatform Profile
profile
emitStore frame (mkLblExpr lbl)
emitStore (cmmOffset platform frame off_updatee) updatee
initUpdFrameProf frame
pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
pushOrigThunkInfoFrame :: ClosureInfo -> FCode () -> FCode ()
pushOrigThunkInfoFrame ClosureInfo
closure_info FCode ()
body = do
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
if stgToCmmOrigThunkInfo cfg
then do_it
else body
where
orig_itbl :: CmmExpr
orig_itbl = CLabel -> CmmExpr
mkLblExpr (ClosureInfo -> CLabel
closureInfoLabel ClosureInfo
closure_info)
do_it :: FCode ()
do_it = do
updfr <- FCode ByteOff
getUpdFrameOff
profile <- getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
hdr = Profile -> ByteOff
fixedHdrSize Profile
profile
orig_info_frame_sz =
ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_SIZEOF_StgOrigThunkInfoFrame_NoHdr (Profile -> PlatformConstants
profileConstants Profile
profile)
off_orig_info = ByteOff
hdr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ PlatformConstants -> ByteOff
pc_OFFSET_StgOrigThunkInfoFrame_info_ptr (Profile -> PlatformConstants
profileConstants Profile
profile)
frame_off = ByteOff
updfr ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ ByteOff
orig_info_frame_sz
frame = Area -> ByteOff -> CmmExpr
CmmStackSlot Area
Old ByteOff
frame_off
emitStore frame (mkLblExpr mkOrigThunkInfoLabel)
emitStore (cmmOffset platform frame off_orig_info) orig_itbl
withUpdFrameOff frame_off body
link_caf :: LocalReg
-> FCode CmmExpr
link_caf :: LocalReg -> FCode CmmExpr
link_caf LocalReg
node = do
{ cfg <- FCode StgToCmmConfig
getStgToCmmConfig
; let newCAF_lbl = FastString -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel (String -> FastString
fsLit String
"newCAF")
ForeignLabelSource
ForeignLabelInExternalPackage FunctionOrData
IsFunction
; let profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
; let platform = Profile -> Platform
profilePlatform Profile
profile
; bh <- newTemp (bWord platform)
; emitRtsCallGen [(bh,AddrHint)] newCAF_lbl
[ (baseExpr platform, AddrHint),
(CmmReg (CmmLocal node), AddrHint) ]
False
; updfr <- getUpdFrameOff
; let align_check = StgToCmmConfig -> Bool
stgToCmmAlignCheck StgToCmmConfig
cfg
; let target = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform
(Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
node)))
; emit =<< mkCmmIfThen
(cmmEqWord platform (CmmReg (CmmLocal bh)) (zeroExpr platform))
(mkJump profile NativeNodeCall target [] updfr)
; return (CmmReg (CmmLocal bh)) }
closureDescription
:: Module
-> Name
-> String
closureDescription :: Module -> Name -> String
closureDescription Module
mod_name Name
name
= SDocContext -> SDoc -> String
showSDocOneLine SDocContext
defaultSDocContext
(Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'<' SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Module -> Name -> SDoc
pprFullName Module
mod_name Name
name SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Char -> SDoc
forall doc. IsLine doc => Char -> doc
char Char
'>')