{-# OPTIONS_GHC -Wno-incomplete-uni-patterns #-}
{-# LANGUAGE BangPatterns #-}
{-# LANGUAGE CPP #-}
{-# LANGUAGE TypeFamilies #-}
module GHC.StgToCmm.Expr ( cgExpr, cgLit ) where
import GHC.Prelude hiding ((<*>))
import {-# SOURCE #-} GHC.StgToCmm.Bind ( cgBind )
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Heap
import GHC.StgToCmm.Env
import GHC.StgToCmm.DataCon
import GHC.StgToCmm.Prof (saveCurrentCostCentre, restoreCurrentCostCentre, emitSetCCC)
import GHC.StgToCmm.Layout
import GHC.StgToCmm.Lit
import GHC.StgToCmm.Prim
import GHC.StgToCmm.Hpc
import GHC.StgToCmm.TagCheck
import GHC.StgToCmm.Ticky
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.Stg.Syntax
import GHC.Cmm.Graph
import GHC.Cmm.BlockId
import GHC.Cmm hiding ( succ )
import GHC.Cmm.Info
import GHC.Cmm.Utils ( zeroExpr, cmmTagMask, mkWordCLit, mAX_PTR_TAG )
import GHC.Core
import GHC.Core.DataCon
import GHC.Types.ForeignCall
import GHC.Types.Id
import GHC.Builtin.PrimOps
import GHC.Core.TyCon
import GHC.Core.Type ( isUnliftedType )
import GHC.Types.RepType ( isZeroBitTy, countConRepArgs, mightBeFunTy )
import GHC.Types.CostCentre ( CostCentreStack, currentCCS )
import GHC.Types.Tickish
import GHC.Data.Maybe
import GHC.Utils.Misc
import GHC.Data.FastString
import GHC.Utils.Outputable
import GHC.Utils.Panic
import GHC.Utils.Panic.Plain
import Control.Monad ( unless, void )
import Control.Arrow ( first )
import Data.List ( partition )
import GHC.Stg.InferTags.TagSig (isTaggedSig)
import GHC.Platform.Profile (profileIsProfiling)
cgExpr :: CgStgExpr -> FCode ReturnKind
cgExpr :: CgStgExpr -> FCode ReturnKind
cgExpr (StgApp Id
fun [StgArg]
args) = Id -> [StgArg] -> FCode ReturnKind
cgIdApp Id
fun [StgArg]
args
cgExpr (StgOpApp (StgPrimOp PrimOp
SeqOp) [StgVarArg Id
a, StgArg
_] Type
_res_ty) =
Id -> [StgArg] -> FCode ReturnKind
cgIdApp Id
a []
cgExpr (StgOpApp (StgPrimOp PrimOp
DataToTagOp) [StgVarArg Id
a] Type
_res_ty) = do
Platform
platform <- FCode Platform
getPlatform
FastString -> FCode ()
emitComment (String -> FastString
mkFastString String
"dataToTag#")
CgIdInfo
info <- Id -> FCode CgIdInfo
getCgIdInfo Id
a
let amode :: CmmExpr
amode = CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
info
LocalReg
tag_reg <- CmmExpr -> FCode LocalReg
assignTemp (CmmExpr -> FCode LocalReg) -> CmmExpr -> FCode LocalReg
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmExpr
cmmConstrTag1 Platform
platform CmmExpr
amode
LocalReg
result_reg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
let tag :: CmmExpr
tag = CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmReg
CmmLocal LocalReg
tag_reg
is_tagged :: CmmExpr
is_tagged = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform CmmExpr
tag (Platform -> CmmExpr
zeroExpr Platform
platform)
is_too_big_tag :: CmmExpr
is_too_big_tag = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmEqWord Platform
platform CmmExpr
tag (Platform -> CmmExpr
cmmTagMask Platform
platform)
(CmmAGraph
fast_path :: CmmAGraph) <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
CmmAGraph
return_ptr_tag <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
result_reg)
(CmmExpr -> FCode ()) -> CmmExpr -> FCode ()
forall a b. (a -> b) -> a -> b
$ Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmSubWord Platform
platform CmmExpr
tag (CmmLit -> CmmExpr
CmmLit (CmmLit -> CmmExpr) -> CmmLit -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> Integer -> CmmLit
mkWordCLit Platform
platform Integer
1)
CmmAGraph
return_info_tag <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
Profile
profile <- FCode Profile
getProfile
Bool
align_check <- StgToCmmConfig -> Bool
stgToCmmAlignCheck (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
result_reg)
(CmmExpr -> FCode ()) -> CmmExpr -> FCode ()
forall a b. (a -> b) -> a -> b
$ Profile -> Bool -> CmmExpr -> CmmExpr
getConstrTag Profile
profile Bool
align_check (Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform CmmExpr
amode)
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
is_too_big_tag CmmAGraph
return_info_tag CmmAGraph
return_ptr_tag (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
case (Id -> Maybe TagSig
idTagSig_maybe Id
a) of
Just TagSig
sig
| TagSig -> Bool
isTaggedSig TagSig
sig
-> CmmAGraph -> FCode ()
emit CmmAGraph
fast_path
Maybe TagSig
_ -> do
CmmAGraph
slow_path <- FCode () -> FCode CmmAGraph
forall a. FCode a -> FCode CmmAGraph
getCode (FCode () -> FCode CmmAGraph) -> FCode () -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ do
LocalReg
tmp <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
ReturnKind
_ <- Sequel -> FCode ReturnKind -> FCode ReturnKind
forall a. Sequel -> FCode a -> FCode a
withSequel ([LocalReg] -> Bool -> Sequel
AssignTo [LocalReg
tmp] Bool
False) (Id -> [StgArg] -> FCode ReturnKind
cgIdApp Id
a [])
Profile
profile <- FCode Profile
getProfile
Bool
align_check <- StgToCmmConfig -> Bool
stgToCmmAlignCheck (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
result_reg)
(CmmExpr -> FCode ()) -> CmmExpr -> FCode ()
forall a b. (a -> b) -> a -> b
$ Profile -> Bool -> CmmExpr -> CmmExpr
getConstrTag Profile
profile Bool
align_check (Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tmp)))
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CmmExpr -> CmmAGraph -> CmmAGraph -> Maybe Bool -> FCode CmmAGraph
mkCmmIfThenElse' CmmExpr
is_tagged CmmAGraph
fast_path CmmAGraph
slow_path (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
[CmmExpr] -> FCode ReturnKind
emitReturn [CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ LocalReg -> CmmReg
CmmLocal LocalReg
result_reg]
cgExpr (StgOpApp StgOp
op [StgArg]
args Type
ty) = StgOp -> [StgArg] -> Type -> FCode ReturnKind
cgOpApp StgOp
op [StgArg]
args Type
ty
cgExpr (StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args [Type]
_) = DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind
cgConApp DataCon
con ConstructorNumber
mn [StgArg]
args
cgExpr (StgTick StgTickish
t CgStgExpr
e) = StgTickish -> FCode ()
cgTick StgTickish
t FCode () -> FCode ReturnKind -> FCode ReturnKind
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
e
cgExpr (StgLit Literal
lit) = do CmmExpr
cmm_expr <- Literal -> FCode CmmExpr
cgLit Literal
lit
[CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr
cmm_expr]
cgExpr (StgLet XLet 'CodeGen
_ GenStgBinding 'CodeGen
binds CgStgExpr
expr) = do { GenStgBinding 'CodeGen -> FCode ()
cgBind GenStgBinding 'CodeGen
binds; CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
expr }
cgExpr (StgLetNoEscape XLetNoEscape 'CodeGen
_ GenStgBinding 'CodeGen
binds CgStgExpr
expr) =
do { Unique
u <- FCode Unique
newUnique
; let join_id :: BlockId
join_id = Unique -> BlockId
mkBlockId Unique
u
; BlockId -> GenStgBinding 'CodeGen -> FCode ()
cgLneBinds BlockId
join_id GenStgBinding 'CodeGen
binds
; ReturnKind
r <- CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
expr
; BlockId -> FCode ()
emitLabel BlockId
join_id
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
r }
cgExpr (StgCase CgStgExpr
expr BinderP 'CodeGen
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts) =
CgStgExpr
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> FCode ReturnKind
cgCase CgStgExpr
expr Id
BinderP 'CodeGen
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts
cgLneBinds :: BlockId -> CgStgBinding -> FCode ()
cgLneBinds :: BlockId -> GenStgBinding 'CodeGen -> FCode ()
cgLneBinds BlockId
join_id (StgNonRec BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs)
= do { Maybe LocalReg
local_cc <- FCode (Maybe LocalReg)
saveCurrentCostCentre
; (CgIdInfo
info, FCode ()
fcode) <- BlockId
-> Maybe LocalReg
-> Id
-> GenStgRhs 'CodeGen
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhs BlockId
join_id Maybe LocalReg
local_cc Id
BinderP 'CodeGen
bndr GenStgRhs 'CodeGen
rhs
; FCode ()
fcode
; CgIdInfo -> FCode ()
addBindC CgIdInfo
info }
cgLneBinds BlockId
join_id (StgRec [(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs)
= do { Maybe LocalReg
local_cc <- FCode (Maybe LocalReg)
saveCurrentCostCentre
; [(CgIdInfo, FCode ())]
r <- [FCode (CgIdInfo, FCode ())] -> FCode [(CgIdInfo, FCode ())]
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 ())] -> FCode [(CgIdInfo, FCode ())])
-> [FCode (CgIdInfo, FCode ())] -> FCode [(CgIdInfo, FCode ())]
forall a b. (a -> b) -> a -> b
$ (Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode ()))
-> [(Id, GenStgRhs 'CodeGen)] -> [FCode (CgIdInfo, FCode ())]
forall a b c. (a -> b -> c) -> [(a, b)] -> [c]
unzipWith (BlockId
-> Maybe LocalReg
-> Id
-> GenStgRhs 'CodeGen
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhs BlockId
join_id Maybe LocalReg
local_cc) [(Id, GenStgRhs 'CodeGen)]
[(BinderP 'CodeGen, GenStgRhs 'CodeGen)]
pairs
; let ([CgIdInfo]
infos, [FCode ()]
fcodes) = [(CgIdInfo, FCode ())] -> ([CgIdInfo], [FCode ()])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CgIdInfo, FCode ())]
r
; [CgIdInfo] -> FCode ()
addBindsC [CgIdInfo]
infos
; [FCode ()] -> FCode ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ [FCode ()]
fcodes
}
cgLetNoEscapeRhs
:: BlockId
-> Maybe LocalReg
-> Id
-> CgStgRhs
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhs :: BlockId
-> Maybe LocalReg
-> Id
-> GenStgRhs 'CodeGen
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhs BlockId
join_id Maybe LocalReg
local_cc Id
bndr GenStgRhs 'CodeGen
rhs =
do { (CgIdInfo
info, FCode ()
rhs_code) <- Maybe LocalReg
-> Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhsBody Maybe LocalReg
local_cc Id
bndr GenStgRhs 'CodeGen
rhs
; let (BlockId
bid, [LocalReg]
_) = String -> Maybe (BlockId, [LocalReg]) -> (BlockId, [LocalReg])
forall a. HasCallStack => String -> Maybe a -> a
expectJust String
"cgLetNoEscapeRhs" (Maybe (BlockId, [LocalReg]) -> (BlockId, [LocalReg]))
-> Maybe (BlockId, [LocalReg]) -> (BlockId, [LocalReg])
forall a b. (a -> b) -> a -> b
$ CgIdInfo -> Maybe (BlockId, [LocalReg])
maybeLetNoEscape CgIdInfo
info
; let code :: FCode ()
code = do { (()
_, CmmAGraphScoped
body) <- FCode () -> FCode ((), CmmAGraphScoped)
forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped FCode ()
rhs_code
; BlockId -> CmmAGraphScoped -> FCode ()
emitOutOfLine BlockId
bid ((CmmAGraph -> CmmAGraph) -> CmmAGraphScoped -> CmmAGraphScoped
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first (CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmAGraph
mkBranch BlockId
join_id) CmmAGraphScoped
body) }
; (CgIdInfo, FCode ()) -> FCode (CgIdInfo, FCode ())
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (CgIdInfo
info, FCode ()
code)
}
cgLetNoEscapeRhsBody
:: Maybe LocalReg
-> Id
-> CgStgRhs
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhsBody :: Maybe LocalReg
-> Id -> GenStgRhs 'CodeGen -> FCode (CgIdInfo, FCode ())
cgLetNoEscapeRhsBody Maybe LocalReg
local_cc Id
bndr (StgRhsClosure XRhsClosure 'CodeGen
_ CostCentreStack
cc UpdateFlag
_upd [BinderP 'CodeGen]
args CgStgExpr
body)
= Id
-> Maybe LocalReg
-> CostCentreStack
-> [NonVoid Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure Id
bndr Maybe LocalReg
local_cc CostCentreStack
cc ([Id] -> [NonVoid Id]
nonVoidIds [Id]
[BinderP 'CodeGen]
args) CgStgExpr
body
cgLetNoEscapeRhsBody Maybe LocalReg
local_cc Id
bndr (StgRhsCon CostCentreStack
cc DataCon
con ConstructorNumber
mn [StgTickish]
_ts [StgArg]
args)
= Id
-> Maybe LocalReg
-> CostCentreStack
-> [NonVoid Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure Id
bndr Maybe LocalReg
local_cc CostCentreStack
cc []
(DataCon -> ConstructorNumber -> [StgArg] -> [Type] -> CgStgExpr
forall (pass :: StgPass).
DataCon
-> ConstructorNumber -> [StgArg] -> [Type] -> GenStgExpr pass
StgConApp DataCon
con ConstructorNumber
mn [StgArg]
args (String -> SDoc -> [Type]
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cgLetNoEscapeRhsBody" (SDoc -> [Type]) -> SDoc -> [Type]
forall a b. (a -> b) -> a -> b
$
String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"StgRhsCon doesn't have type args"))
cgLetNoEscapeClosure
:: Id
-> Maybe LocalReg
-> CostCentreStack
-> [NonVoid Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure :: Id
-> Maybe LocalReg
-> CostCentreStack
-> [NonVoid Id]
-> CgStgExpr
-> FCode (CgIdInfo, FCode ())
cgLetNoEscapeClosure Id
bndr Maybe LocalReg
cc_slot CostCentreStack
_unused_cc [NonVoid Id]
args CgStgExpr
body
= do Platform
platform <- FCode Platform
getPlatform
(CgIdInfo, FCode ()) -> FCode (CgIdInfo, FCode ())
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ( Platform -> Id -> [NonVoid Id] -> CgIdInfo
lneIdInfo Platform
platform Id
bndr [NonVoid Id]
args, FCode ()
code )
where
code :: FCode ()
code = FCode () -> FCode ()
forall a. FCode a -> FCode a
forkLneBody (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ Id -> [NonVoid Id] -> FCode () -> FCode ()
forall a. Id -> [NonVoid Id] -> FCode a -> FCode a
withNewTickyCounterLNE Id
bndr [NonVoid Id]
args (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
{ Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Maybe LocalReg
cc_slot
; [LocalReg]
arg_regs <- [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs [NonVoid Id]
args
; 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
$ [LocalReg] -> FCode ReturnKind -> FCode ReturnKind
forall a. [LocalReg] -> FCode a -> FCode a
noEscapeHeapCheck [LocalReg]
arg_regs (FCode ()
tickyEnterLNE FCode () -> FCode ReturnKind -> FCode ReturnKind
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
body) }
data GcPlan
= GcInAlts
[LocalReg]
| NoGcInAlts
cgCase :: CgStgExpr -> Id -> AltType -> [CgStgAlt] -> FCode ReturnKind
cgCase :: CgStgExpr
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> FCode ReturnKind
cgCase (StgApp Id
v []) Id
_ (PrimAlt PrimRep
_) [GenStgAlt 'CodeGen]
alts
| PrimRep -> Bool
isVoidRep (Id -> PrimRep
idPrimRep Id
v)
, [GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
DEFAULT, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'CodeGen]
_, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=CgStgExpr
rhs}] <- [GenStgAlt 'CodeGen]
alts
= CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
rhs
cgCase (StgApp Id
v []) Id
bndr alt_type :: AltType
alt_type@(PrimAlt PrimRep
_) [GenStgAlt 'CodeGen]
alts
| (() :: Constraint) => Type -> Bool
Type -> Bool
isUnliftedType (Id -> Type
idType Id
v)
=
do { Platform
platform <- FCode Platform
getPlatform
; Bool -> FCode () -> FCode ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Platform -> Bool
reps_compatible Platform
platform) (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$
String -> SDoc -> FCode ()
forall a. HasCallStack => String -> SDoc -> a
pprPanic String
"cgCase: reps do not match, perhaps a dodgy unsafeCoerce?"
(Id -> SDoc
pp_bndr Id
v SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
pp_bndr Id
bndr)
; CgIdInfo
v_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
v
; CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)))
(CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
v_info)
; LocalReg
_ <- NonVoid Id -> FCode LocalReg
bindArgToReg (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr)
; (GcPlan, ReturnKind)
-> NonVoid Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> FCode ReturnKind
cgAlts (GcPlan
NoGcInAlts,ReturnKind
AssignedDirectly) (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr) AltType
alt_type [GenStgAlt 'CodeGen]
alts }
where
reps_compatible :: Platform -> Bool
reps_compatible Platform
platform = Platform -> PrimRep -> PrimRep -> Bool
primRepCompatible Platform
platform (Id -> PrimRep
idPrimRep Id
v) (Id -> PrimRep
idPrimRep Id
bndr)
pp_bndr :: Id -> SDoc
pp_bndr Id
id = Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc
dcolon SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Type -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> Type
idType Id
id) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (PrimRep -> SDoc
forall a. Outputable a => a -> SDoc
ppr (Id -> PrimRep
idPrimRep Id
id))
cgCase scrut :: CgStgExpr
scrut@(StgApp Id
v []) Id
_ (PrimAlt PrimRep
_) [GenStgAlt 'CodeGen]
_
= do { Platform
platform <- FCode Platform
getPlatform
; Maybe LocalReg
mb_cc <- Bool -> FCode (Maybe LocalReg)
maybeSaveCostCentre Bool
True
; ReturnKind
_ <- Sequel -> FCode ReturnKind -> FCode ReturnKind
forall a. Sequel -> FCode a -> FCode a
withSequel
([LocalReg] -> Bool -> Sequel
AssignTo [Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
v)] Bool
False) (CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
scrut)
; Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Maybe LocalReg
mb_cc
; FastString -> FCode ()
emitComment (FastString -> FCode ()) -> FastString -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
"should be unreachable code"
; BlockId
l <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
; BlockId -> FCode ()
emitLabel BlockId
l
; CmmAGraph -> FCode ()
emit (BlockId -> CmmAGraph
mkBranch BlockId
l)
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
}
cgCase (StgOpApp (StgPrimOp PrimOp
SeqOp) [StgVarArg Id
a, StgArg
_] Type
_) Id
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts
=
CgStgExpr
-> Id -> AltType -> [GenStgAlt 'CodeGen] -> FCode ReturnKind
cgCase (Id -> [StgArg] -> CgStgExpr
forall (pass :: StgPass). Id -> [StgArg] -> GenStgExpr pass
StgApp Id
a []) Id
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts
cgCase CgStgExpr
scrut Id
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts
=
do { Platform
platform <- FCode Platform
getPlatform
; RepArity
up_hp_usg <- FCode RepArity
getVirtHp
; let ret_bndrs :: [NonVoid Id]
ret_bndrs = Id -> AltType -> [GenStgAlt 'CodeGen] -> [NonVoid Id]
chooseReturnBndrs Id
bndr AltType
alt_type [GenStgAlt 'CodeGen]
alts
alt_regs :: [LocalReg]
alt_regs = (NonVoid Id -> LocalReg) -> [NonVoid Id] -> [LocalReg]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform) [NonVoid Id]
ret_bndrs
; Bool
simple_scrut <- CgStgExpr -> AltType -> FCode Bool
isSimpleScrut CgStgExpr
scrut AltType
alt_type
; let do_gc :: Bool
do_gc | CgStgExpr -> Bool
forall {pass :: StgPass}. GenStgExpr pass -> Bool
is_cmp_op CgStgExpr
scrut = Bool
False
| Bool -> Bool
not Bool
simple_scrut = Bool
True
| [GenStgAlt 'CodeGen] -> Bool
forall a. [a] -> Bool
isSingleton [GenStgAlt 'CodeGen]
alts = Bool
False
| RepArity
up_hp_usg RepArity -> RepArity -> Bool
forall a. Ord a => a -> a -> Bool
> RepArity
0 = Bool
False
| Bool
otherwise = Bool
True
gc_plan :: GcPlan
gc_plan = if Bool
do_gc then [LocalReg] -> GcPlan
GcInAlts [LocalReg]
alt_regs else GcPlan
NoGcInAlts
; Maybe LocalReg
mb_cc <- Bool -> FCode (Maybe LocalReg)
maybeSaveCostCentre Bool
simple_scrut
; let sequel :: Sequel
sequel = [LocalReg] -> Bool -> Sequel
AssignTo [LocalReg]
alt_regs Bool
do_gc
; ReturnKind
ret_kind <- Sequel -> FCode ReturnKind -> FCode ReturnKind
forall a. Sequel -> FCode a -> FCode a
withSequel Sequel
sequel (CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
scrut)
; Maybe LocalReg -> FCode ()
restoreCurrentCostCentre Maybe LocalReg
mb_cc
; [LocalReg]
_ <- [NonVoid Id] -> FCode [LocalReg]
bindArgsToRegs [NonVoid Id]
ret_bndrs
; (GcPlan, ReturnKind)
-> NonVoid Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> FCode ReturnKind
cgAlts (GcPlan
gc_plan,ReturnKind
ret_kind) (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
bndr) AltType
alt_type [GenStgAlt 'CodeGen]
alts
}
where
is_cmp_op :: GenStgExpr pass -> Bool
is_cmp_op (StgOpApp (StgPrimOp PrimOp
op) [StgArg]
_ Type
_) = PrimOp -> Bool
isComparisonPrimOp PrimOp
op
is_cmp_op GenStgExpr pass
_ = Bool
False
maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
maybeSaveCostCentre :: Bool -> FCode (Maybe LocalReg)
maybeSaveCostCentre Bool
simple_scrut
| Bool
simple_scrut = Maybe LocalReg -> FCode (Maybe LocalReg)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe LocalReg
forall a. Maybe a
Nothing
| Bool
otherwise = FCode (Maybe LocalReg)
saveCurrentCostCentre
isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
isSimpleScrut :: CgStgExpr -> AltType -> FCode Bool
isSimpleScrut (StgOpApp StgOp
op [StgArg]
args Type
_) AltType
_ = StgOp -> [StgArg] -> FCode Bool
isSimpleOp StgOp
op [StgArg]
args
isSimpleScrut (StgLit Literal
_) AltType
_ = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isSimpleScrut (StgApp Id
_ []) (PrimAlt PrimRep
_) = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
isSimpleScrut (StgApp Id
f []) AltType
_
| Just TagSig
sig <- Id -> Maybe TagSig
idTagSig_maybe Id
f
, TagSig -> Bool
isTaggedSig TagSig
sig
= if Type -> Bool
mightBeFunTy (Id -> Type
idType Id
f)
then Bool -> Bool
not (Bool -> Bool) -> (Profile -> Bool) -> Profile -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Profile -> Bool
profileIsProfiling (Profile -> Bool) -> FCode Profile -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode Profile
getProfile
else Bool -> FCode Bool
forall a. a -> FCode a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
isSimpleScrut CgStgExpr
_ AltType
_ = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
isSimpleOp (StgFCallOp (CCall (CCallSpec CCallTarget
_ CCallConv
_ Safety
safe)) Type
_) [StgArg]
_ = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> FCode Bool) -> Bool -> FCode Bool
forall a b. (a -> b) -> a -> b
$! Bool -> Bool
not (Safety -> Bool
playSafe Safety
safe)
isSimpleOp (StgPrimOp PrimOp
DataToTagOp) [StgArg]
_ = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
isSimpleOp (StgPrimOp PrimOp
op) [StgArg]
stg_args = do
[CmmExpr]
arg_exprs <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
stg_args
StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> FCode Bool) -> Bool -> FCode Bool
forall a b. (a -> b) -> a -> b
$! StgToCmmConfig -> PrimOp -> [CmmExpr] -> Bool
shouldInlinePrimOp StgToCmmConfig
cfg PrimOp
op [CmmExpr]
arg_exprs
isSimpleOp (StgPrimCallOp PrimCall
_) [StgArg]
_ = Bool -> FCode Bool
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
chooseReturnBndrs :: Id -> AltType -> [CgStgAlt] -> [NonVoid Id]
chooseReturnBndrs :: Id -> AltType -> [GenStgAlt 'CodeGen] -> [NonVoid Id]
chooseReturnBndrs Id
bndr (PrimAlt PrimRep
_) [GenStgAlt 'CodeGen]
_alts
= [Id] -> [NonVoid Id]
assertNonVoidIds [Id
bndr]
chooseReturnBndrs Id
_bndr (MultiValAlt RepArity
n) [GenStgAlt 'CodeGen
alt]
= Bool -> SDoc -> [NonVoid Id] -> [NonVoid Id]
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([Id]
[BinderP 'CodeGen]
ids [Id] -> RepArity -> Bool
forall a. [a] -> RepArity -> Bool
`lengthIs` RepArity
n) (RepArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr RepArity
n SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ [Id] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [Id]
[BinderP 'CodeGen]
ids SDoc -> SDoc -> SDoc
forall doc. IsDoc doc => doc -> doc -> doc
$$ Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
_bndr) ([NonVoid Id] -> [NonVoid Id]) -> [NonVoid Id] -> [NonVoid Id]
forall a b. (a -> b) -> a -> b
$
[Id] -> [NonVoid Id]
assertNonVoidIds [Id]
[BinderP 'CodeGen]
ids
where ids :: [BinderP 'CodeGen]
ids = GenStgAlt 'CodeGen -> [BinderP 'CodeGen]
forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs GenStgAlt 'CodeGen
alt
chooseReturnBndrs Id
bndr (AlgAlt TyCon
_) [GenStgAlt 'CodeGen]
_alts
= [Id] -> [NonVoid Id]
assertNonVoidIds [Id
bndr]
chooseReturnBndrs Id
bndr AltType
PolyAlt [GenStgAlt 'CodeGen]
_alts
= [Id] -> [NonVoid Id]
assertNonVoidIds [Id
bndr]
chooseReturnBndrs Id
_ AltType
_ [GenStgAlt 'CodeGen]
_ = String -> [NonVoid Id]
forall a. HasCallStack => String -> a
panic String
"chooseReturnBndrs"
cgAlts :: (GcPlan,ReturnKind) -> NonVoid Id -> AltType -> [CgStgAlt]
-> FCode ReturnKind
cgAlts :: (GcPlan, ReturnKind)
-> NonVoid Id
-> AltType
-> [GenStgAlt 'CodeGen]
-> FCode ReturnKind
cgAlts (GcPlan, ReturnKind)
gc_plan NonVoid Id
_bndr AltType
PolyAlt [GenStgAlt 'CodeGen
alt]
= (GcPlan, ReturnKind) -> FCode ReturnKind -> FCode ReturnKind
forall a. (GcPlan, ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (GcPlan, ReturnKind)
gc_plan (CgStgExpr -> FCode ReturnKind
cgExpr (CgStgExpr -> FCode ReturnKind) -> CgStgExpr -> FCode ReturnKind
forall a b. (a -> b) -> a -> b
$ GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
cgAlts (GcPlan, ReturnKind)
gc_plan NonVoid Id
_bndr (MultiValAlt RepArity
_) [GenStgAlt 'CodeGen
alt]
= (GcPlan, ReturnKind) -> FCode ReturnKind -> FCode ReturnKind
forall a. (GcPlan, ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (GcPlan, ReturnKind)
gc_plan (CgStgExpr -> FCode ReturnKind
cgExpr (CgStgExpr -> FCode ReturnKind) -> CgStgExpr -> FCode ReturnKind
forall a b. (a -> b) -> a -> b
$ GenStgAlt 'CodeGen -> CgStgExpr
forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs GenStgAlt 'CodeGen
alt)
cgAlts (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr (PrimAlt PrimRep
_) [GenStgAlt 'CodeGen]
alts
= do { Platform
platform <- FCode Platform
getPlatform
; [(AltCon, CmmAGraphScoped)]
tagged_cmms <- (GcPlan, ReturnKind)
-> NonVoid Id
-> [GenStgAlt 'CodeGen]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr [GenStgAlt 'CodeGen]
alts
; let bndr_reg :: CmmReg
bndr_reg = LocalReg -> CmmReg
CmmLocal (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
bndr)
(AltCon
DEFAULT,CmmAGraphScoped
deflt) = [(AltCon, CmmAGraphScoped)] -> (AltCon, CmmAGraphScoped)
forall a. HasCallStack => [a] -> a
head [(AltCon, CmmAGraphScoped)]
tagged_cmms
tagged_cmms' :: [(Literal, CmmAGraphScoped)]
tagged_cmms' = [(Literal
lit,CmmAGraphScoped
code)
| (LitAlt Literal
lit, CmmAGraphScoped
code) <- [(AltCon, CmmAGraphScoped)]
tagged_cmms]
; CmmExpr
-> [(Literal, CmmAGraphScoped)] -> CmmAGraphScoped -> FCode ()
emitCmmLitSwitch (CmmReg -> CmmExpr
CmmReg CmmReg
bndr_reg) [(Literal, CmmAGraphScoped)]
tagged_cmms' CmmAGraphScoped
deflt
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly }
cgAlts (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr (AlgAlt TyCon
tycon) [GenStgAlt 'CodeGen]
alts
= do { Platform
platform <- FCode Platform
getPlatform
; (Maybe CmmAGraphScoped
mb_deflt, [(RepArity, CmmAGraphScoped)]
branches) <- (GcPlan, ReturnKind)
-> NonVoid Id
-> [GenStgAlt 'CodeGen]
-> FCode (Maybe CmmAGraphScoped, [(RepArity, CmmAGraphScoped)])
cgAlgAltRhss (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr [GenStgAlt 'CodeGen]
alts
; let !fam_sz :: RepArity
fam_sz = TyCon -> RepArity
tyConFamilySize TyCon
tycon
!bndr_reg :: CmmReg
bndr_reg = LocalReg -> CmmReg
CmmLocal (Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
bndr)
!ptag_expr :: CmmExpr
ptag_expr = Platform -> CmmExpr -> CmmExpr
cmmConstrTag1 Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
bndr_reg)
!branches' :: [(RepArity, CmmAGraphScoped)]
branches' = (RepArity -> RepArity)
-> (RepArity, CmmAGraphScoped) -> (RepArity, CmmAGraphScoped)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RepArity -> RepArity
forall a. Enum a => a -> a
succ ((RepArity, CmmAGraphScoped) -> (RepArity, CmmAGraphScoped))
-> [(RepArity, CmmAGraphScoped)] -> [(RepArity, CmmAGraphScoped)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RepArity, CmmAGraphScoped)]
branches
!maxpt :: RepArity
maxpt = Platform -> RepArity
mAX_PTR_TAG Platform
platform
(![(RepArity, CmmAGraphScoped)]
via_ptr, ![(RepArity, CmmAGraphScoped)]
via_info) = ((RepArity, CmmAGraphScoped) -> Bool)
-> [(RepArity, CmmAGraphScoped)]
-> ([(RepArity, CmmAGraphScoped)], [(RepArity, CmmAGraphScoped)])
forall a. (a -> Bool) -> [a] -> ([a], [a])
partition ((RepArity -> RepArity -> Bool
forall a. Ord a => a -> a -> Bool
< RepArity
maxpt) (RepArity -> Bool)
-> ((RepArity, CmmAGraphScoped) -> RepArity)
-> (RepArity, CmmAGraphScoped)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (RepArity, CmmAGraphScoped) -> RepArity
forall a b. (a, b) -> a
fst) [(RepArity, CmmAGraphScoped)]
branches'
!small :: Bool
small = Platform -> RepArity -> Bool
isSmallFamily Platform
platform RepArity
fam_sz
; if Bool
small Bool -> Bool -> Bool
|| [(RepArity, CmmAGraphScoped)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RepArity, CmmAGraphScoped)]
via_info
then
CmmExpr
-> [(RepArity, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> RepArity
-> RepArity
-> FCode ()
emitSwitch CmmExpr
ptag_expr [(RepArity, CmmAGraphScoped)]
branches' Maybe CmmAGraphScoped
mb_deflt RepArity
1
(if Bool
small then RepArity
fam_sz else RepArity
maxpt)
else
do
Profile
profile <- FCode Profile
getProfile
Bool
align_check <- StgToCmmConfig -> Bool
stgToCmmAlignCheck (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
let !untagged_ptr :: CmmExpr
untagged_ptr = Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
bndr_reg)
!itag_expr :: CmmExpr
itag_expr = Profile -> Bool -> CmmExpr -> CmmExpr
getConstrTag Profile
profile Bool
align_check CmmExpr
untagged_ptr
!info0 :: [(RepArity, CmmAGraphScoped)]
info0 = (RepArity -> RepArity)
-> (RepArity, CmmAGraphScoped) -> (RepArity, CmmAGraphScoped)
forall b c d. (b -> c) -> (b, d) -> (c, d)
forall (a :: * -> * -> *) b c d.
Arrow a =>
a b c -> a (b, d) (c, d)
first RepArity -> RepArity
forall a. Enum a => a -> a
pred ((RepArity, CmmAGraphScoped) -> (RepArity, CmmAGraphScoped))
-> [(RepArity, CmmAGraphScoped)] -> [(RepArity, CmmAGraphScoped)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(RepArity, CmmAGraphScoped)]
via_info
if [(RepArity, CmmAGraphScoped)] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(RepArity, CmmAGraphScoped)]
via_ptr then
CmmExpr
-> [(RepArity, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> RepArity
-> RepArity
-> FCode ()
emitSwitch CmmExpr
itag_expr [(RepArity, CmmAGraphScoped)]
info0 Maybe CmmAGraphScoped
mb_deflt RepArity
0 (RepArity
fam_sz RepArity -> RepArity -> RepArity
forall a. Num a => a -> a -> a
- RepArity
1)
else do
BlockId
infos_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
CmmTickScope
infos_scp <- FCode CmmTickScope
getTickScope
let spillover :: (RepArity, CmmAGraphScoped)
spillover = (RepArity
maxpt, (BlockId -> CmmAGraph
mkBranch BlockId
infos_lbl, CmmTickScope
infos_scp))
(Maybe CmmAGraphScoped
mb_shared_deflt, Maybe CmmAGraphScoped
mb_shared_branch) <- case Maybe CmmAGraphScoped
mb_deflt of
(Just (CmmAGraph
stmts, CmmTickScope
scp)) ->
do BlockId
lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
(Maybe CmmAGraphScoped, Maybe CmmAGraphScoped)
-> FCode (Maybe CmmAGraphScoped, Maybe CmmAGraphScoped)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ( CmmAGraphScoped -> Maybe CmmAGraphScoped
forall a. a -> Maybe a
Just (BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
lbl CmmTickScope
scp CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
stmts, CmmTickScope
scp)
, CmmAGraphScoped -> Maybe CmmAGraphScoped
forall a. a -> Maybe a
Just (BlockId -> CmmAGraph
mkBranch BlockId
lbl, CmmTickScope
scp))
Maybe CmmAGraphScoped
_ -> (Maybe CmmAGraphScoped, Maybe CmmAGraphScoped)
-> FCode (Maybe CmmAGraphScoped, Maybe CmmAGraphScoped)
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CmmAGraphScoped
forall a. Maybe a
Nothing, Maybe CmmAGraphScoped
forall a. Maybe a
Nothing)
CmmExpr
-> [(RepArity, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> RepArity
-> RepArity
-> FCode ()
emitSwitch CmmExpr
ptag_expr ((RepArity, CmmAGraphScoped)
spillover (RepArity, CmmAGraphScoped)
-> [(RepArity, CmmAGraphScoped)] -> [(RepArity, CmmAGraphScoped)]
forall a. a -> [a] -> [a]
: [(RepArity, CmmAGraphScoped)]
via_ptr) Maybe CmmAGraphScoped
mb_shared_deflt RepArity
1 RepArity
maxpt
BlockId
join_lbl <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
CmmAGraph -> FCode ()
emit (BlockId -> CmmAGraph
mkBranch BlockId
join_lbl)
BlockId -> FCode ()
emitLabel BlockId
infos_lbl
CmmExpr
-> [(RepArity, CmmAGraphScoped)]
-> Maybe CmmAGraphScoped
-> RepArity
-> RepArity
-> FCode ()
emitSwitch CmmExpr
itag_expr [(RepArity, CmmAGraphScoped)]
info0 Maybe CmmAGraphScoped
mb_shared_branch
(RepArity
maxpt RepArity -> RepArity -> RepArity
forall a. Num a => a -> a -> a
- RepArity
1) (RepArity
fam_sz RepArity -> RepArity -> RepArity
forall a. Num a => a -> a -> a
- RepArity
1)
BlockId -> FCode ()
emitLabel BlockId
join_lbl
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly }
cgAlts (GcPlan, ReturnKind)
_ NonVoid Id
_ AltType
_ [GenStgAlt 'CodeGen]
_ = String -> FCode ReturnKind
forall a. HasCallStack => String -> a
panic String
"cgAlts"
cgAlgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-> FCode ( Maybe CmmAGraphScoped
, [(ConTagZ, CmmAGraphScoped)] )
cgAlgAltRhss :: (GcPlan, ReturnKind)
-> NonVoid Id
-> [GenStgAlt 'CodeGen]
-> FCode (Maybe CmmAGraphScoped, [(RepArity, CmmAGraphScoped)])
cgAlgAltRhss (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr [GenStgAlt 'CodeGen]
alts
= do { [(AltCon, CmmAGraphScoped)]
tagged_cmms <- (GcPlan, ReturnKind)
-> NonVoid Id
-> [GenStgAlt 'CodeGen]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr [GenStgAlt 'CodeGen]
alts
; let { mb_deflt :: Maybe CmmAGraphScoped
mb_deflt = case [(AltCon, CmmAGraphScoped)]
tagged_cmms of
((AltCon
DEFAULT,CmmAGraphScoped
rhs) : [(AltCon, CmmAGraphScoped)]
_) -> CmmAGraphScoped -> Maybe CmmAGraphScoped
forall a. a -> Maybe a
Just CmmAGraphScoped
rhs
[(AltCon, CmmAGraphScoped)]
_other -> Maybe CmmAGraphScoped
forall a. Maybe a
Nothing
; branches :: [(RepArity, CmmAGraphScoped)]
branches = [ (DataCon -> RepArity
dataConTagZ DataCon
con, CmmAGraphScoped
cmm)
| (DataAlt DataCon
con, CmmAGraphScoped
cmm) <- [(AltCon, CmmAGraphScoped)]
tagged_cmms ]
}
; (Maybe CmmAGraphScoped, [(RepArity, CmmAGraphScoped)])
-> FCode (Maybe CmmAGraphScoped, [(RepArity, CmmAGraphScoped)])
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CmmAGraphScoped
mb_deflt, [(RepArity, CmmAGraphScoped)]
branches)
}
cgAltRhss :: (GcPlan,ReturnKind) -> NonVoid Id -> [CgStgAlt]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss :: (GcPlan, ReturnKind)
-> NonVoid Id
-> [GenStgAlt 'CodeGen]
-> FCode [(AltCon, CmmAGraphScoped)]
cgAltRhss (GcPlan, ReturnKind)
gc_plan NonVoid Id
bndr [GenStgAlt 'CodeGen]
alts = do
Platform
platform <- FCode Platform
getPlatform
let
base_reg :: LocalReg
base_reg = Platform -> NonVoid Id -> LocalReg
idToReg Platform
platform NonVoid Id
bndr
cg_alt :: CgStgAlt -> FCode (AltCon, CmmAGraphScoped)
cg_alt :: GenStgAlt 'CodeGen -> FCode (AltCon, CmmAGraphScoped)
cg_alt GenStgAlt{alt_con :: forall (pass :: StgPass). GenStgAlt pass -> AltCon
alt_con=AltCon
con, alt_bndrs :: forall (pass :: StgPass). GenStgAlt pass -> [BinderP pass]
alt_bndrs=[BinderP 'CodeGen]
bndrs, alt_rhs :: forall (pass :: StgPass). GenStgAlt pass -> GenStgExpr pass
alt_rhs=CgStgExpr
rhs}
= FCode AltCon -> FCode (AltCon, CmmAGraphScoped)
forall a. FCode a -> FCode (a, CmmAGraphScoped)
getCodeScoped (FCode AltCon -> FCode (AltCon, CmmAGraphScoped))
-> FCode AltCon -> FCode (AltCon, CmmAGraphScoped)
forall a b. (a -> b) -> a -> b
$
(GcPlan, ReturnKind) -> FCode AltCon -> FCode AltCon
forall a. (GcPlan, ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (GcPlan, ReturnKind)
gc_plan (FCode AltCon -> FCode AltCon) -> FCode AltCon -> FCode AltCon
forall a b. (a -> b) -> a -> b
$
do { [LocalReg]
_ <- AltCon -> LocalReg -> [NonVoid Id] -> FCode [LocalReg]
bindConArgs AltCon
con LocalReg
base_reg ([Id] -> [NonVoid Id]
assertNonVoidIds [Id]
[BinderP 'CodeGen]
bndrs)
; ReturnKind
_ <- CgStgExpr -> FCode ReturnKind
cgExpr CgStgExpr
rhs
; AltCon -> FCode AltCon
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return AltCon
con }
[FCode (AltCon, CmmAGraphScoped)]
-> FCode [(AltCon, CmmAGraphScoped)]
forall a. [FCode a] -> FCode [a]
forkAlts ((GenStgAlt 'CodeGen -> FCode (AltCon, CmmAGraphScoped))
-> [GenStgAlt 'CodeGen] -> [FCode (AltCon, CmmAGraphScoped)]
forall a b. (a -> b) -> [a] -> [b]
map GenStgAlt 'CodeGen -> FCode (AltCon, CmmAGraphScoped)
cg_alt [GenStgAlt 'CodeGen]
alts)
maybeAltHeapCheck :: (GcPlan,ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck :: forall a. (GcPlan, ReturnKind) -> FCode a -> FCode a
maybeAltHeapCheck (GcPlan
NoGcInAlts,ReturnKind
_) FCode a
code = FCode a
code
maybeAltHeapCheck (GcInAlts [LocalReg]
regs, ReturnKind
AssignedDirectly) FCode a
code =
[LocalReg] -> FCode a -> FCode a
forall a. [LocalReg] -> FCode a -> FCode a
altHeapCheck [LocalReg]
regs FCode a
code
maybeAltHeapCheck (GcInAlts [LocalReg]
regs, ReturnedTo BlockId
lret RepArity
off) FCode a
code =
[LocalReg] -> BlockId -> RepArity -> FCode a -> FCode a
forall a. [LocalReg] -> BlockId -> RepArity -> FCode a -> FCode a
altHeapCheckReturnsTo [LocalReg]
regs BlockId
lret RepArity
off FCode a
code
cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind
cgConApp :: DataCon -> ConstructorNumber -> [StgArg] -> FCode ReturnKind
cgConApp DataCon
con ConstructorNumber
mn [StgArg]
stg_args
| DataCon -> Bool
isUnboxedTupleDataCon DataCon
con
= do { [CmmExpr]
arg_exprs <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
stg_args
; RepArity -> FCode ()
tickyUnboxedTupleReturn ([CmmExpr] -> RepArity
forall a. [a] -> RepArity
forall (t :: * -> *) a. Foldable t => t a -> RepArity
length [CmmExpr]
arg_exprs)
; [CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr]
arg_exprs }
| Bool
otherwise
= Bool -> SDoc -> FCode ReturnKind -> FCode ReturnKind
forall a. HasCallStack => Bool -> SDoc -> a -> a
assertPpr ([StgArg]
stg_args [StgArg] -> RepArity -> Bool
forall a. [a] -> RepArity -> Bool
`lengthIs` DataCon -> RepArity
countConRepArgs DataCon
con)
(DataCon -> SDoc
forall a. Outputable a => a -> SDoc
ppr DataCon
con SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc
parens (RepArity -> SDoc
forall a. Outputable a => a -> SDoc
ppr (DataCon -> RepArity
countConRepArgs DataCon
con)) SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> [StgArg] -> SDoc
forall a. Outputable a => a -> SDoc
ppr [StgArg]
stg_args) (FCode ReturnKind -> FCode ReturnKind)
-> FCode ReturnKind -> FCode ReturnKind
forall a b. (a -> b) -> a -> b
$
do { (CgIdInfo
idinfo, FCode CmmAGraph
fcode_init) <- Id
-> ConstructorNumber
-> Bool
-> CostCentreStack
-> DataCon
-> [NonVoid StgArg]
-> FCode (CgIdInfo, FCode CmmAGraph)
buildDynCon (DataCon -> Id
dataConWorkId DataCon
con) ConstructorNumber
mn Bool
False
CostCentreStack
currentCCS DataCon
con ([StgArg] -> [NonVoid StgArg]
assertNonVoidStgArgs [StgArg]
stg_args)
; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> FCode CmmAGraph -> FCode ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< FCode CmmAGraph
fcode_init
; RepArity -> FCode ()
tickyReturnNewCon ([StgArg] -> RepArity
forall a. [a] -> RepArity
forall (t :: * -> *) a. Foldable t => t a -> RepArity
length [StgArg]
stg_args)
; [CmmExpr] -> FCode ReturnKind
emitReturn [CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
idinfo] }
cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
cgIdApp :: Id -> [StgArg] -> FCode ReturnKind
cgIdApp Id
fun_id [StgArg]
args = do
Platform
platform <- FCode Platform
getPlatform
CgIdInfo
fun_info <- Id -> FCode CgIdInfo
getCgIdInfo Id
fun_id
StgToCmmConfig
cfg <- FCode StgToCmmConfig
getStgToCmmConfig
Maybe SelfLoopInfo
self_loop <- FCode (Maybe SelfLoopInfo)
getSelfLoop
let profile :: Profile
profile = StgToCmmConfig -> Profile
stgToCmmProfile StgToCmmConfig
cfg
fun_arg :: StgArg
fun_arg = Id -> StgArg
StgVarArg Id
fun_id
fun_name :: Name
fun_name = Id -> Name
idName Id
fun_id
fun :: CmmExpr
fun = CgIdInfo -> CmmExpr
idInfoToAmode CgIdInfo
fun_info
lf_info :: LambdaFormInfo
lf_info = CgIdInfo -> LambdaFormInfo
cg_lf CgIdInfo
fun_info
n_args :: RepArity
n_args = [StgArg] -> RepArity
forall a. [a] -> RepArity
forall (t :: * -> *) a. Foldable t => t a -> RepArity
length [StgArg]
args
v_args :: RepArity
v_args = [StgArg] -> RepArity
forall a. [a] -> RepArity
forall (t :: * -> *) a. Foldable t => t a -> RepArity
length ([StgArg] -> RepArity) -> [StgArg] -> RepArity
forall a b. (a -> b) -> a -> b
$ (StgArg -> Bool) -> [StgArg] -> [StgArg]
forall a. (a -> Bool) -> [a] -> [a]
filter ((() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Type -> Bool) -> (StgArg -> Type) -> StgArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. StgArg -> Type
stgArgType) [StgArg]
args
case StgToCmmConfig
-> Name
-> Id
-> LambdaFormInfo
-> RepArity
-> RepArity
-> CgLoc
-> Maybe SelfLoopInfo
-> CallMethod
getCallMethod StgToCmmConfig
cfg Name
fun_name Id
fun_id LambdaFormInfo
lf_info RepArity
n_args RepArity
v_args (CgIdInfo -> CgLoc
cg_loc CgIdInfo
fun_info) Maybe SelfLoopInfo
self_loop of
CallMethod
ReturnIt
| (() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Id -> Type
idType Id
fun_id) -> [CmmExpr] -> FCode ReturnKind
emitReturn []
| Bool
otherwise -> [CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr
fun]
CallMethod
InferedReturnIt
| (() :: Constraint) => Type -> Bool
Type -> Bool
isZeroBitTy (Id -> Type
idType Id
fun_id) -> FCode ()
trace FCode () -> FCode ReturnKind -> FCode ReturnKind
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> [CmmExpr] -> FCode ReturnKind
emitReturn []
| Bool
otherwise -> FCode ()
trace FCode () -> FCode () -> FCode ()
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> FCode ()
assertTag FCode () -> FCode ReturnKind -> FCode ReturnKind
forall a b. FCode a -> FCode b -> FCode b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>>
[CmmExpr] -> FCode ReturnKind
emitReturn [CmmExpr
fun]
where
trace :: FCode ()
trace = do
FCode ()
tickyTagged
Unique
use_id <- FCode Unique
newUnique
CLabel
_lbl <- Unique -> NonVoid Id -> FCode CLabel
emitTickyCounterTag Unique
use_id (Id -> NonVoid Id
forall a. a -> NonVoid a
NonVoid Id
fun_id)
Unique -> Id -> FCode ()
tickyTagSkip Unique
use_id Id
fun_id
assertTag :: FCode ()
assertTag = FCode () -> FCode ()
whenCheckTags (FCode () -> FCode ()) -> FCode () -> FCode ()
forall a b. (a -> b) -> a -> b
$ do
Module
mod <- FCode Module
getModuleName
String -> CmmExpr -> FCode ()
emitTagAssertion (SDoc -> String
forall a. Outputable a => a -> String
showPprUnsafe
(String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"TagCheck failed on entry in" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Module -> SDoc
forall a. Outputable a => a -> SDoc
ppr Module
mod SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> String -> SDoc
forall doc. IsLine doc => String -> doc
text String
"- value:" SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<> Id -> SDoc
forall a. Outputable a => a -> SDoc
ppr Id
fun_id SDoc -> SDoc -> SDoc
forall doc. IsLine doc => doc -> doc -> doc
<+> Platform -> CmmExpr -> SDoc
forall env a. OutputableP env a => env -> a -> SDoc
pdoc Platform
platform CmmExpr
fun))
CmmExpr
fun
CallMethod
EnterIt -> Bool -> FCode ReturnKind -> FCode ReturnKind
forall a. HasCallStack => Bool -> a -> a
assert ([StgArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [StgArg]
args) (FCode ReturnKind -> FCode ReturnKind)
-> FCode ReturnKind -> FCode ReturnKind
forall a b. (a -> b) -> a -> b
$
CmmExpr -> FCode ReturnKind
emitEnter CmmExpr
fun
CallMethod
SlowCall -> do
{ LambdaFormInfo -> [StgArg] -> FCode ()
tickySlowCall LambdaFormInfo
lf_info [StgArg]
args
; FastString -> FCode ()
emitComment (FastString -> FCode ()) -> FastString -> FCode ()
forall a b. (a -> b) -> a -> b
$ String -> FastString
mkFastString String
"slowCall"
; CmmExpr -> [StgArg] -> FCode ReturnKind
slowCall CmmExpr
fun [StgArg]
args }
DirectEntry CLabel
lbl RepArity
arity -> do
{ RepArity -> [StgArg] -> FCode ()
tickyDirectCall RepArity
arity [StgArg]
args
; if Profile -> LambdaFormInfo -> Bool
nodeMustPointToIt Profile
profile LambdaFormInfo
lf_info
then Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
directCall Convention
NativeNodeCall CLabel
lbl RepArity
arity (StgArg
fun_argStgArg -> [StgArg] -> [StgArg]
forall a. a -> [a] -> [a]
:[StgArg]
args)
else Convention -> CLabel -> RepArity -> [StgArg] -> FCode ReturnKind
directCall Convention
NativeDirectCall CLabel
lbl RepArity
arity [StgArg]
args }
JumpToIt BlockId
blk_id [LocalReg]
lne_regs -> do
{ FCode ()
adjustHpBackwards
; [CmmExpr]
cmm_args <- [StgArg] -> FCode [CmmExpr]
getNonVoidArgAmodes [StgArg]
args
; [LocalReg] -> [CmmExpr] -> FCode ()
emitMultiAssign [LocalReg]
lne_regs [CmmExpr]
cmm_args
; CmmAGraph -> FCode ()
emit (BlockId -> CmmAGraph
mkBranch BlockId
blk_id)
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly }
emitEnter :: CmmExpr -> FCode ReturnKind
emitEnter :: CmmExpr -> FCode ReturnKind
emitEnter CmmExpr
fun = do
{ Platform
platform <- FCode Platform
getPlatform
; Profile
profile <- FCode Profile
getProfile
; FCode ()
adjustHpBackwards
; Sequel
sequel <- FCode Sequel
getSequel
; RepArity
updfr_off <- FCode RepArity
getUpdFrameOff
; Bool
align_check <- StgToCmmConfig -> Bool
stgToCmmAlignCheck (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
; case Sequel
sequel of
Sequel
Return -> do
{ let entry :: CmmExpr
entry = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform
(CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$ Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check
(CmmExpr -> CmmExpr) -> CmmExpr -> CmmExpr
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg
; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ Profile
-> Convention -> CmmExpr -> [CmmExpr] -> RepArity -> CmmAGraph
mkJump Profile
profile Convention
NativeNodeCall CmmExpr
entry
[Platform -> CmmExpr -> CmmExpr
cmmUntag Platform
platform CmmExpr
fun] RepArity
updfr_off
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
}
AssignTo [LocalReg]
res_regs Bool
_ -> do
{ BlockId
lret <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
; BlockId
lcall <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
; RepArity
updfr_off <- FCode RepArity
getUpdFrameOff
; Bool
align_check <- StgToCmmConfig -> Bool
stgToCmmAlignCheck (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
; let (RepArity
off, [GlobalReg]
_, CmmAGraph
copyin) = Profile
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (RepArity, [GlobalReg], CmmAGraph)
copyInOflow Profile
profile Convention
NativeReturn (BlockId -> Area
Young BlockId
lret) [LocalReg]
res_regs []
; let area :: Area
area = BlockId -> Area
Young BlockId
lret
; let (RepArity
outArgs, [GlobalReg]
regs, CmmAGraph
copyout) = Profile
-> Convention
-> Transfer
-> Area
-> [CmmExpr]
-> RepArity
-> [CmmExpr]
-> (RepArity, [GlobalReg], CmmAGraph)
copyOutOflow Profile
profile Convention
NativeNodeCall Transfer
Call Area
area
[CmmExpr
fun] RepArity
updfr_off []
; let entry :: CmmExpr
entry = Platform -> CmmExpr -> CmmExpr
entryCode Platform
platform (Platform -> Bool -> CmmExpr -> CmmExpr
closureInfoPtr Platform
platform Bool
align_check (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg))
the_call :: CmmAGraph
the_call = CmmExpr
-> Maybe BlockId
-> RepArity
-> RepArity
-> RepArity
-> [GlobalReg]
-> CmmAGraph
toCall CmmExpr
entry (BlockId -> Maybe BlockId
forall a. a -> Maybe a
Just BlockId
lret) RepArity
updfr_off RepArity
off RepArity
outArgs [GlobalReg]
regs
; CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
; CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$
CmmAGraph
copyout CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmExpr -> BlockId -> BlockId -> Maybe Bool -> CmmAGraph
mkCbranch (Platform -> CmmExpr -> CmmExpr
cmmIsTagged Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
nodeReg))
BlockId
lret BlockId
lcall Maybe Bool
forall a. Maybe a
Nothing CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
BlockId -> CmmAGraphScoped -> CmmAGraph
outOfLine BlockId
lcall (CmmAGraph
the_call,CmmTickScope
tscope) CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
lret CmmTickScope
tscope CmmAGraph -> CmmAGraph -> CmmAGraph
<*>
CmmAGraph
copyin
; ReturnKind -> FCode ReturnKind
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> RepArity -> ReturnKind
ReturnedTo BlockId
lret RepArity
off)
}
}
cgTick :: StgTickish -> FCode ()
cgTick :: StgTickish -> FCode ()
cgTick StgTickish
tick
= do { Platform
platform <- FCode Platform
getPlatform
; case StgTickish
tick of
ProfNote CostCentre
cc Bool
t Bool
p -> CostCentre -> Bool -> Bool -> FCode ()
emitSetCCC CostCentre
cc Bool
t Bool
p
HpcTick Module
m RepArity
n -> CmmAGraph -> FCode ()
emit (Platform -> Module -> RepArity -> CmmAGraph
mkTickBox Platform
platform Module
m RepArity
n)
SourceNote RealSrcSpan
s String
n -> CmmTickish -> FCode ()
emitTick (CmmTickish -> FCode ()) -> CmmTickish -> FCode ()
forall a b. (a -> b) -> a -> b
$ RealSrcSpan -> String -> CmmTickish
forall (pass :: TickishPass).
RealSrcSpan -> String -> GenTickish pass
SourceNote RealSrcSpan
s String
n
StgTickish
_other -> () -> FCode ()
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
}