Commit 6228e318 authored by Simon Marlow's avatar Simon Marlow

Use "ReturnedTo" when generating safe foreign calls

parent 290ec750
......@@ -52,7 +52,7 @@ import OrdList
import MkGraph
import Data.IORef
import Control.Monad (when)
import Control.Monad (when,void)
import Util
codeGen :: DynFlags
......@@ -244,9 +244,9 @@ cgDataCon data_con
do { _ <- ticky_code
; ldvEnter (CmmReg nodeReg)
; tickyReturnOldCon (length arg_things)
; _ <- emitReturn [cmmOffsetB (CmmReg nodeReg)
; void $ emitReturn [cmmOffsetB (CmmReg nodeReg)
(tagForCon data_con)]
; return () }
}
-- The case continuation code expects a tagged pointer
arg_reps :: [(PrimRep, UnaryType)]
......
......@@ -436,8 +436,8 @@ closureCodeBody top_lvl bndr cl_info _cc args arity body fv_details
-- heap check, to reduce live vars over check
; if node_points then load_fvs node lf_info fv_bindings
else return ()
; _ <- cgExpr body
; return () }}
; void $ cgExpr body
}}
}
-- A function closure pointer may be tagged, so we
......@@ -503,8 +503,7 @@ thunkCode cl_info fv_details _cc node arity body
; let lf_info = closureLFInfo cl_info
; fv_bindings <- mapM bind_fv fv_details
; load_fvs node lf_info fv_bindings
; _ <- cgExpr body
; return () }}}
; void $ cgExpr body }}}
------------------------------------------------------------------------
......
......@@ -41,6 +41,7 @@ import Outputable
import BasicTypes
import Control.Monad
import Prelude hiding( succ )
-----------------------------------------------------------------------------
-- Code generation for Foreign Calls
......@@ -88,13 +89,11 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
; sequel <- getSequel
; case sequel of
AssignTo assign_to_these _ ->
do { emitForeignCall safety assign_to_these call_target
emitForeignCall safety assign_to_these call_target
call_args CmmMayReturn
; return AssignedDirectly
}
_something_else ->
do { emitForeignCall safety res_regs call_target
do { _ <- emitForeignCall safety res_regs call_target
call_args CmmMayReturn
; emitReturn (map (CmmReg . CmmLocal) res_regs)
}
......@@ -185,7 +184,7 @@ emitCCall :: [(CmmFormal,ForeignHint)]
-> [(CmmActual,ForeignHint)]
-> FCode ()
emitCCall hinted_results fn hinted_args
= emitForeignCall PlayRisky results target args CmmMayReturn
= void $ emitForeignCall PlayRisky results target args CmmMayReturn
where
(args, arg_hints) = unzip hinted_args
(results, result_hints) = unzip hinted_results
......@@ -195,7 +194,7 @@ emitCCall hinted_results fn hinted_args
emitPrimCall :: [CmmFormal] -> CallishMachOp -> [CmmActual] -> FCode ()
emitPrimCall res op args
= emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
= void $ emitForeignCall PlayRisky res (PrimTarget op) args CmmMayReturn
-- alternative entry point, used by CmmParse
emitForeignCall
......@@ -205,20 +204,34 @@ emitForeignCall
-> [CmmActual] -- arguments
-> CmmReturnInfo -- This can say "never returns"
-- only RTS procedures do this
-> FCode ()
-> FCode ReturnKind
emitForeignCall safety results target args _ret
| not (playSafe safety) = do
let (caller_save, caller_load) = callerSaveVolatileRegs
emit caller_save
emit $ mkUnsafeCall target results args
emit caller_load
return AssignedDirectly
| otherwise = do
updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target
emit =<< mkSafeCall temp_target results args updfr_off
(playInterruptible safety)
k <- newLabelC
let (off, copyout) = copyInOflow NativeReturn (Young k) results
-- see Note [safe foreign call convention]
emit $
( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall { tgt = temp_target
, res = results
, args = args
, succ = k
, updfr = updfr_off
, intrbl = playInterruptible safety })
<*> mkLabel k
<*> copyout
)
return (ReturnedTo k off)
{-
......
......@@ -30,7 +30,7 @@ module StgCmmMonad (
getCodeR, getCode, getHeapUsage,
mkCmmIfThenElse, mkCmmIfThen, mkCmmIfGoto,
mkCall, mkCmmCall, mkSafeCall,
mkCall, mkCmmCall,
forkClosureBody, forkStatics, forkAlts, forkProc, codeOnly,
......@@ -95,6 +95,9 @@ infixr 9 `thenFC`
newtype FCode a = FCode (CgInfoDownwards -> CgState -> (a, CgState))
instance Functor FCode where
fmap f (FCode g) = FCode $ \i s -> let (a,s') = g i s in (f a, s')
instance Monad FCode where
(>>=) = thenFC
return = returnFC
......@@ -792,22 +795,6 @@ mkCmmCall f results actuals updfr_off
= mkCall f (NativeDirectCall, NativeReturn) results actuals updfr_off (0,[])
mkSafeCall :: ForeignTarget -> [CmmFormal] -> [CmmActual]
-> UpdFrameOffset -> Bool
-> FCode CmmAGraph
mkSafeCall t fs as upd i = do
k <- newLabelC
let (_off, copyout) = copyInOflow NativeReturn (Young k) fs
-- see Note [safe foreign call convention]
return
( mkStore (CmmStackSlot (Young k) (widthInBytes wordWidth))
(CmmLit (CmmBlock k))
<*> mkLast (CmmForeignCall { tgt=t, res=fs, args=as, succ=k
, updfr=upd, intrbl=i })
<*> mkLabel k
<*> copyout
)
-- ----------------------------------------------------------------------------
-- CgStmts
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment