module GHC.StgToCmm.Foreign (
cgForeignCall,
emitPrimCall,
emitCCall,
emitCCallNeverReturns,
emitForeignCall,
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
emitSaveRegs,
emitRestoreRegs,
emitPushArgRegs,
emitPopArgRegs,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
) where
import GHC.Prelude hiding( succ, (<*>) )
import GHC.Platform
import GHC.Platform.Profile
import GHC.Stg.Syntax
import GHC.StgToCmm.Prof (storeCurCCS, ccsType)
import GHC.StgToCmm.Monad
import GHC.StgToCmm.Utils
import GHC.StgToCmm.Closure
import GHC.StgToCmm.Layout
import GHC.Cmm.BlockId (newBlockId)
import GHC.Cmm
import GHC.Cmm.Reg ( GlobalArgRegs(..) )
import GHC.Cmm.Utils
import GHC.Cmm.Graph
import GHC.Cmm.CallConv
import GHC.Core.Type
import GHC.Types.RepType
import GHC.Cmm.CLabel
import GHC.Runtime.Heap.Layout
import GHC.Types.ForeignCall
import GHC.Data.Maybe
import GHC.Utils.Panic
import GHC.Types.Basic
import GHC.Types.Unique.DSM
import GHC.Unit.Types
import GHC.Core.TyCo.Rep
import GHC.Builtin.Types.Prim
import GHC.Utils.Misc (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 { cmm_args <- [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs [StgArg]
stg_args Type
typ
; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
; let ((call_args, arg_hints), cmm_target)
= case target of
StaticTarget SourceText
_ CLabelString
_ Maybe Unit
_ Bool
False ->
String -> (([CmmExpr], [ForeignHint]), CmmExpr)
forall a. HasCallStack => String -> a
panic String
"cgForeignCall: unexpected FFI value import"
StaticTarget SourceText
_ CLabelString
lbl Maybe Unit
mPkgId Bool
True
-> let labelSource :: ForeignLabelSource
labelSource
= case Maybe Unit
mPkgId of
Maybe Unit
Nothing -> ForeignLabelSource
ForeignLabelInThisPackage
Just Unit
pkgId -> UnitId -> ForeignLabelSource
ForeignLabelInPackage (Unit -> UnitId
toUnitId Unit
pkgId)
in ( [(CmmExpr, ForeignHint)] -> ([CmmExpr], [ForeignHint])
forall a b. [(a, b)] -> ([a], [b])
unzip [(CmmExpr, ForeignHint)]
cmm_args
, CmmLit -> CmmExpr
CmmLit (CLabel -> CmmLit
CmmLabel
(CLabelString -> ForeignLabelSource -> FunctionOrData -> CLabel
mkForeignLabel CLabelString
lbl 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. HasCallStack => String -> a
panic String
"cgForeignCall []"
fc = CCallConv
-> [ForeignHint]
-> [ForeignHint]
-> CmmReturnInfo
-> ForeignConvention
ForeignConvention CCallConv
cconv [ForeignHint]
arg_hints [ForeignHint]
res_hints CmmReturnInfo
CmmMayReturn
call_target = CmmExpr -> ForeignConvention -> ForeignTarget
ForeignTarget CmmExpr
cmm_target ForeignConvention
fc
; sequel <- getSequel
; case 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 { _ <- Safety
-> [LocalReg] -> ForeignTarget -> [CmmExpr] -> FCode ReturnKind
emitForeignCall Safety
safety [LocalReg]
res_regs ForeignTarget
call_target [CmmExpr]
call_args
; emitReturn (map (CmmReg . CmmLocal) res_regs)
}
}
emitCCall' :: CmmReturnInfo
-> [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall' :: CmmReturnInfo
-> [(LocalReg, ForeignHint)]
-> CmmExpr
-> [(CmmExpr, ForeignHint)]
-> FCode ()
emitCCall' CmmReturnInfo
ret_info [(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
ret_info
emitCCall :: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall :: [(LocalReg, ForeignHint)]
-> CmmExpr -> [(CmmExpr, ForeignHint)] -> FCode ()
emitCCall = CmmReturnInfo
-> [(LocalReg, ForeignHint)]
-> CmmExpr
-> [(CmmExpr, ForeignHint)]
-> FCode ()
emitCCall' CmmReturnInfo
CmmMayReturn
emitCCallNeverReturns
:: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCallNeverReturns :: [(LocalReg, ForeignHint)]
-> CmmExpr -> [(CmmExpr, ForeignHint)] -> FCode ()
emitCCallNeverReturns = CmmReturnInfo
-> [(LocalReg, ForeignHint)]
-> CmmExpr
-> [(CmmExpr, ForeignHint)]
-> FCode ()
emitCCall' CmmReturnInfo
CmmNeverReturns
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
platform <- FCode Platform
getPlatform
let (caller_save, caller_load) = callerSaveVolatileRegs platform
emit caller_save
target' <- load_target_into_temp target
args' <- mapM maybe_assign_temp args
emit $ mkUnsafeCall target' results args'
emit caller_load
return AssignedDirectly
| Bool
otherwise = do
profile <- FCode Profile
getProfile
platform <- getPlatform
updfr_off <- getUpdFrameOff
target' <- load_target_into_temp target
args' <- mapM maybe_assign_temp args
k <- newBlockId
let (off, _, copyout) = copyInOflow profile NativeReturn (Young k) results []
tscope <- getTickScope
emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes (wordWidth platform)))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall { tgt = target'
, res = results
, args = args'
, succ = k
, ret_args = off
, ret_off = updfr_off
, intrbl = playInterruptible safety })
<*> mkLabel k tscope
<*> copyout
)
return (ReturnedTo k 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
tmp <- CmmExpr -> FCode CmmExpr
maybe_assign_temp CmmExpr
expr
return (ForeignTarget tmp conv)
load_target_into_temp other_target :: ForeignTarget
other_target@(PrimTarget CallishMachOp
_) =
ForeignTarget -> FCode ForeignTarget
forall a. a -> FCode a
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
do_save <- StgToCmmConfig -> Bool
stgToCmmSaveFCallTargetToLocal (StgToCmmConfig -> Bool) -> FCode StgToCmmConfig -> FCode Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> FCode StgToCmmConfig
getStgToCmmConfig
if do_save
then do
platform <- getPlatform
reg <- newTemp (cmmExprType platform e)
emitAssign (CmmLocal reg) e
return (CmmReg (CmmLocal reg))
else
pure e
emitSaveThreadState :: FCode ()
emitSaveThreadState :: FCode ()
emitSaveThreadState = do
profile <- FCode Profile
getProfile
code <- saveThreadState profile
emit code
saveThreadState :: MonadGetUnique m => Profile -> m CmmAGraph
saveThreadState :: forall (m :: * -> *). MonadGetUnique m => Profile -> m CmmAGraph
saveThreadState Profile
profile = do
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
gcWord Platform
platform)
close_nursery <- closeNursery profile tso
pure $ catAGraphs
[
mkAssign (CmmLocal tso) (currentTSOExpr platform)
,
mkStore (cmmOffset platform
(cmmLoadBWord platform (cmmOffset platform
(CmmReg (CmmLocal tso))
(tso_stackobj profile)))
(stack_SP profile))
(spExpr platform)
, close_nursery
,
if profileIsProfiling profile
then mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS profile))
(cccsExpr platform)
else mkNop
]
emitSaveRegs :: GlobalArgRegs -> FCode ()
emitSaveRegs :: GlobalArgRegs -> FCode ()
emitSaveRegs GlobalArgRegs
argRegs = do
platform <- FCode Platform
getPlatform
let regs = Platform -> GlobalArgRegs -> [GlobalReg]
realArgRegsCover Platform
platform GlobalArgRegs
argRegs
save = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> CmmAGraph
callerSaveGlobalReg Platform
platform) [GlobalReg]
regs)
emit save
emitRestoreRegs :: GlobalArgRegs -> FCode ()
emitRestoreRegs :: GlobalArgRegs -> FCode ()
emitRestoreRegs GlobalArgRegs
argRegs = do
platform <- FCode Platform
getPlatform
let regs = Platform -> GlobalArgRegs -> [GlobalReg]
realArgRegsCover Platform
platform GlobalArgRegs
argRegs
restore = [CmmAGraph] -> CmmAGraph
catAGraphs ((GlobalReg -> CmmAGraph) -> [GlobalReg] -> [CmmAGraph]
forall a b. (a -> b) -> [a] -> [b]
map (Platform -> GlobalReg -> CmmAGraph
callerRestoreGlobalReg Platform
platform) [GlobalReg]
regs)
emit restore
emitPushArgRegs :: GlobalArgRegs -> CmmExpr -> FCode ()
emitPushArgRegs :: GlobalArgRegs -> CmmExpr -> FCode ()
emitPushArgRegs GlobalArgRegs
argRegs CmmExpr
regs_live = do
platform <- FCode Platform
getPlatform
let regs = [GlobalReg] -> [ByteOff] -> [(GlobalReg, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
argRegs) [ByteOff
0..]
save_arg (GlobalReg
reg, ByteOff
n) =
let reg_ty :: CmmType
reg_ty = Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
reg
mask :: CmmExpr
mask = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
1 Integer -> ByteOff -> Integer
forall a. Bits a => a -> ByteOff -> a
`shiftL` ByteOff
n) (Platform -> Width
wordWidth Platform
platform))
live :: CmmExpr
live = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform CmmExpr
regs_live CmmExpr
mask
cond :: CmmExpr
cond = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform CmmExpr
live (Platform -> CmmExpr
zeroExpr Platform
platform)
width :: ByteOff
width = Platform -> ByteOff -> ByteOff
roundUpToWords Platform
platform
(Width -> ByteOff
widthInBytes (Width -> ByteOff) -> Width -> ByteOff
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
reg_ty)
adj_sp :: CmmAGraph
adj_sp = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (Platform -> CmmReg
spReg Platform
platform)
(Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (Platform -> CmmExpr
spExpr Platform
platform) (ByteOff -> ByteOff
forall a. Num a => a -> a
negate ByteOff
width))
save_reg :: CmmAGraph
save_reg = CmmExpr -> CmmExpr -> CmmAGraph
mkStore (Platform -> CmmExpr
spExpr Platform
platform) (CmmReg -> CmmExpr
CmmReg (CmmReg -> CmmExpr) -> CmmReg -> CmmExpr
forall a b. (a -> b) -> a -> b
$ GlobalRegUse -> CmmReg
CmmGlobal (GlobalRegUse -> CmmReg) -> GlobalRegUse -> CmmReg
forall a b. (a -> b) -> a -> b
$ GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
reg CmmType
reg_ty)
in CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
cond (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph
adj_sp, CmmAGraph
save_reg]
emit . catAGraphs =<< mapM save_arg (reverse $ regs)
emitPopArgRegs :: GlobalArgRegs ->CmmExpr -> FCode ()
emitPopArgRegs :: GlobalArgRegs -> CmmExpr -> FCode ()
emitPopArgRegs GlobalArgRegs
argRegs CmmExpr
regs_live = do
platform <- FCode Platform
getPlatform
let regs = [GlobalReg] -> [ByteOff] -> [(GlobalReg, ByteOff)]
forall a b. [a] -> [b] -> [(a, b)]
zip (Platform -> GlobalArgRegs -> [GlobalReg]
allArgRegsCover Platform
platform GlobalArgRegs
argRegs) [ByteOff
0..]
save_arg (GlobalReg
reg, ByteOff
n) =
let reg_ty :: CmmType
reg_ty = Platform -> GlobalReg -> CmmType
globalRegSpillType Platform
platform GlobalReg
reg
mask :: CmmExpr
mask = CmmLit -> CmmExpr
CmmLit (Integer -> Width -> CmmLit
CmmInt (Integer
1 Integer -> ByteOff -> Integer
forall a. Bits a => a -> ByteOff -> a
`shiftL` ByteOff
n) (Platform -> Width
wordWidth Platform
platform))
live :: CmmExpr
live = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmAndWord Platform
platform CmmExpr
regs_live CmmExpr
mask
cond :: CmmExpr
cond = Platform -> CmmExpr -> CmmExpr -> CmmExpr
cmmNeWord Platform
platform CmmExpr
live (Platform -> CmmExpr
zeroExpr Platform
platform)
width :: ByteOff
width = Platform -> ByteOff -> ByteOff
roundUpToWords Platform
platform
(Width -> ByteOff
widthInBytes (Width -> ByteOff) -> Width -> ByteOff
forall a b. (a -> b) -> a -> b
$ CmmType -> Width
typeWidth CmmType
reg_ty)
adj_sp :: CmmAGraph
adj_sp = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (Platform -> CmmReg
spReg Platform
platform)
(Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (Platform -> CmmExpr
spExpr Platform
platform) ByteOff
width)
restore_reg :: CmmAGraph
restore_reg = CmmReg -> CmmExpr -> CmmAGraph
mkAssign (GlobalRegUse -> CmmReg
CmmGlobal (GlobalReg -> CmmType -> GlobalRegUse
GlobalRegUse GlobalReg
reg CmmType
reg_ty))
(CmmExpr -> CmmType -> AlignmentSpec -> CmmExpr
CmmLoad (Platform -> CmmExpr
spExpr Platform
platform) CmmType
reg_ty AlignmentSpec
NaturallyAligned)
in CmmExpr -> CmmAGraph -> FCode CmmAGraph
mkCmmIfThen CmmExpr
cond (CmmAGraph -> FCode CmmAGraph) -> CmmAGraph -> FCode CmmAGraph
forall a b. (a -> b) -> a -> b
$ [CmmAGraph] -> CmmAGraph
catAGraphs [CmmAGraph
restore_reg, CmmAGraph
adj_sp]
emit . catAGraphs =<< mapM save_arg regs
emitCloseNursery :: FCode ()
emitCloseNursery :: FCode ()
emitCloseNursery = do
profile <- FCode Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
tso <- newTemp (bWord platform)
code <- closeNursery profile tso
emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code
closeNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph
closeNursery :: forall (m :: * -> *).
MonadGetUnique m =>
Profile -> LocalReg -> m CmmAGraph
closeNursery Profile
profile LocalReg
tso = do
let tsoreg :: CmmReg
tsoreg = LocalReg -> CmmReg
CmmLocal LocalReg
tso
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
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 :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
pure $ catAGraphs [
mkAssign cnreg (currentNurseryExpr platform),
mkStore (nursery_bdescr_free platform cnreg) (cmmOffsetW platform (hpExpr platform) 1),
let alloc =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordSub Platform
platform)
[ Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetW Platform
platform (Platform -> CmmExpr
hpExpr Platform
platform) ByteOff
1
, Platform -> CmmExpr -> CmmExpr
cmmLoadBWord Platform
platform (Platform -> CmmReg -> CmmExpr
nursery_bdescr_start Platform
platform CmmReg
cnreg)
]
alloc_limit = Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (Profile -> ByteOff
tso_alloc_limit Profile
profile)
in
mkStore alloc_limit (CmmMachOp (MO_Sub W64)
[ CmmLoad alloc_limit b64 NaturallyAligned
, CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
emitLoadThreadState :: FCode ()
emitLoadThreadState :: FCode ()
emitLoadThreadState = do
profile <- FCode Profile
getProfile
code <- loadThreadState profile
emit code
loadThreadState :: MonadGetUnique m => Profile -> m CmmAGraph
loadThreadState :: forall (m :: * -> *). MonadGetUnique m => Profile -> m CmmAGraph
loadThreadState Profile
profile = do
let platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
tso <- CmmType -> m LocalReg
forall (m :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
gcWord Platform
platform)
stack <- newTemp (gcWord platform)
open_nursery <- openNursery profile tso
pure $ catAGraphs [
mkAssign (CmmLocal tso) (currentTSOExpr platform),
mkAssign (CmmLocal stack) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj profile))),
mkAssign (spReg platform) (cmmLoadBWord platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP profile))),
mkAssign (spLimReg platform) (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK profile))
(pc_RESERVED_STACK_WORDS (platformConstants platform))),
mkAssign (hpAllocReg platform) (zeroExpr platform),
open_nursery,
if profileIsProfiling profile
then let ccs_ptr = Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg (LocalReg -> CmmReg
CmmLocal LocalReg
tso)) (Profile -> ByteOff
tso_CCCS Profile
profile)
in storeCurCCS platform (CmmLoad ccs_ptr (ccsType platform) NaturallyAligned)
else mkNop
]
emitOpenNursery :: FCode ()
emitOpenNursery :: FCode ()
emitOpenNursery = do
profile <- FCode Profile
getProfile
let platform = Profile -> Platform
profilePlatform Profile
profile
tso <- newTemp (bWord platform)
code <- openNursery profile tso
emit $ mkAssign (CmmLocal tso) (currentTSOExpr platform) <*> code
openNursery :: MonadGetUnique m => Profile -> LocalReg -> m CmmAGraph
openNursery :: forall (m :: * -> *).
MonadGetUnique m =>
Profile -> LocalReg -> m CmmAGraph
openNursery Profile
profile LocalReg
tso = do
let tsoreg :: CmmReg
tsoreg = LocalReg -> CmmReg
CmmLocal LocalReg
tso
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
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 :: * -> *). MonadGetUnique m => CmmType -> m LocalReg
newTemp (Platform -> CmmType
bWord Platform
platform)
bdfreereg <- CmmLocal <$> newTemp (bWord platform)
bdstartreg <- CmmLocal <$> newTemp (bWord platform)
pure $ catAGraphs [
mkAssign cnreg (currentNurseryExpr platform),
mkAssign bdfreereg (cmmLoadBWord platform (nursery_bdescr_free platform cnreg)),
mkAssign (hpReg platform) (cmmOffsetW platform (CmmReg bdfreereg) (-1)),
mkAssign bdstartreg (cmmLoadBWord platform (nursery_bdescr_start platform cnreg)),
mkAssign (hpLimReg platform)
(cmmOffsetExpr platform
(CmmReg bdstartreg)
(cmmOffset platform
(CmmMachOp (mo_wordMul platform)
[ CmmMachOp (MO_SS_Conv W32 (wordWidth platform))
[CmmLoad (nursery_bdescr_blocks platform cnreg) b32 NaturallyAligned]
, mkIntExpr platform (pc_BLOCK_SIZE (platformConstants platform))
])
(-1)
)
),
let alloc =
MachOp -> [CmmExpr] -> CmmExpr
CmmMachOp (Platform -> MachOp
mo_wordSub Platform
platform) [CmmReg -> CmmExpr
CmmReg CmmReg
bdfreereg, CmmReg -> CmmExpr
CmmReg CmmReg
bdstartreg]
alloc_limit = Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
tsoreg) (Profile -> ByteOff
tso_alloc_limit Profile
profile)
in
mkStore alloc_limit (CmmMachOp (MO_Add W64)
[ CmmLoad alloc_limit b64 NaturallyAligned
, CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
:: Platform -> CmmReg -> CmmExpr
nursery_bdescr_free :: Platform -> CmmReg -> CmmExpr
nursery_bdescr_free Platform
platform CmmReg
cn =
Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (PlatformConstants -> ByteOff
pc_OFFSET_bdescr_free (Platform -> PlatformConstants
platformConstants Platform
platform))
nursery_bdescr_start :: Platform -> CmmReg -> CmmExpr
nursery_bdescr_start Platform
platform CmmReg
cn =
Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (PlatformConstants -> ByteOff
pc_OFFSET_bdescr_start (Platform -> PlatformConstants
platformConstants Platform
platform))
nursery_bdescr_blocks :: Platform -> CmmReg -> CmmExpr
nursery_bdescr_blocks Platform
platform CmmReg
cn =
Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffset Platform
platform (CmmReg -> CmmExpr
CmmReg CmmReg
cn) (PlatformConstants -> ByteOff
pc_OFFSET_bdescr_blocks (Platform -> PlatformConstants
platformConstants Platform
platform))
tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: Profile -> ByteOff
tso_stackobj :: Profile -> ByteOff
tso_stackobj Profile
profile = Profile -> ByteOff -> ByteOff
closureField Profile
profile (PlatformConstants -> ByteOff
pc_OFFSET_StgTSO_stackobj (Profile -> PlatformConstants
profileConstants Profile
profile))
tso_alloc_limit :: Profile -> ByteOff
tso_alloc_limit Profile
profile = Profile -> ByteOff -> ByteOff
closureField Profile
profile (PlatformConstants -> ByteOff
pc_OFFSET_StgTSO_alloc_limit (Profile -> PlatformConstants
profileConstants Profile
profile))
tso_CCCS :: Profile -> ByteOff
tso_CCCS Profile
profile = Profile -> ByteOff -> ByteOff
closureField Profile
profile (PlatformConstants -> ByteOff
pc_OFFSET_StgTSO_cccs (Profile -> PlatformConstants
profileConstants Profile
profile))
stack_STACK :: Profile -> ByteOff
stack_STACK Profile
profile = Profile -> ByteOff -> ByteOff
closureField Profile
profile (PlatformConstants -> ByteOff
pc_OFFSET_StgStack_stack (Profile -> PlatformConstants
profileConstants Profile
profile))
stack_SP :: Profile -> ByteOff
stack_SP Profile
profile = Profile -> ByteOff -> ByteOff
closureField Profile
profile (PlatformConstants -> ByteOff
pc_OFFSET_StgStack_sp (Profile -> PlatformConstants
profileConstants Profile
profile))
closureField :: Profile -> ByteOff -> ByteOff
closureField :: Profile -> ByteOff -> ByteOff
closureField Profile
profile ByteOff
off = ByteOff
off ByteOff -> ByteOff -> ByteOff
forall a. Num a => a -> a -> a
+ Profile -> ByteOff
fixedHdrSize Profile
profile
getFCallArgs ::
[StgArg]
-> Type
-> FCode [(CmmExpr, ForeignHint)]
getFCallArgs :: [StgArg] -> Type -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs [StgArg]
args Type
typ
= do { 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
get (String -> [StgArg] -> [StgFArgType] -> [(StgArg, StgFArgType)]
forall a b. HasDebugCallStack => String -> [a] -> [b] -> [(a, b)]
zipEqual String
"getFCallArgs" [StgArg]
args (Type -> [StgFArgType]
collectStgFArgTypes Type
typ))
; return (catMaybes mb_cmms) }
where
get :: (StgArg, StgFArgType) -> FCode (Maybe (CmmExpr, ForeignHint))
get (StgArg
arg,StgFArgType
typ)
| [PrimRep] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PrimRep]
arg_reps
= Maybe (CmmExpr, ForeignHint)
-> FCode (Maybe (CmmExpr, ForeignHint))
forall a. a -> FCode a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (CmmExpr, ForeignHint)
forall a. Maybe a
Nothing
| Bool
otherwise
= do { cmm <- NonVoid StgArg -> FCode CmmExpr
getArgAmode (StgArg -> NonVoid StgArg
forall a. a -> NonVoid a
NonVoid StgArg
arg)
; profile <- getProfile
; return (Just (add_shim profile typ cmm, 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 :: Profile -> StgFArgType -> CmmExpr -> CmmExpr
add_shim :: Profile -> StgFArgType -> CmmExpr -> CmmExpr
add_shim Profile
profile StgFArgType
ty CmmExpr
expr = case StgFArgType
ty of
StgFArgType
StgPlainType -> CmmExpr
expr
StgFArgType
StgArrayType -> Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
expr (Profile -> ByteOff
arrPtrsHdrSize Profile
profile)
StgFArgType
StgSmallArrayType -> Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
expr (Profile -> ByteOff
smallArrPtrsHdrSize Profile
profile)
StgFArgType
StgByteArrayType -> Platform -> CmmExpr -> ByteOff -> CmmExpr
cmmOffsetB Platform
platform CmmExpr
expr (Profile -> ByteOff
arrWordsHdrSize Profile
profile)
where
platform :: Platform
platform = Profile -> Platform
profilePlatform Profile
profile
collectStgFArgTypes :: Type -> [StgFArgType]
collectStgFArgTypes :: Type -> [StgFArgType]
collectStgFArgTypes = [StgFArgType] -> Type -> [StgFArgType]
go []
where
go :: [StgFArgType] -> Type -> [StgFArgType]
go [StgFArgType]
bs (ForAllTy ForAllTyBinder
_ 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. HasCallStack => String -> a
panic String
"myCollectTypeArgs: CastTy"
go [StgFArgType]
_ (CoercionTy{}) = String -> [StgFArgType]
forall a. HasCallStack => 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
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 = HasDebugCallStack => Type -> TyCon
Type -> TyCon
tyConAppTyCon (Type -> Type
unwrapType Type
typ)