module GHC.StgToCmm.Foreign (
cgForeignCall,
emitPrimCall, emitCCall,
emitForeignCall,
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
emitSaveRegs,
emitRestoreRegs,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
) where
import GHC.Prelude hiding( succ, (<*>) )
import GHC.Stg.Syntax
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 GHC.Cmm.BlockId (newBlockId)
import GHC.Cmm
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.Driver.Session
import GHC.Platform
import GHC.Data.Maybe
import GHC.Utils.Outputable
import GHC.Types.Unique.Supply
import GHC.Types.Basic
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 (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
= do { platform <- getPlatform
; let
call_size args
| StdCallConv <- cconv = Just (sum (map arg_size args))
| otherwise = Nothing
arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType platform arg)
(platformWordSizeInBytes platform)
; cmm_args <- getFCallArgs stg_args typ
; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
; let ((call_args, arg_hints), cmm_target)
= case target of
StaticTarget _ _ _ False ->
panic "cgForeignCall: unexpected FFI value import"
StaticTarget _ lbl mPkgId True
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
Just pkgId -> ForeignLabelInPackage pkgId
size = call_size cmm_args
in ( unzip cmm_args
, CmmLit (CmmLabel
(mkForeignLabel lbl size labelSource IsFunction)))
DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
[] -> panic "cgForeignCall []"
fc = ForeignConvention cconv arg_hints res_hints CmmMayReturn
call_target = ForeignTarget cmm_target fc
; sequel <- getSequel
; case sequel of
AssignTo assign_to_these _ ->
emitForeignCall safety assign_to_these call_target call_args
_something_else ->
do { _ <- emitForeignCall safety res_regs call_target call_args
; emitReturn (map (CmmReg . CmmLocal) res_regs)
}
}
emitCCall :: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= void $ emitForeignCall PlayRisky results target args
where
(args, arg_hints) = unzip hinted_args
(results, result_hints) = unzip hinted_results
target = ForeignTarget fn fc
fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
emitPrimCall res op args
= void $ emitForeignCall PlayRisky res (PrimTarget op) args
emitForeignCall
:: Safety
-> [CmmFormal]
-> ForeignTarget
-> [CmmActual]
-> FCode ReturnKind
emitForeignCall safety results target args
| not (playSafe safety) = do
dflags <- getDynFlags
let (caller_save, caller_load) = callerSaveVolatileRegs dflags
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
| otherwise = do
dflags <- getDynFlags
platform <- getPlatform
updfr_off <- getUpdFrameOff
target' <- load_target_into_temp target
args' <- mapM maybe_assign_temp args
k <- newBlockId
let (off, _, copyout) = copyInOflow dflags 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 expr conv) = do
tmp <- maybe_assign_temp expr
return (ForeignTarget tmp conv)
load_target_into_temp other_target@(PrimTarget _) =
return other_target
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp e = do
platform <- getPlatform
reg <- newTemp (cmmExprType platform e)
emitAssign (CmmLocal reg) e
return (CmmReg (CmmLocal reg))
emitSaveThreadState :: FCode ()
emitSaveThreadState = do
dflags <- getDynFlags
code <- saveThreadState dflags
emit code
saveThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
saveThreadState dflags = do
let platform = targetPlatform dflags
tso <- newTemp (gcWord platform)
close_nursery <- closeNursery dflags tso
pure $ catAGraphs [
mkAssign (CmmLocal tso) currentTSOExpr,
mkStore (cmmOffset platform
(CmmLoad (cmmOffset platform
(CmmReg (CmmLocal tso))
(tso_stackobj dflags))
(bWord platform))
(stack_SP dflags))
spExpr,
close_nursery,
if sccProfilingEnabled dflags then
mkStore (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) cccsExpr
else mkNop
]
emitSaveRegs :: FCode ()
emitSaveRegs = do
dflags <- getDynFlags
let regs = realArgRegsCover dflags
save = catAGraphs (map (callerSaveGlobalReg dflags) regs)
emit save
emitRestoreRegs :: FCode ()
emitRestoreRegs = do
dflags <- getDynFlags
let regs = realArgRegsCover dflags
save = catAGraphs (map (callerRestoreGlobalReg dflags) regs)
emit save
emitCloseNursery :: FCode ()
emitCloseNursery = do
dflags <- getDynFlags
platform <- getPlatform
tso <- newTemp (bWord platform)
code <- closeNursery dflags tso
emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
closeNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
closeNursery df tso = do
let tsoreg = CmmLocal tso
platform = targetPlatform df
cnreg <- CmmLocal <$> newTemp (bWord platform)
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW platform hpExpr 1),
let alloc =
CmmMachOp (mo_wordSub platform)
[ cmmOffsetW platform hpExpr 1
, CmmLoad (nursery_bdescr_start df cnreg) (bWord platform)
]
alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit df)
in
mkStore alloc_limit (CmmMachOp (MO_Sub W64)
[ CmmLoad alloc_limit b64
, CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
emitLoadThreadState :: FCode ()
emitLoadThreadState = do
dflags <- getDynFlags
code <- loadThreadState dflags
emit code
loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState dflags = do
let platform = targetPlatform dflags
tso <- newTemp (gcWord platform)
stack <- newTemp (gcWord platform)
open_nursery <- openNursery dflags tso
pure $ catAGraphs [
mkAssign (CmmLocal tso) currentTSOExpr,
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord platform)),
mkAssign spReg (CmmLoad (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord platform)),
mkAssign spLimReg (cmmOffsetW platform (cmmOffset platform (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
mkAssign hpAllocReg (zeroExpr platform),
open_nursery,
if sccProfilingEnabled dflags
then storeCurCCS
(CmmLoad (cmmOffset platform (CmmReg (CmmLocal tso))
(tso_CCCS dflags)) (ccsType platform))
else mkNop
]
emitOpenNursery :: FCode ()
emitOpenNursery = do
dflags <- getDynFlags
platform <- getPlatform
tso <- newTemp (bWord platform)
code <- openNursery dflags tso
emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
openNursery dflags tso = do
let tsoreg = CmmLocal tso
platform = targetPlatform dflags
cnreg <- CmmLocal <$> newTemp (bWord platform)
bdfreereg <- CmmLocal <$> newTemp (bWord platform)
bdstartreg <- CmmLocal <$> newTemp (bWord platform)
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
mkAssign bdfreereg (CmmLoad (nursery_bdescr_free dflags cnreg) (bWord platform)),
mkAssign hpReg (cmmOffsetW platform (CmmReg bdfreereg) (1)),
mkAssign bdstartreg (CmmLoad (nursery_bdescr_start dflags cnreg) (bWord platform)),
mkAssign hpLimReg
(cmmOffsetExpr platform
(CmmReg bdstartreg)
(cmmOffset platform
(CmmMachOp (mo_wordMul platform) [
CmmMachOp (MO_SS_Conv W32 (wordWidth platform))
[CmmLoad (nursery_bdescr_blocks dflags cnreg) b32],
mkIntExpr platform (bLOCK_SIZE dflags)
])
(1)
)
),
let alloc =
CmmMachOp (mo_wordSub platform) [CmmReg bdfreereg, CmmReg bdstartreg]
alloc_limit = cmmOffset platform (CmmReg tsoreg) (tso_alloc_limit dflags)
in
mkStore alloc_limit (CmmMachOp (MO_Add W64)
[ CmmLoad alloc_limit b64
, CmmMachOp (mo_WordTo64 platform) [alloc] ])
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
:: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free dflags cn =
cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_free dflags)
nursery_bdescr_start dflags cn =
cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_start dflags)
nursery_bdescr_blocks dflags cn =
cmmOffset (targetPlatform dflags) (CmmReg cn) (oFFSET_bdescr_blocks dflags)
tso_stackobj, tso_CCCS, tso_alloc_limit, stack_STACK, stack_SP :: DynFlags -> ByteOff
tso_stackobj dflags = closureField dflags (oFFSET_StgTSO_stackobj dflags)
tso_alloc_limit dflags = closureField dflags (oFFSET_StgTSO_alloc_limit dflags)
tso_CCCS dflags = closureField dflags (oFFSET_StgTSO_cccs dflags)
stack_STACK dflags = closureField dflags (oFFSET_StgStack_stack dflags)
stack_SP dflags = closureField dflags (oFFSET_StgStack_sp dflags)
closureField :: DynFlags -> ByteOff -> ByteOff
closureField dflags off = off + fixedHdrSize dflags
getFCallArgs ::
[StgArg]
-> Type
-> FCode [(CmmExpr, ForeignHint)]
getFCallArgs args typ
= do { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))
; return (catMaybes mb_cmms) }
where
get (arg,typ)
| null arg_reps
= return Nothing
| otherwise
= do { cmm <- getArgAmode (NonVoid arg)
; dflags <- getDynFlags
; return (Just (add_shim dflags typ cmm, hint)) }
where
arg_ty = stgArgType arg
arg_reps = typePrimRep arg_ty
hint = typeForeignHint arg_ty
data StgFArgType
= StgPlainType
| StgArrayType
| StgSmallArrayType
| StgByteArrayType
add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
add_shim dflags ty expr = case ty of
StgPlainType -> expr
StgArrayType -> cmmOffsetB platform expr (arrPtrsHdrSize dflags)
StgSmallArrayType -> cmmOffsetB platform expr (smallArrPtrsHdrSize dflags)
StgByteArrayType -> cmmOffsetB platform expr (arrWordsHdrSize dflags)
where
platform = targetPlatform dflags
collectStgFArgTypes :: Type -> [StgFArgType]
collectStgFArgTypes = go []
where
go bs (ForAllTy _ res) = go bs res
go bs (AppTy{}) = reverse bs
go bs (TyConApp{}) = reverse bs
go bs (LitTy{}) = reverse bs
go bs (TyVarTy{}) = reverse bs
go _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"
go _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"
go bs (FunTy {ft_arg = arg, ft_res=res}) =
go (typeToStgFArgType arg:bs) res
typeToStgFArgType :: Type -> StgFArgType
typeToStgFArgType typ
| tycon == arrayPrimTyCon = StgArrayType
| tycon == mutableArrayPrimTyCon = StgArrayType
| tycon == arrayArrayPrimTyCon = StgArrayType
| tycon == mutableArrayArrayPrimTyCon = StgArrayType
| tycon == smallArrayPrimTyCon = StgSmallArrayType
| tycon == smallMutableArrayPrimTyCon = StgSmallArrayType
| tycon == byteArrayPrimTyCon = StgByteArrayType
| tycon == mutableByteArrayPrimTyCon = StgByteArrayType
| otherwise = StgPlainType
where
tycon = tyConAppTyCon (unwrapType typ)