module StgCmmForeign (
cgForeignCall, loadThreadState, saveThreadState,
emitPrimCall, emitCCall,
emitSaveThreadState,
emitLoadThreadState,
emitOpenNursery,
) where
#include "HsVersions.h"
import StgSyn
import StgCmmProf
import StgCmmEnv
import StgCmmMonad
import StgCmmUtils
import StgCmmClosure
import BlockId
import Cmm
import CmmUtils
import MkZipCfgCmm hiding (CmmAGraph)
import Type
import TysPrim
import CLabel
import SMRep
import ForeignCall
import Constants
import StaticFlags
import Maybes
import Outputable
import ZipCfgCmmRep
import BasicTypes
import Control.Monad
cgForeignCall :: [LocalReg]
-> [ForeignHint]
-> ForeignCall
-> [StgArg]
-> FCode ()
cgForeignCall results result_hints (CCall (CCallSpec target cconv safety)) stg_args
= do { cmm_args <- getFCallArgs stg_args
; let ((call_args, arg_hints), cmm_target)
= case target of
StaticTarget lbl ->
(unzip cmm_args,
CmmLit (CmmLabel (mkForeignLabel lbl (call_size cmm_args)
False IsFunction)))
DynamicTarget -> case cmm_args of
(fn,_):rest -> (unzip rest, fn)
[] -> panic "cgForeignCall []"
fc = ForeignConvention cconv arg_hints result_hints
call_target = ForeignTarget cmm_target fc
; srt <- getSRTInfo NoSRT
; emitForeignCall safety results call_target call_args srt CmmMayReturn }
where
call_size args
| StdCallConv <- cconv = Just (sum (map arg_size args))
| otherwise = Nothing
arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType arg) wORD_SIZE
emitCCall :: [(CmmFormal,ForeignHint)]
-> CmmExpr
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= emitForeignCall PlayRisky results target args
NoC_SRT
CmmMayReturn
where
(args, arg_hints) = unzip hinted_args
(results, result_hints) = unzip hinted_results
target = ForeignTarget fn fc
fc = ForeignConvention CCallConv arg_hints result_hints
emitPrimCall :: CmmFormal -> CallishMachOp -> CmmActuals -> FCode ()
emitPrimCall res op args
= emitForeignCall PlayRisky [res] (PrimTarget op) args NoC_SRT CmmMayReturn
emitForeignCall
:: Safety
-> CmmFormals
-> MidCallTarget
-> CmmActuals
-> C_SRT
-> CmmReturnInfo
-> FCode ()
emitForeignCall safety results target args _srt _ret
| not (playSafe safety) = do
let (caller_save, caller_load) = callerSaveVolatileRegs
emit caller_save
emit $ mkUnsafeCall target results args
emit caller_load
| otherwise = do
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
emit $ mkSafeCall temp_target results args updfr_off
load_target_into_temp :: MidCallTarget -> FCode MidCallTarget
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
| hasNoGlobalRegs e = return e
| otherwise = do
reg <- newTemp (cmmExprType e)
emit (mkAssign (CmmLocal reg) e)
return (CmmReg (CmmLocal reg))
saveThreadState :: CmmAGraph
saveThreadState =
mkStore (cmmOffset stgCurrentTSO tso_SP) stgSp
<*> closeNursery
<*> if opt_SccProfilingOn then
mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS
else mkNop
emitSaveThreadState :: BlockId -> FCode ()
emitSaveThreadState bid = do
emit $ mkStore (cmmOffset stgCurrentTSO tso_SP)
(CmmStackSlot (CallArea (Young bid)) (widthInBytes (typeWidth gcWord)))
emit closeNursery
when opt_SccProfilingOn $
emit (mkStore (cmmOffset stgCurrentTSO tso_CCCS) curCCS)
closeNursery :: CmmAGraph
closeNursery = mkStore nursery_bdescr_free (cmmOffsetW stgHp 1)
loadThreadState :: LocalReg -> CmmAGraph
loadThreadState tso = do
catAGraphs [
mkAssign (CmmLocal tso) stgCurrentTSO,
mkAssign sp (CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_SP)
bWord),
mkAssign spLim (cmmOffsetW (cmmOffset (CmmReg (CmmLocal tso)) tso_STACK)
rESERVED_STACK_WORDS),
openNursery,
if opt_SccProfilingOn then
mkStore curCCSAddr
(CmmLoad (cmmOffset (CmmReg (CmmLocal tso)) tso_CCCS) ccsType)
else mkNop]
emitLoadThreadState :: LocalReg -> FCode ()
emitLoadThreadState tso = emit $ loadThreadState tso
openNursery :: CmmAGraph
openNursery = catAGraphs [
mkAssign hp (cmmOffsetW (CmmLoad nursery_bdescr_free bWord) (1)),
mkAssign 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)
)
)
]
emitOpenNursery :: FCode ()
emitOpenNursery = emit openNursery
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 :: CmmReg
sp = CmmGlobal Sp
spLim = CmmGlobal SpLim
hp = CmmGlobal Hp
hpLim = CmmGlobal HpLim
currentTSO = CmmGlobal CurrentTSO
currentNursery = CmmGlobal CurrentNursery
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)
; return (Just (add_shim arg_ty cmm, hint)) }
where
arg_ty = stgArgType arg
arg_rep = typePrimRep arg_ty
hint = typeForeignHint arg_ty
add_shim :: Type -> CmmExpr -> CmmExpr
add_shim arg_ty expr
| tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
= cmmOffsetB expr arrPtrsHdrSize
| tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
= cmmOffsetB expr arrWordsHdrSize
| otherwise = expr
where
tycon = tyConAppTyCon (repType arg_ty)