module GHC.StgToCmm.Foreign (
cgForeignCall,
emitPrimCall, emitCCall,
emitForeignCall,
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
) where
import GhcPrelude hiding( succ, (<*>) )
import StgSyn
import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
import GHC.StgToCmm.Env
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout
import BlockId (newBlockId)
import Cmm
import CmmUtils
import MkGraph
import Type
import RepType
import CLabel
import SMRep
import ForeignCall
import DynFlags
import Maybes
import Outputable
import UniqSupply
import BasicTypes
import TyCoRep
import TysPrim
import Util (zipEqual)
import Control.Monad
cgForeignCall :: ForeignCall
-> Type
-> [StgArg]
-> Type
-> FCode ReturnKind
cgForeignCall :: ForeignCall -> Type -> [StgArg] -> Type -> FCode ReturnKind
cgForeignCall (CCall (CCallSpec CCallTarget
target CCallConv
cconv Safety
safety)) Type
typ [StgArg]
stg_args Type
res_ty
= do { DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; let
call_size :: [(CmmExpr, b)] -> Maybe Int
call_size [(CmmExpr, b)]
args
| CCallConv
StdCallConv <- CCallConv
cconv = Int -> Maybe Int
forall a. a -> Maybe a
Just ([Int] -> Int
forall (t :: * -> *) a. (Foldable t, Num a) => t a -> a
sum (((CmmExpr, b) -> Int) -> [(CmmExpr, b)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (CmmExpr, b) -> Int
forall b. (CmmExpr, b) -> Int
arg_size [(CmmExpr, b)]
args))
| Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing
arg_size :: (CmmExpr, b) -> Int
arg_size (CmmExpr
arg, b
_) = Int -> Int -> Int
forall a. Ord a => a -> a -> a
max (Width -> Int
widthInBytes (Width -> Int) -> Width -> Int
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth (CmmType -> Width) -> CmmType -> Width
forall a b. (a -> b) -> a -> b
$ DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
arg)
(DynFlags -> Int
wORD_SIZE DynFlags
dflags)
; [(CmmExpr, ForeignHint)]
cmm_args <- [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs [StgArg]
stg_args Type
typ
; ([LocalReg]
res_regs, [ForeignHint]
res_hints) <- Type -> FCode ([LocalReg], [ForeignHint])
newUnboxedTupleRegs Type
res_ty
; let (([CmmExpr]
call_args, [ForeignHint]
arg_hints), CmmExpr
cmm_target)
= case CCallTarget
target of
StaticTarget SourceText
_ CLabelString
_ Maybe UnitId
_ Bool
False ->
String -> (([CmmExpr], [ForeignHint]), CmmExpr)
forall a. String -> a
panic String
"cgForeignCall: unexpected FFI value import"
StaticTarget SourceText
_ CLabelString
lbl Maybe UnitId
mPkgId Bool
True
-> let labelSource :: ForeignLabelSource
labelSource
= case Maybe UnitId
mPkgId of
Maybe UnitId
Nothing -> ForeignLabelSource
ForeignLabelInThisPackage
Just UnitId
pkgId -> UnitId -> ForeignLabelSource
ForeignLabelInPackage UnitId
pkgId
size :: Maybe Int
size = [(CmmExpr, ForeignHint)] -> Maybe Int
forall b. [(CmmExpr, b)] -> Maybe Int
call_size [(CmmExpr, ForeignHint)]
cmm_args
in ( [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
cmm_args
, CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel
(CLabelString
-> Maybe Int -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel CLabelString
lbl Maybe Int
size ForeignLabelSource
labelSource FunctionOrData
IsFunction)))
CCallTarget
DynamicTarget -> case [(CmmExpr, ForeignHint)]
cmm_args of
(CmmExpr
fn,ForeignHint
_):[(CmmExpr, ForeignHint)]
rest -> ([(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
rest, CmmExpr
fn)
[] -> String -> (([CmmExpr], [ForeignHint]), CmmExpr)
forall a. String -> a
panic String
"cgForeignCall []"
fc :: ForeignConvention
fc = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
cconv [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
CmmMayReturn
call_target :: ForeignTarget
call_target = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
cmm_target ForeignConvention
fc
; Sequel
sequel <- FCode Sequel
getSequel
; case Sequel
sequel of
AssignTo [LocalReg]
assign_to_these Bool
_ ->
Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
assign_to_these ForeignTarget
call_target [CmmExpr]
call_args
Sequel
_something_else ->
do { ReturnKind
_ <- Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
res_regs ForeignTarget
call_target [CmmExpr]
call_args
; [CmmExpr] -> FCode ReturnKind
emitReturn ((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]
res_regs)
}
}
emitCCall :: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall :: [(LocalReg, ForeignHint)]
-> CmmExpr -> [(CmmExpr, ForeignHint)] -> FCode ()
emitCCall [(LocalReg, ForeignHint)]
hinted_results CmmExpr
fn [(CmmExpr, ForeignHint)]
hinted_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
$ Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
PlayRisky [LocalReg]
results ForeignTarget
target [CmmExpr]
args
where
([CmmExpr]
args, [ForeignHint]
arg_hints) = [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
hinted_args
([LocalReg]
results, [ForeignHint]
result_hints) = [(LocalReg, ForeignHint)] -> ([LocalReg], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(LocalReg, ForeignHint)]
hinted_results
target :: ForeignTarget
target = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
fn ForeignConvention
fc
fc :: ForeignConvention
fc = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
CCallConv [ForeignHint]
arg_hints [ForeignHint]
result_hints CmmReturnInfo
CmmMayReturn
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
emitPrimCall :: [LocalReg] -> CallishMachOp -> [CmmExpr] -> FCode ()
emitPrimCall [LocalReg]
res CallishMachOp
op [CmmExpr]
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
$ Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
PlayRisky [LocalReg]
res (CallishMachOp -> ForeignTarget
PrimTarget CallishMachOp
op) [CmmExpr]
args
emitForeignCall
:: Safety
-> [CmmFormal]
-> ForeignTarget
-> [CmmActual]
-> FCode ReturnKind
emitForeignCall :: Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
results ForeignTarget
target [CmmExpr]
args
| Bool -> Bool
not (Safety -> Bool
playSafe Safety
safety) = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
let (CmmAGraph
caller_save, CmmAGraph
caller_load) = DynFlags -> (CmmAGraph, CmmAGraph)
callerSaveVolatileRegs DynFlags
dflags
CmmAGraph -> FCode ()
emit CmmAGraph
caller_save
ForeignTarget
target' <- ForeignTarget -> FCode ForeignTarget
load_target_into_temp ForeignTarget
target
[CmmExpr]
args' <- (CmmExpr -> FCode CmmExpr) -> [CmmExpr] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> FCode CmmExpr
maybe_assign_temp [CmmExpr]
args
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ ForeignTarget -> [LocalReg] -> [CmmExpr] -> CmmAGraph
mkUnsafeCall ForeignTarget
target' [LocalReg]
results [CmmExpr]
args'
CmmAGraph -> FCode ()
emit CmmAGraph
caller_load
ReturnKind -> FCode ReturnKind
forall (m :: * -> *) a. Monad m => a -> m a
return ReturnKind
AssignedDirectly
| Bool
otherwise = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
Int
updfr_off <- FCode Int
getUpdFrameOff
ForeignTarget
target' <- ForeignTarget -> FCode ForeignTarget
load_target_into_temp ForeignTarget
target
[CmmExpr]
args' <- (CmmExpr -> FCode CmmExpr) -> [CmmExpr] -> FCode [CmmExpr]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM CmmExpr -> FCode CmmExpr
maybe_assign_temp [CmmExpr]
args
BlockId
k <- FCode BlockId
forall (m :: * -> *). MonadUnique m => m BlockId
newBlockId
let (Int
off, [GlobalReg]
_, CmmAGraph
copyout) = DynFlags
-> Convention
-> Area
-> [LocalReg]
-> [LocalReg]
-> (Int, [GlobalReg], CmmAGraph)
copyInOflow DynFlags
dflags Convention
NativeReturn (BlockId -> Area
Young BlockId
k) [LocalReg]
results []
CmmTickScope
tscope <- FCode CmmTickScope
getTickScope
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$
( CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Area -> Int -> CmmExpr
CmmStackSlot (BlockId -> Area
Young BlockId
k) (Width -> Int
widthInBytes (DynFlags -> Width
wordWidth DynFlags
dflags)))
(CmmLit -> CmmExpr
CmmLit (BlockId -> CmmLit
CmmBlock BlockId
k))
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmNode O C -> CmmAGraph
mkLast (CmmForeignCall :: ForeignTarget
-> [LocalReg]
-> [CmmExpr]
-> BlockId
-> Int
-> Int
-> Bool
-> CmmNode O C
CmmForeignCall { tgt :: ForeignTarget
tgt = ForeignTarget
target'
, res :: [LocalReg]
res = [LocalReg]
results
, args :: [CmmExpr]
args = [CmmExpr]
args'
, succ :: BlockId
succ = BlockId
k
, ret_args :: Int
ret_args = Int
off
, ret_off :: Int
ret_off = Int
updfr_off
, intrbl :: Bool
intrbl = Safety -> Bool
playInterruptible Safety
safety })
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> BlockId -> CmmTickScope -> CmmAGraph
mkLabel BlockId
k CmmTickScope
tscope
CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
copyout
)
ReturnKind -> FCode ReturnKind
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockId -> Int -> ReturnKind
ReturnedTo BlockId
k Int
off)
load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
load_target_into_temp :: ForeignTarget -> FCode ForeignTarget
load_target_into_temp (ForeignTarget CmmExpr
expr ForeignConvention
conv) = do
CmmExpr
tmp <- CmmExpr -> FCode CmmExpr
maybe_assign_temp CmmExpr
expr
ForeignTarget -> FCode ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
tmp ForeignConvention
conv)
load_target_into_temp other_target :: ForeignTarget
other_target@(PrimTarget CallishMachOp
_) =
ForeignTarget -> FCode ForeignTarget
forall (m :: * -> *) a. Monad m => a -> m a
return ForeignTarget
other_target
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp CmmExpr
e = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
LocalReg
reg <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmExpr -> CmmType
cmmExprType DynFlags
dflags CmmExpr
e)
CmmReg -> CmmExpr -> FCode ()
emitAssign (LocalReg -> CmmReg
CmmLocal LocalReg
reg) CmmExpr
e
CmmExpr -> FCode CmmExpr
forall (m :: * -> *) a. Monad m => a -> m a
return (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
reg))
emitSaveThreadState :: FCode ()
emitSaveThreadState :: FCode ()
emitSaveThreadState = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmAGraph
code <- DynFlags -> FCode CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags
CmmAGraph -> FCode ()
emit CmmAGraph
code
saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState :: DynFlags -> m CmmAGraph
saveThreadState DynFlags
dflags = do
LocalReg
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
CmmAGraph
close_nursery <- DynFlags -> LocalReg -> m CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
closeNursery DynFlags
dflags LocalReg
tso
CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr,
CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags
(CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags
(CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso))
(DynFlags -> Int
tso_stackobj DynFlags
dflags))
(DynFlags -> CmmType
bWord DynFlags
dflags))
(DynFlags -> Int
stack_SP DynFlags
dflags))
CmmExpr
spExpr,
CmmAGraph
close_nursery,
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags then
CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso)) (DynFlags -> Int
tso_CCCS DynFlags
dflags)) CmmExpr
cccsExpr
else CmmAGraph
mkNop
]
emitCloseNursery :: FCode ()
emitCloseNursery :: FCode ()
emitCloseNursery = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
LocalReg
tso <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
CmmAGraph
code <- DynFlags -> LocalReg -> FCode CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
closeNursery DynFlags
dflags LocalReg
tso
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
code
closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
closeNursery :: DynFlags -> LocalReg -> m CmmAGraph
closeNursery DynFlags
df LocalReg
tso = do
let tsoreg :: CmmReg
tsoreg = LocalReg -> CmmReg
CmmLocal LocalReg
tso
CmmReg
cnreg <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cnreg CmmExpr
currentNurseryExpr,
CmmExpr -> CmmExpr -> CmmAGraph
mkStore (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free DynFlags
df CmmReg
cnreg) (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df CmmExpr
hpExpr Int
1),
let alloc :: CmmExpr
alloc =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
df)
[ DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df CmmExpr
hpExpr Int
1
, CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start DynFlags
df CmmReg
cnreg) (DynFlags -> CmmType
bWord DynFlags
df)
]
alloc_limit :: CmmExpr
alloc_limit = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (DynFlags -> Int
tso_alloc_limit DynFlags
df)
in
CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Sub Width
W64)
[ CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
alloc_limit CmmType
b64
, MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_WordTo64 DynFlags
df) [CmmExpr
alloc] ])
]
emitLoadThreadState :: FCode ()
emitLoadThreadState :: FCode ()
emitLoadThreadState = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
CmmAGraph
code <- DynFlags -> FCode CmmAGraph
forall (m :: * -> *). MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags
CmmAGraph -> FCode ()
emit CmmAGraph
code
loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState :: DynFlags -> m CmmAGraph
loadThreadState DynFlags
dflags = do
LocalReg
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
LocalReg
stack <- CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
gcWord DynFlags
dflags)
CmmAGraph
open_nursery <- DynFlags -> LocalReg -> m CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
openNursery DynFlags
dflags LocalReg
tso
CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr,
CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
stack) (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso)) (DynFlags -> Int
tso_stackobj DynFlags
dflags)) (DynFlags -> CmmType
bWord DynFlags
dflags)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
spReg (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
stack)) (DynFlags -> Int
stack_SP DynFlags
dflags)) (DynFlags -> CmmType
bWord DynFlags
dflags)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
spLimReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
dflags (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
stack)) (DynFlags -> Int
stack_STACK DynFlags
dflags))
(DynFlags -> Int
rESERVED_STACK_WORDS DynFlags
dflags)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpAllocReg (DynFlags -> CmmExpr
zeroExpr DynFlags
dflags),
CmmAGraph
open_nursery,
if GeneralFlag -> DynFlags -> Bool
gopt GeneralFlag
Opt_SccProfilingOn DynFlags
dflags
then CmmExpr -> CmmAGraph
storeCurCCS
(CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso))
(DynFlags -> Int
tso_CCCS DynFlags
dflags)) (DynFlags -> CmmType
ccsType DynFlags
dflags))
else CmmAGraph
mkNop
]
emitOpenNursery :: FCode ()
emitOpenNursery :: FCode ()
emitOpenNursery = do
DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
LocalReg
tso <- CmmType -> FCode LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
dflags)
CmmAGraph
code <- DynFlags -> LocalReg -> FCode CmmAGraph
forall (m :: * -> *).
MonadUnique m =>
DynFlags -> LocalReg -> m CmmAGraph
openNursery DynFlags
dflags LocalReg
tso
CmmAGraph -> FCode ()
emit (CmmAGraph -> FCode ()) -> CmmAGraph -> FCode ()
forall a b. (a -> b) -> a -> b
$ CmmReg -> CmmExpr -> CmmAGraph
mkAssign (LocalReg -> CmmReg
CmmLocal LocalReg
tso) CmmExpr
currentTSOExpr CmmAGraph -> CmmAGraph -> CmmAGraph
<*> CmmAGraph
code
openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
openNursery :: DynFlags -> LocalReg -> m CmmAGraph
openNursery DynFlags
df LocalReg
tso = do
let tsoreg :: CmmReg
tsoreg = LocalReg -> CmmReg
CmmLocal LocalReg
tso
CmmReg
cnreg <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
CmmReg
bdfreereg <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
CmmReg
bdstartreg <- LocalReg -> CmmReg
CmmLocal (LocalReg -> CmmReg) -> m LocalReg -> m CmmReg
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CmmType -> m LocalReg
forall (m :: * -> *). MonadUnique m => CmmType -> m LocalReg
newTemp (DynFlags -> CmmType
bWord DynFlags
df)
CmmAGraph -> m CmmAGraph
forall (f :: * -> *) a. Applicative f => a -> f a
pure (CmmAGraph -> m CmmAGraph) -> CmmAGraph -> m CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
cnreg CmmExpr
currentNurseryExpr,
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
bdfreereg (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free DynFlags
df CmmReg
cnreg) (DynFlags -> CmmType
bWord DynFlags
df)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpReg (DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetW DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
bdfreereg) (-Int
1)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
bdstartreg (CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start DynFlags
df CmmReg
cnreg) (DynFlags -> CmmType
bWord DynFlags
df)),
CmmReg -> CmmExpr -> CmmAGraph
mkAssign CmmReg
hpLimReg
(DynFlags -> CmmExpr -> CmmExpr -> CmmExpr
cmmOffsetExpr DynFlags
df
(CmmReg -> CmmExpr
CmmReg CmmReg
bdstartreg)
(DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df
(MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordMul DynFlags
df) [
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> Width -> MachOp
MO_SS_Conv Width
W32 (DynFlags -> Width
wordWidth DynFlags
df))
[CmmExpr -> CmmType -> CmmExpr
CmmLoad (DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_blocks DynFlags
df CmmReg
cnreg) CmmType
b32],
DynFlags -> Int -> CmmExpr
mkIntExpr DynFlags
df (DynFlags -> Int
bLOCK_SIZE DynFlags
df)
])
(-Int
1)
)
),
let alloc :: CmmExpr
alloc =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_wordSub DynFlags
df) [CmmReg -> CmmExpr
CmmReg CmmReg
bdfreereg, CmmReg -> CmmExpr
CmmReg CmmReg
bdstartreg]
alloc_limit :: CmmExpr
alloc_limit = DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
df (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (DynFlags -> Int
tso_alloc_limit DynFlags
df)
in
CmmExpr -> CmmExpr -> CmmAGraph
mkStore CmmExpr
alloc_limit (MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Width -> MachOp
MO_Add Width
W64)
[ CmmExpr -> CmmType -> CmmExpr
CmmLoad CmmExpr
alloc_limit CmmType
b64
, MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (DynFlags -> MachOp
mo_WordTo64 DynFlags
df) [CmmExpr
alloc] ])
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
:: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free DynFlags
dflags CmmReg
cn =
DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_free DynFlags
dflags)
nursery_bdescr_start :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_start DynFlags
dflags CmmReg
cn =
DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_start DynFlags
dflags)
nursery_bdescr_blocks :: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_blocks DynFlags
dflags CmmReg
cn =
DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffset DynFlags
dflags (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (DynFlags -> Int
oFFSET_bdescr_blocks DynFlags
dflags)
tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj :: DynFlags -> Int
tso_stackobj DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_stackobj DynFlags
dflags)
tso_alloc_limit :: DynFlags -> Int
tso_alloc_limit DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_alloc_limit DynFlags
dflags)
tso_CCCS :: DynFlags -> Int
tso_CCCS DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgTSO_cccs DynFlags
dflags)
stack_STACK :: DynFlags -> Int
stack_STACK DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgStack_stack DynFlags
dflags)
stack_SP :: DynFlags -> Int
stack_SP DynFlags
dflags = DynFlags -> Int -> Int
closureField DynFlags
dflags (DynFlags -> Int
oFFSET_StgStack_sp DynFlags
dflags)
closureField :: DynFlags -> ByteOff -> ByteOff
closureField :: DynFlags -> Int -> Int
closureField DynFlags
dflags Int
off = Int
off Int -> Int -> Int
forall a. Num a => a -> a -> a
+ DynFlags -> Int
fixedHdrSize DynFlags
dflags
getFCallArgs ::
[StgArg]
-> Type
-> FCode [(CmmExpr, ForeignHint)]
getFCallArgs :: [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs [StgArg]
args Type
typ
= do { [Maybe (CmmExpr, ForeignHint)]
mb_cmms <- ((StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint)))
-> [(StgArg, StgFArgType)] -> FCode [Maybe (CmmExpr, ForeignHint)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
get (String -> [StgArg] -> [StgFArgType] -> [(StgArg, StgFArgType)]
forall a b. String -> [a] -> [b] -> [(a, b)]
zipEqual String
"getFCallArgs" [StgArg]
args (Type -> [StgFArgType]
collectStgFArgTypes Type
typ))
; [(CmmExpr, ForeignHint)] -> FCode [(CmmExpr, ForeignHint)]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe (CmmExpr, ForeignHint)] -> [(CmmExpr, ForeignHint)]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (CmmExpr, ForeignHint)]
mb_cmms) }
where
get :: (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
get (StgArg
arg,StgFArgType
typ)
| [PrimRep] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
arg_reps
= Maybe (CmmExpr, ForeignHint)
-> FCode (Maybe (CmmExpr, ForeignHint))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (CmmExpr, ForeignHint)
forall a. Maybe a
Nothing
| Bool
otherwise
= do { CmmExpr
cmm <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
; DynFlags
dflags <- FCode DynFlags
forall (m :: * -> *). HasDynFlags m => m DynFlags
getDynFlags
; Maybe (CmmExpr, ForeignHint)
-> FCode (Maybe (CmmExpr, ForeignHint))
forall (m :: * -> *) a. Monad m => a -> m a
return ((CmmExpr, ForeignHint) -> Maybe (CmmExpr, ForeignHint)
forall a. a -> Maybe a
Just (DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
add_shim DynFlags
dflags StgFArgType
typ CmmExpr
cmm, ForeignHint
hint)) }
where
arg_ty :: Type
arg_ty = StgArg -> Type
stgArgType StgArg
arg
arg_reps :: [PrimRep]
arg_reps = HasDebugCallStack => Type -> [PrimRep]
Type -> [PrimRep]
typePrimRep Type
arg_ty
hint :: ForeignHint
hint = Type -> ForeignHint
typeForeignHint Type
arg_ty
data StgFArgType
= StgPlainType
| StgArrayType
| StgSmallArrayType
| StgByteArrayType
add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
add_shim DynFlags
dflags StgFArgType
ty CmmExpr
expr = case StgFArgType
ty of
StgFArgType
StgPlainType -> CmmExpr
expr
StgFArgType
StgArrayType -> DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
arrPtrsHdrSize DynFlags
dflags)
StgFArgType
StgSmallArrayType -> DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
smallArrPtrsHdrSize DynFlags
dflags)
StgFArgType
StgByteArrayType -> DynFlags -> CmmExpr -> Int -> CmmExpr
cmmOffsetB DynFlags
dflags CmmExpr
expr (DynFlags -> Int
arrWordsHdrSize DynFlags
dflags)
collectStgFArgTypes :: Type -> [StgFArgType]
collectStgFArgTypes :: Type -> [StgFArgType]
collectStgFArgTypes = [StgFArgType] -> Type -> [StgFArgType]
go []
where
go :: [StgFArgType] -> Type -> [StgFArgType]
go [StgFArgType]
bs (ForAllTy TyCoVarBinder
_ Type
res) = [StgFArgType] -> Type -> [StgFArgType]
go [StgFArgType]
bs Type
res
go [StgFArgType]
bs (AppTy{}) = [StgFArgType] -> [StgFArgType]
forall a. [a] -> [a]
reverse [StgFArgType]
bs
go [StgFArgType]
bs (TyConApp{}) = [StgFArgType] -> [StgFArgType]
forall a. [a] -> [a]
reverse [StgFArgType]
bs
go [StgFArgType]
bs (LitTy{}) = [StgFArgType] -> [StgFArgType]
forall a. [a] -> [a]
reverse [StgFArgType]
bs
go [StgFArgType]
bs (TyVarTy{}) = [StgFArgType] -> [StgFArgType]
forall a. [a] -> [a]
reverse [StgFArgType]
bs
go [StgFArgType]
_ (CastTy{}) = String -> [StgFArgType]
forall a. String -> a
panic String
"myCollectTypeArgs: CastTy"
go [StgFArgType]
_ (CoercionTy{}) = String -> [StgFArgType]
forall a. String -> a
panic String
"myCollectTypeArgs: CoercionTy"
go [StgFArgType]
bs (FunTy {ft_arg :: Type -> Type
ft_arg = Type
arg, ft_res :: Type -> Type
ft_res=Type
res}) =
[StgFArgType] -> Type -> [StgFArgType]
go (Type -> StgFArgType
typeToStgFArgType Type
argStgFArgType -> [StgFArgType] -> [StgFArgType]
forall a. a -> [a] -> [a]
:[StgFArgType]
bs) Type
res
typeToStgFArgType :: Type -> StgFArgType
typeToStgFArgType :: Type -> StgFArgType
typeToStgFArgType Type
typ
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayPrimTyCon = StgFArgType
StgArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayPrimTyCon = StgFArgType
StgArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
arrayArrayPrimTyCon = StgFArgType
StgArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableArrayArrayPrimTyCon = StgFArgType
StgArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallArrayPrimTyCon = StgFArgType
StgSmallArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
smallMutableArrayPrimTyCon = StgFArgType
StgSmallArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
byteArrayPrimTyCon = StgFArgType
StgByteArrayType
| TyCon
tycon TyCon -> TyCon -> Bool
forall a. Eq a => a -> a -> Bool
== TyCon
mutableByteArrayPrimTyCon = StgFArgType
StgByteArrayType
| Bool
otherwise = StgFArgType
StgPlainType
where
tycon :: TyCon
tycon = Type -> TyCon
tyConAppTyCon (Type -> Type
unwrapType Type
typ)