module StgCmmForeign (
cgForeignCall,
emitPrimCall, emitCCall,
emitForeignCall,
emitSaveThreadState,
saveThreadState,
emitLoadThreadState,
loadThreadState,
emitOpenNursery,
emitCloseNursery,
) where
#include "HsVersions.h"
import StgSyn
import StgCmmProf (storeCurCCS, ccsType, curCCS)
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
import StgCmmLayout
import Cmm
import CmmUtils
import MkGraph
import Type
import TysPrim
import CLabel
import SMRep
import ForeignCall
import DynFlags
import Maybes
import Outputable
import BasicTypes
import Control.Monad
#if __GLASGOW_HASKELL__ >= 709
import Prelude hiding( succ, (<*>) )
#else
import Prelude hiding( succ )
#endif
cgForeignCall :: ForeignCall
-> [StgArg]
-> Type
-> FCode ReturnKind
cgForeignCall (CCall (CCallSpec target cconv safety)) 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
; (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
updfr_off <- getUpdFrameOff
target' <- load_target_into_temp target
args' <- mapM maybe_assign_temp args
k <- newLabelC
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
tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
emit $ saveThreadState dflags tso cn
saveThreadState :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
saveThreadState dflags tso cn =
catAGraphs [
mkAssign (CmmLocal tso) stgCurrentTSO,
mkStore (cmmOffset dflags (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)) (stack_SP dflags)) stgSp,
closeNursery dflags tso cn,
if gopt Opt_SccProfilingOn dflags then
mkStore (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_CCCS dflags)) curCCS
else mkNop
]
emitCloseNursery :: FCode ()
emitCloseNursery = do
dflags <- getDynFlags
tso <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
closeNursery dflags tso cn
closeNursery :: DynFlags -> LocalReg -> LocalReg -> CmmAGraph
closeNursery df tso cn =
let
tsoreg = CmmLocal tso
cnreg = CmmLocal cn
in
catAGraphs [
mkAssign cnreg stgCurrentNursery,
mkStore (nursery_bdescr_free df cnreg) (cmmOffsetW df stgHp 1),
let alloc =
CmmMachOp (mo_wordSub df)
[ cmmOffsetW df stgHp 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
tso <- newTemp (gcWord dflags)
stack <- newTemp (gcWord dflags)
cn <- newTemp (bWord dflags)
bdfree <- newTemp (bWord dflags)
bdstart <- newTemp (bWord dflags)
emit $ loadThreadState dflags tso stack cn bdfree bdstart
loadThreadState :: DynFlags
-> LocalReg -> LocalReg -> LocalReg -> LocalReg -> LocalReg
-> CmmAGraph
loadThreadState dflags tso stack cn bdfree bdstart =
catAGraphs [
mkAssign (CmmLocal tso) stgCurrentTSO,
mkAssign (CmmLocal stack) (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal tso)) (tso_stackobj dflags)) (bWord dflags)),
mkAssign sp (CmmLoad (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_SP dflags)) (bWord dflags)),
mkAssign spLim (cmmOffsetW dflags (cmmOffset dflags (CmmReg (CmmLocal stack)) (stack_STACK dflags))
(rESERVED_STACK_WORDS dflags)),
mkAssign hpAlloc (zeroExpr dflags),
openNursery dflags tso cn bdfree bdstart,
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 (gcWord dflags)
cn <- newTemp (bWord dflags)
bdfree <- newTemp (bWord dflags)
bdstart <- newTemp (bWord dflags)
emit $ mkAssign (CmmLocal tso) stgCurrentTSO <*>
openNursery dflags tso cn bdfree bdstart
openNursery :: DynFlags
-> LocalReg -> LocalReg -> LocalReg -> LocalReg
-> CmmAGraph
openNursery df tso cn bdfree bdstart =
let
tsoreg = CmmLocal tso
cnreg = CmmLocal cn
bdfreereg = CmmLocal bdfree
bdstartreg = CmmLocal bdstart
in
catAGraphs [
mkAssign cnreg stgCurrentNursery,
mkAssign bdfreereg (CmmLoad (nursery_bdescr_free df cnreg) (bWord df)),
mkAssign hp (cmmOffsetW df (CmmReg bdfreereg) (1)),
mkAssign bdstartreg (CmmLoad (nursery_bdescr_start df cnreg) (bWord df)),
mkAssign hpLim
(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
stgSp, stgHp, stgCurrentTSO, stgCurrentNursery :: CmmExpr
stgSp = CmmReg sp
stgHp = CmmReg hp
stgCurrentTSO = CmmReg currentTSO
stgCurrentNursery = CmmReg currentNursery
sp, spLim, hp, hpLim, currentTSO, currentNursery, hpAlloc :: CmmReg
sp = CmmGlobal Sp
spLim = CmmGlobal SpLim
hp = CmmGlobal Hp
hpLim = CmmGlobal HpLim
currentTSO = CmmGlobal CurrentTSO
currentNursery = CmmGlobal CurrentNursery
hpAlloc = CmmGlobal HpAlloc
getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
getFCallArgs args
= do { mb_cmms <- mapM get args
; return (catMaybes mb_cmms) }
where
get arg | isVoidRep arg_rep
= return Nothing
| otherwise
= do { cmm <- getArgAmode (NonVoid arg)
; dflags <- getDynFlags
; return (Just (add_shim dflags arg_ty cmm, hint)) }
where
arg_ty = stgArgType arg
arg_rep = typePrimRep arg_ty
hint = typeForeignHint arg_ty
add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
add_shim dflags arg_ty expr
| tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
= cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
| tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
= cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
| tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
= cmmOffsetB dflags expr (arrWordsHdrSize dflags)
| otherwise = expr
where
UnaryRep rep_ty = repType arg_ty
tycon = tyConAppTyCon rep_ty