module CgForeignCall (
cgForeignCall,
emitForeignCall,
emitForeignCall',
shimForeignCallArg,
emitSaveThreadState,
emitLoadThreadState,
emitCloseNursery,
emitOpenNursery,
) where
import StgSyn
import CgProf
import CgBindery
import CgMonad
import CgUtils
import Type
import TysPrim
import CLabel
import Cmm
import CmmUtils
import SMRep
import ForeignCall
import ClosureInfo
import Constants
import StaticFlags
import Outputable
import Module
import FastString
import BasicTypes
import Control.Monad
cgForeignCall
:: HintedCmmFormals
-> ForeignCall
-> [StgArg]
-> StgLiveVars
-> Code
cgForeignCall results fcall stg_args live
= do
reps_n_amodes <- getArgAmodes stg_args
let
arg_exprs = [ shimForeignCallArg stg_arg expr
| (stg_arg, (rep,expr)) <- stg_args `zip` reps_n_amodes,
nonVoidArg rep]
arg_hints = zipWith CmmHinted
arg_exprs (map (typeForeignHint.stgArgType) stg_args)
emitForeignCall results fcall arg_hints live
emitForeignCall
:: HintedCmmFormals
-> ForeignCall
-> [CmmHinted CmmExpr]
-> StgLiveVars
-> Code
emitForeignCall results (CCall (CCallSpec target cconv safety)) args live
= do vols <- getVolatileRegs live
srt <- getSRTInfo
emitForeignCall' safety results
(CmmCallee cmm_target cconv) call_args (Just vols) srt CmmMayReturn
where
(call_args, cmm_target)
= case target of
StaticTarget lbl mPkgId
-> let labelSource
= case mPkgId of
Nothing -> ForeignLabelInThisPackage
Just pkgId -> ForeignLabelInPackage pkgId
in ( args
, CmmLit (CmmLabel
(mkForeignLabel lbl call_size labelSource IsFunction)))
DynamicTarget -> case args of
(CmmHinted fn _):rest -> (rest, fn)
[] -> panic "emitForeignCall: DynamicTarget []"
call_size
| StdCallConv <- cconv = Just (sum (map (arg_size.cmmExprType.hintlessCmm) args))
| otherwise = Nothing
arg_size rep = max (widthInBytes (typeWidth rep)) wORD_SIZE
emitForeignCall'
:: Safety
-> HintedCmmFormals
-> CmmCallTarget
-> [CmmHinted CmmExpr]
-> Maybe [GlobalReg]
-> C_SRT
-> CmmReturnInfo
-> Code
emitForeignCall' safety results target args vols _srt ret
| not (playSafe safety) = do
temp_args <- load_args_into_temps args
let (caller_save, caller_load) = callerSaveVolatileRegs vols
let caller_load' = if ret == CmmNeverReturns then [] else caller_load
stmtsC caller_save
stmtC (CmmCall target results temp_args CmmUnsafe ret)
stmtsC caller_load'
| otherwise = do
id <- newTemp bWord
new_base <- newTemp (cmmRegType (CmmGlobal BaseReg))
temp_args <- load_args_into_temps args
temp_target <- load_target_into_temp target
let (caller_save, caller_load) = callerSaveVolatileRegs vols
emitSaveThreadState
stmtsC caller_save
stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ]
CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv)
[ CmmHinted new_base AddrHint ]
[ CmmHinted (CmmReg (CmmLocal id)) AddrHint ]
CmmUnsafe ret)
stmtC (CmmAssign (CmmGlobal BaseReg) (CmmReg (CmmLocal new_base)))
stmtsC caller_load
emitLoadThreadState
suspendThread, resumeThread :: CmmExpr
suspendThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "suspendThread")))
resumeThread = CmmLit (CmmLabel (mkCmmCodeLabel rtsPackageId (fsLit "resumeThread")))
load_args_into_temps :: [CmmHinted CmmExpr] -> FCode [CmmHinted CmmExpr]
load_args_into_temps = mapM arg_assign_temp
where arg_assign_temp (CmmHinted e hint) = do
tmp <- maybe_assign_temp e
return (CmmHinted tmp hint)
load_target_into_temp :: CmmCallTarget -> FCode CmmCallTarget
load_target_into_temp (CmmCallee expr conv) = do
tmp <- maybe_assign_temp expr
return (CmmCallee tmp conv)
load_target_into_temp other_target =
return other_target
maybe_assign_temp :: CmmExpr -> FCode CmmExpr
maybe_assign_temp e
| hasNoGlobalRegs e = return e
| otherwise = do
reg <- newTemp (cmmExprType e)
stmtC (CmmAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
emitSaveThreadState :: Code
emitSaveThreadState = do
stmtC $ CmmStore (cmmOffset stgCurrentTSO tso_SP) stgSp
emitCloseNursery
when opt_SccProfilingOn $
stmtC (CmmStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
emitCloseNursery :: Code
emitCloseNursery = stmtC $ CmmStore nursery_bdescr_free (cmmOffsetW stgHp 1)
emitLoadThreadState :: Code
emitLoadThreadState = do
tso <- newTemp bWord
stmtsC [
CmmAssign (CmmLocal tso) stgCurrentTSO,
CmmAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
bWord),
CmmAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
rESERVED_STACK_WORDS),
CmmAssign hpAlloc (CmmLit zeroCLit)
]
emitOpenNursery
when opt_SccProfilingOn $
stmtC (CmmStore curCCSAddr
(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) bWord))
emitOpenNursery :: Code
emitOpenNursery = stmtsC [
CmmAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free gcWord) (1)),
CmmAssign hpLim
(cmmOffsetExpr
(CmmLoad nursery_bdescr_start bWord)
(cmmOffset
(CmmMachOp mo_wordMul [
CmmMachOp (MO_SS_Conv W32 wordWidth)
[CmmLoad nursery_bdescr_blocks b32],
CmmLit (mkIntCLit bLOCK_SIZE)
])
(1)
)
)
]
nursery_bdescr_free, nursery_bdescr_start, nursery_bdescr_blocks :: CmmExpr
nursery_bdescr_free = cmmOffset stgCurrentNursery oFFSET_bdescr_free
nursery_bdescr_start = cmmOffset stgCurrentNursery oFFSET_bdescr_start
nursery_bdescr_blocks = cmmOffset stgCurrentNursery oFFSET_bdescr_blocks
tso_SP, tso_STACK, tso_CCCS :: ByteOff
tso_SP = tsoFieldB oFFSET_StgTSO_sp
tso_STACK = tsoFieldB oFFSET_StgTSO_stack
tso_CCCS = tsoProfFieldB oFFSET_StgTSO_CCCS
tsoFieldB :: ByteOff -> ByteOff
tsoFieldB off
| opt_SccProfilingOn = off + sIZEOF_StgTSOProfInfo + fixedHdrSize * wORD_SIZE
| otherwise = off + fixedHdrSize * wORD_SIZE
tsoProfFieldB :: ByteOff -> ByteOff
tsoProfFieldB off = off + fixedHdrSize * wORD_SIZE
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
shimForeignCallArg :: StgArg -> CmmExpr -> CmmExpr
shimForeignCallArg arg expr
| tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
= cmmOffsetB expr arrPtrsHdrSize
| tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
= cmmOffsetB expr arrWordsHdrSize
| otherwise = expr
where
tycon = tyConAppTyCon (repType (stgArgType arg))