module GHC.StgToCmm.Foreign (
cgForeignCall,
emitPrimCall, emitCCall,
emitForeignCall,
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
emitSaveRegs,
emitRestoreRegs,
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 CmmCallConv
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 (CCall (CCallSpec target cconv safety ret_rep arg_reps)) typ stg_args res_ty
= do { dflags <- getDynFlags
; let
call_size args
| StdCallConv <- cconv = Just (sum (map arg_size args))
| otherwise = Nothing
arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
(wORD_SIZE dflags)
; 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 ret_rep arg_reps
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, PrimRep, ForeignHint)]
-> CmmExpr
-> [(CmmActual, PrimRep, ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= void $ emitForeignCall PlayRisky results target args
where
(args, arg_reps, arg_hints) = unzip3 hinted_args
(results, result_reps, result_hints) = unzip3 hinted_results
res_rep = case result_reps of
[] -> VoidRep
[r] -> r
_ -> error "can not deal with multiple return values in emitCCall"
target = ForeignTarget fn fc
fc = ForeignConvention CCallConv arg_hints result_hints CmmMayReturn res_rep arg_reps
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
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 dflags)))
(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
dflags <- getDynFlags
reg <- newTemp (cmmExprType dflags 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
tso <- newTemp (gcWord dflags)
close_nursery <- closeNursery dflags tso
pure $ catAGraphs [
mkAssign (CmmLocal tso) currentTSOExpr,
mkStore (cmmOffset dflags
(CmmLoad (cmmOffset dflags
(CmmReg (CmmLocal tso))
(tso_stackobj dflags))
(bWord dflags))
(stack_SP dflags))
spExpr,
close_nursery,
if gopt Opt_SccProfilingOn dflags then
mkStore (cmmOffset dflags (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
tso <- newTemp (bWord dflags)
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
cnreg <- CmmLocal <$> newTemp (bWord df)
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df hpExpr 1),
let alloc =
CmmMachOp (mo_wordSub df)
[ cmmOffsetW df hpExpr 1
, CmmLoad (nursery_bdescr_start df cnreg) (bWord df)
]
alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
in
mkStore alloc_limit (CmmMachOp (MO_Sub W64)
[ CmmLoad alloc_limit b64
, CmmMachOp (mo_WordTo64 df) [alloc] ])
]
emitLoadThreadState :: FCode ()
emitLoadThreadState = do
dflags <- getDynFlags
code <- loadThreadState dflags
emit code
loadThreadState :: MonadUnique m => DynFlags -> m CmmAGraph
loadThreadState dflags = do
tso <- newTemp (gcWord dflags)
stack <- newTemp (gcWord dflags)
open_nursery <- openNursery dflags tso
pure $ catAGraphs [
mkAssign (CmmLocal tso) currentTSOExpr,
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
mkAssign spReg (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
mkAssign spLimReg (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
mkAssign hpAllocReg (zeroExpr dflags),
open_nursery,
if gopt Opt_SccProfilingOn dflags
then storeCurCCS
(CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso))
(tso_CCCS dflags)) (ccsType dflags))
else mkNop
]
emitOpenNursery :: FCode ()
emitOpenNursery = do
dflags <- getDynFlags
tso <- newTemp (bWord dflags)
code <- openNursery dflags tso
emit $ mkAssign (CmmLocal tso) currentTSOExpr <*> code
openNursery :: MonadUnique m => DynFlags -> LocalReg -> m CmmAGraph
openNursery df tso = do
let tsoreg = CmmLocal tso
cnreg <- CmmLocal <$> newTemp (bWord df)
bdfreereg <- CmmLocal <$> newTemp (bWord df)
bdstartreg <- CmmLocal <$> newTemp (bWord df)
pure $ catAGraphs [
mkAssign cnreg currentNurseryExpr,
mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)),
mkAssign hpReg (cmmOffsetW df (CmmReg bdfreereg) (1)),
mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
mkAssign hpLimReg
(cmmOffsetExpr df
(CmmReg bdstartreg)
(cmmOffset df
(CmmMachOp (mo_wordMul df) [
CmmMachOp (MO_SS_Conv W32 (wordWidth df))
[CmmLoad (nursery_bdescr_blocks df cnreg) b32],
mkIntExpr df (bLOCK_SIZE df)
])
(1)
)
),
let alloc =
CmmMachOp (mo_wordSub df) [CmmReg bdfreereg, CmmReg bdstartreg]
alloc_limit = cmmOffset df (CmmReg tsoreg) (tso_alloc_limit df)
in
mkStore alloc_limit (CmmMachOp (MO_Add W64)
[ CmmLoad alloc_limit b64
, CmmMachOp (mo_WordTo64 df) [alloc] ])
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks
:: DynFlags -> CmmReg -> CmmExpr
nursery_bdescr_free dflags cn =
cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_free dflags)
nursery_bdescr_start dflags cn =
cmmOffset dflags (CmmReg cn) (oFFSET_bdescr_start dflags)
nursery_bdescr_blocks dflags cn =
cmmOffset 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 dflags expr (arrPtrsHdrSize dflags)
StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize 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)