Commit 83d563cb authored by Edward Z. Yang's avatar Edward Z. Yang

Interruptible FFI calls with pthread_kill and CancelSynchronousIO. v4

This is patch that adds support for interruptible FFI calls in the form
of a new foreign import keyword 'interruptible', which can be used
instead of 'safe' or 'unsafe'.  Interruptible FFI calls act like safe
FFI calls, except that the worker thread they run on may be interrupted.

Internally, it replaces BlockedOnCCall_NoUnblockEx with
BlockedOnCCall_Interruptible, and changes the behavior of the RTS
to not modify the TSO_ flags on the event of an FFI call from
a thread that was interruptible.  It also modifies the bytecode
format for foreign call, adding an extra Word16 to indicate
interruptibility.

The semantics of interruption vary from platform to platform, but the
intent is that any blocking system calls are aborted with an error code.
This is most useful for making function calls to system library
functions that support interrupting.  There is no support for pre-Vista
Windows.

There is a partner testsuite patch which adds several tests for this
functionality.
parent 9fa96fc4
...@@ -254,7 +254,7 @@ type HintedCmmFormals = [HintedCmmFormal] ...@@ -254,7 +254,7 @@ type HintedCmmFormals = [HintedCmmFormal]
type HintedCmmFormal = CmmHinted CmmFormal type HintedCmmFormal = CmmHinted CmmFormal
type HintedCmmActual = CmmHinted CmmActual type HintedCmmActual = CmmHinted CmmActual
data CmmSafety = CmmUnsafe | CmmSafe C_SRT data CmmSafety = CmmUnsafe | CmmSafe C_SRT | CmmInterruptible
-- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals' -- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
instance UserOfLocalRegs CmmStmt where instance UserOfLocalRegs CmmStmt where
......
...@@ -459,7 +459,7 @@ extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g ...@@ -459,7 +459,7 @@ extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
l = case last of LastOther l -> l l = case last of LastOther l -> l
LastExit -> panic "extendEnvs lastExit" LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _) = z tail _ z (ZFirst _) = z
tail fact env (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = tail fact env (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
tail (mid m fact) (extendBlockEnv env bid fact) h tail (mid m fact) (extendBlockEnv env bid fact) h
tail fact env (ZHead h m) = tail (mid m fact) env h tail fact env (ZHead h m) = tail (mid m fact) env h
lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
...@@ -478,7 +478,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g = ...@@ -478,7 +478,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
LastExit -> panic "extendEnvs lastExit" LastExit -> panic "extendEnvs lastExit"
tail _ z (ZFirst _) = z tail _ z (ZFirst _) = z
tail lives@(cafs, slots) (cafEnv, slotEnv) tail lives@(cafs, slots) (cafEnv, slotEnv)
(ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) = (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =
let slots' = removeLiveSlotDefs slots m let slots' = removeLiveSlotDefs slots m
slotEnv' = extendBlockEnv slotEnv bid slots' slotEnv' = extendBlockEnv slotEnv bid slots'
cafEnv' = extendBlockEnv cafEnv bid cafs cafEnv' = extendBlockEnv cafEnv bid cafs
...@@ -542,7 +542,7 @@ lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do ...@@ -542,7 +542,7 @@ lowerSafeForeignCalls rst (CmmProc info l args (off, g@(LGraph entry _))) = do
-- Check for foreign calls -- if none, then we can avoid copying the block. -- Check for foreign calls -- if none, then we can avoid copying the block.
hasSafeForeignCall :: CmmBlock -> Bool hasSafeForeignCall :: CmmBlock -> Bool
hasSafeForeignCall (Block _ t) = tail t hasSafeForeignCall (Block _ t) = tail t
where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
tail (ZTail _ t) = tail t tail (ZTail _ t) = tail t
tail (ZLast _) = False tail (ZLast _) = False
...@@ -554,7 +554,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) ...@@ -554,7 +554,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
tail s b@(ZBlock (ZFirst _) _) = tail s b@(ZBlock (ZFirst _) _) =
do state <- s do state <- s
return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) } return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off) _ _ _)) t) = tail s (ZBlock (ZHead h m@(MidForeignCall (Safe bid updfr_off _) _ _ _)) t) =
do state <- s do state <- s
let state' = state let state' = state
{ s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off : { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
...@@ -568,7 +568,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last)) ...@@ -568,7 +568,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
-- to lower a safe foreign call to a sequence of unsafe calls. -- to lower a safe foreign call to a sequence of unsafe calls.
lowerSafeForeignCall :: lowerSafeForeignCall ::
SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last) SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _ interruptible) _ _ _) tail = do
let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep) let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
-- Both 'id' and 'new_base' are KindNonPtr because they're -- Both 'id' and 'new_base' are KindNonPtr because they're
-- RTS-only objects and are not subject to garbage collection -- RTS-only objects and are not subject to garbage collection
...@@ -582,8 +582,9 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do ...@@ -582,8 +582,9 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
saveThreadState <*> saveThreadState <*>
caller_save <*> caller_save <*>
mkUnsafeCall (ForeignTarget suspendThread mkUnsafeCall (ForeignTarget suspendThread
(ForeignConvention CCallConv [AddrHint] [AddrHint])) (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
[id] [CmmReg (CmmGlobal BaseReg)] -- XXX Not sure if the size of the CmmInt is correct
[id] [CmmReg (CmmGlobal BaseReg), CmmLit (CmmInt (fromIntegral (fromEnum interruptible)) wordWidth)]
resume = mkUnsafeCall (ForeignTarget resumeThread resume = mkUnsafeCall (ForeignTarget resumeThread
(ForeignConvention CCallConv [AddrHint] [AddrHint])) (ForeignConvention CCallConv [AddrHint] [AddrHint]))
[new_base] [CmmReg (CmmLocal id)] <*> [new_base] [CmmReg (CmmLocal id)] <*>
......
...@@ -232,7 +232,9 @@ foreignCall uniques call results arguments = ...@@ -232,7 +232,9 @@ foreignCall uniques call results arguments =
caller_save ++ caller_save ++
[CmmCall (CmmCallee suspendThread CCallConv) [CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ] [ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
-- XXX: allow for interruptible suspension
, CmmHinted (CmmLit (CmmInt 0 wordWidth)) NoHint ]
CmmUnsafe CmmUnsafe
CmmMayReturn, CmmMayReturn,
CmmCall call results new_args CmmUnsafe CmmMayReturn, CmmCall call results new_args CmmUnsafe CmmMayReturn,
......
...@@ -8,6 +8,8 @@ ...@@ -8,6 +8,8 @@
-- --
----------------------------------------------------------------------------- -----------------------------------------------------------------------------
-- TODO: Add support for interruptible/uninterruptible foreign call specification
{ {
{-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-} {-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
-- The NoMonomorphismRestriction deals with a Happy infelicity -- The NoMonomorphismRestriction deals with a Happy infelicity
...@@ -734,6 +736,7 @@ callishMachOps = listToUFM $ ...@@ -734,6 +736,7 @@ callishMachOps = listToUFM $
parseSafety :: String -> P CmmSafety parseSafety :: String -> P CmmSafety
parseSafety "safe" = return (CmmSafe NoC_SRT) parseSafety "safe" = return (CmmSafe NoC_SRT)
parseSafety "unsafe" = return CmmUnsafe parseSafety "unsafe" = return CmmUnsafe
parseSafety "interruptible" = return CmmInterruptible
parseSafety str = fail ("unrecognised safety: " ++ str) parseSafety str = fail ("unrecognised safety: " ++ str)
parseCmmHint :: String -> P ForeignHint parseCmmHint :: String -> P ForeignHint
...@@ -864,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret ...@@ -864,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
code (emitForeignCall' (PlaySafe unused) results code (emitForeignCall' (PlaySafe unused) results
(CmmCallee expr' convention) args vols NoC_SRT ret) where (CmmCallee expr' convention) args vols NoC_SRT ret) where
unused = panic "not used by emitForeignCall'" unused = panic "not used by emitForeignCall'"
CmmInterruptible ->
code (emitForeignCall' PlayInterruptible results
(CmmCallee expr' convention) args vols NoC_SRT ret)
adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
#ifdef mingw32_TARGET_OS #ifdef mingw32_TARGET_OS
...@@ -898,6 +904,9 @@ primCall results_code name args_code vols safety ...@@ -898,6 +904,9 @@ primCall results_code name args_code vols safety
code (emitForeignCall' (PlaySafe unused) results code (emitForeignCall' (PlaySafe unused) results
(CmmPrim p) args vols NoC_SRT CmmMayReturn) where (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
unused = panic "not used by emitForeignCall'" unused = panic "not used by emitForeignCall'"
CmmInterruptible ->
code (emitForeignCall' PlayInterruptible results
(CmmPrim p) args vols NoC_SRT CmmMayReturn)
doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode doStore :: CmmType -> ExtFCode CmmExpr -> ExtFCode CmmExpr -> ExtCode
doStore rep addr_code val_code doStore rep addr_code val_code
......
...@@ -358,7 +358,7 @@ layout procPoints env entry_off g = ...@@ -358,7 +358,7 @@ layout procPoints env entry_off g =
fold_succs (setSuccSPs inSp) l areaMap fold_succs (setSuccSPs inSp) l areaMap
where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
allocMidCall m@(MidForeignCall (Safe bid _) _ _ _) t areaMap = allocMidCall m@(MidForeignCall (Safe bid _ _) _ _ _) t areaMap =
let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m let young = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
area = CallArea (Young bid) area = CallArea (Young bid)
areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
...@@ -422,7 +422,7 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) = ...@@ -422,7 +422,7 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) =
where spIn = sp_on_entry id where spIn = sp_on_entry id
replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) ->
FuelMonad ([CmmBlock]) FuelMonad ([CmmBlock])
replTail h spOff (ZTail m@(MidForeignCall (Safe bid _) _ _ _) t) = replTail h spOff (ZTail m@(MidForeignCall (Safe bid _ _) _ _ _) t) =
replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord) where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
......
...@@ -64,7 +64,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals ...@@ -64,7 +64,7 @@ mkCall :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals
mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals -> mkCmmCall :: CmmExpr -> CmmFormals -> CmmActuals ->
UpdFrameOffset -> CmmAGraph UpdFrameOffset -> CmmAGraph
-- Native C-- calling convention -- Native C-- calling convention
mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph mkSafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph
mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph mkUnsafeCall :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph mkFinalCall :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
-- Never returns; like exit() or barf() -- Never returns; like exit() or barf()
...@@ -131,9 +131,9 @@ mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r ...@@ -131,9 +131,9 @@ mkAssign l r = if opt_StubDeadValues then assign l r <*> check l else assign l r
mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot) mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
mkSwitch e tbl = mkLast $ LastSwitch e tbl mkSwitch e tbl = mkLast $ LastSwitch e tbl
mkSafeCall t fs as upd = mkSafeCall t fs as upd interruptible =
withFreshLabel "safe call" $ \k -> withFreshLabel "safe call" $ \k ->
mkMiddle $ MidForeignCall (Safe k upd) t fs as mkMiddle $ MidForeignCall (Safe k upd interruptible) t fs as
mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
-- For debugging purposes, we can stub out dead stack slots: -- For debugging purposes, we can stub out dead stack slots:
......
...@@ -143,6 +143,7 @@ pprTop (CmmData section ds) = ...@@ -143,6 +143,7 @@ pprTop (CmmData section ds) =
instance Outputable CmmSafety where instance Outputable CmmSafety where
ppr CmmUnsafe = ptext (sLit "_unsafe_call_") ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
ppr (CmmSafe srt) = ppr srt ppr (CmmSafe srt) = ppr srt
ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
-- -------------------------------------------------------------------------- -- --------------------------------------------------------------------------
-- Info tables. The current pretty printer needs refinement -- Info tables. The current pretty printer needs refinement
......
...@@ -165,6 +165,7 @@ data ForeignSafety ...@@ -165,6 +165,7 @@ data ForeignSafety
= Unsafe -- unsafe call = Unsafe -- unsafe call
| Safe BlockId -- making infotable requires: 1. label | Safe BlockId -- making infotable requires: 1. label
UpdFrameOffset -- 2. where the upd frame is UpdFrameOffset -- 2. where the upd frame is
Bool -- is the call interruptible?
deriving Eq deriving Eq
data ValueDirection = Arguments | Results data ValueDirection = Arguments | Results
...@@ -484,7 +485,9 @@ ppr_fc (ForeignConvention c args res) = ...@@ -484,7 +485,9 @@ ppr_fc (ForeignConvention c args res) =
doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
ppr_safety :: ForeignSafety -> SDoc ppr_safety :: ForeignSafety -> SDoc
ppr_safety (Safe bid upd) = text "safe<" <> ppr bid <> text ", " <> ppr upd <> text ">" ppr_safety (Safe bid upd interruptible) =
text (if interruptible then "interruptible" else "safe") <>
text "<" <> ppr bid <> text ", " <> ppr upd <> text ">"
ppr_safety Unsafe = text "unsafe" ppr_safety Unsafe = text "unsafe"
ppr_call_target :: MidCallTarget -> SDoc ppr_call_target :: MidCallTarget -> SDoc
......
...@@ -144,7 +144,8 @@ emitForeignCall' safety results target args vols _srt ret ...@@ -144,7 +144,8 @@ emitForeignCall' safety results target args vols _srt ret
-- to this sequence of three CmmUnsafe calls. -- to this sequence of three CmmUnsafe calls.
stmtC (CmmCall (CmmCallee suspendThread CCallConv) stmtC (CmmCall (CmmCallee suspendThread CCallConv)
[ CmmHinted id AddrHint ] [ CmmHinted id AddrHint ]
[ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
, CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]
CmmUnsafe ret) CmmUnsafe ret)
stmtC (CmmCall temp_target results temp_args CmmUnsafe ret) stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
stmtC (CmmCall (CmmCallee resumeThread CCallConv) stmtC (CmmCall (CmmCallee resumeThread CCallConv)
......
...@@ -127,7 +127,7 @@ emitForeignCall safety results target args _srt _ret ...@@ -127,7 +127,7 @@ emitForeignCall safety results target args _srt _ret
| otherwise = do | otherwise = do
updfr_off <- getUpdFrameOff updfr_off <- getUpdFrameOff
temp_target <- load_target_into_temp target temp_target <- load_target_into_temp target
emit $ mkSafeCall temp_target results args updfr_off emit $ mkSafeCall temp_target results args updfr_off (playInterruptible safety)
{- {-
......
...@@ -349,6 +349,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv) ...@@ -349,6 +349,7 @@ repCCallConv callConv = notHandled "repCCallConv" (ppr callConv)
repSafety :: Safety -> DsM (Core TH.Safety) repSafety :: Safety -> DsM (Core TH.Safety)
repSafety PlayRisky = rep2 unsafeName [] repSafety PlayRisky = rep2 unsafeName []
repSafety PlayInterruptible = rep2 interruptibleName []
repSafety (PlaySafe False) = rep2 safeName [] repSafety (PlaySafe False) = rep2 safeName []
repSafety (PlaySafe True) = rep2 threadsafeName [] repSafety (PlaySafe True) = rep2 threadsafeName []
...@@ -1716,6 +1717,7 @@ templateHaskellNames = [ ...@@ -1716,6 +1717,7 @@ templateHaskellNames = [
unsafeName, unsafeName,
safeName, safeName,
threadsafeName, threadsafeName,
interruptibleName,
-- InlineSpec -- InlineSpec
inlineSpecNoPhaseName, inlineSpecPhaseName, inlineSpecNoPhaseName, inlineSpecPhaseName,
-- FunDep -- FunDep
...@@ -1959,10 +1961,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey ...@@ -1959,10 +1961,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey
stdCallName = libFun (fsLit "stdCall") stdCallIdKey stdCallName = libFun (fsLit "stdCall") stdCallIdKey
-- data Safety = ... -- data Safety = ...
unsafeName, safeName, threadsafeName :: Name unsafeName, safeName, threadsafeName, interruptibleName :: Name
unsafeName = libFun (fsLit "unsafe") unsafeIdKey unsafeName = libFun (fsLit "unsafe") unsafeIdKey
safeName = libFun (fsLit "safe") safeIdKey safeName = libFun (fsLit "safe") safeIdKey
threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey
-- data InlineSpec = ... -- data InlineSpec = ...
inlineSpecNoPhaseName, inlineSpecPhaseName :: Name inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
...@@ -2235,10 +2238,11 @@ cCallIdKey = mkPreludeMiscIdUnique 300 ...@@ -2235,10 +2238,11 @@ cCallIdKey = mkPreludeMiscIdUnique 300
stdCallIdKey = mkPreludeMiscIdUnique 301 stdCallIdKey = mkPreludeMiscIdUnique 301
-- data Safety = ... -- data Safety = ...
unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique
unsafeIdKey = mkPreludeMiscIdUnique 305 unsafeIdKey = mkPreludeMiscIdUnique 305
safeIdKey = mkPreludeMiscIdUnique 306 safeIdKey = mkPreludeMiscIdUnique 306
threadsafeIdKey = mkPreludeMiscIdUnique 307 threadsafeIdKey = mkPreludeMiscIdUnique 307
interruptibleIdKey = mkPreludeMiscIdUnique 308
-- data InlineSpec = -- data InlineSpec =
inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
......
...@@ -309,8 +309,8 @@ mkBits findLabel st proto_insns ...@@ -309,8 +309,8 @@ mkBits findLabel st proto_insns
ENTER -> instr1 st bci_ENTER ENTER -> instr1 st bci_ENTER
RETURN -> instr1 st bci_RETURN RETURN -> instr1 st bci_RETURN
RETURN_UBX rep -> instr1 st (return_ubx rep) RETURN_UBX rep -> instr1 st (return_ubx rep)
CCALL off m_addr -> do (np, st2) <- addr st m_addr CCALL off m_addr int -> do (np, st2) <- addr st m_addr
instr3 st2 bci_CCALL off np instr4 st2 bci_CCALL off np int
BRK_FUN array index info -> do BRK_FUN array index info -> do
(p1, st2) <- ptr st (BCOPtrArray array) (p1, st2) <- ptr st (BCOPtrArray array)
(p2, st3) <- ptr st2 (BCOPtrBreakInfo info) (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
...@@ -478,7 +478,7 @@ instrSize16s instr ...@@ -478,7 +478,7 @@ instrSize16s instr
ENTER{} -> 1 ENTER{} -> 1
RETURN{} -> 1 RETURN{} -> 1
RETURN_UBX{} -> 1 RETURN_UBX{} -> 1
CCALL{} -> 3 CCALL{} -> 4
SWIZZLE{} -> 3 SWIZZLE{} -> 3
BRK_FUN{} -> 4 BRK_FUN{} -> 4
......
...@@ -923,7 +923,7 @@ generateCCall :: Word16 -> Sequel -- stack and sequel depths ...@@ -923,7 +923,7 @@ generateCCall :: Word16 -> Sequel -- stack and sequel depths
-> [AnnExpr' Id VarSet] -- args (atoms) -> [AnnExpr' Id VarSet] -- args (atoms)
-> BcM BCInstrList -> BcM BCInstrList
generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l generateCCall d0 s p (CCallSpec target cconv safety) fn args_r_to_l
= let = let
-- useful constants -- useful constants
addr_sizeW :: Word16 addr_sizeW :: Word16
...@@ -1092,7 +1092,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l ...@@ -1092,7 +1092,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller)) recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
let let
-- do the call -- do the call
do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)) do_call = unitOL (CCALL stk_offset (castFunPtrToPtr addr_of_marshaller)
(fromIntegral (fromEnum (playInterruptible safety))))
-- slide and return -- slide and return
wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s) wrapup = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
`snocOL` RETURN_UBX (primRepToCgRep r_rep) `snocOL` RETURN_UBX (primRepToCgRep r_rep)
......
...@@ -127,6 +127,9 @@ data BCInstr ...@@ -127,6 +127,9 @@ data BCInstr
-- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi) -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
| CCALL Word16 -- stack frame size | CCALL Word16 -- stack frame size
(Ptr ()) -- addr of the glue code (Ptr ()) -- addr of the glue code
Word16 -- whether or not the call is interruptible
-- (XXX: inefficient, but I don't know
-- what the alignment constraints are.)
-- For doing magic ByteArray passing to foreign calls -- For doing magic ByteArray passing to foreign calls
| SWIZZLE Word16 -- to the ptr N words down the stack, | SWIZZLE Word16 -- to the ptr N words down the stack,
...@@ -217,9 +220,12 @@ instance Outputable BCInstr where ...@@ -217,9 +220,12 @@ instance Outputable BCInstr where
ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab ppr (TESTEQ_P i lab) = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
ppr CASEFAIL = text "CASEFAIL" ppr CASEFAIL = text "CASEFAIL"
ppr (JMP lab) = text "JMP" <+> ppr lab ppr (JMP lab) = text "JMP" <+> ppr lab
ppr (CCALL off marshall_addr) = text "CCALL " <+> ppr off ppr (CCALL off marshall_addr int) = text "CCALL " <+> ppr off
<+> text "marshall code at" <+> text "marshall code at"
<+> text (show marshall_addr) <+> text (show marshall_addr)
<+> (if int == 1
then text "(interruptible)"
else empty)
ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff ppr (SWIZZLE stkoff n) = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
<+> text "by" <+> ppr n <+> text "by" <+> ppr n
ppr ENTER = text "ENTER" ppr ENTER = text "ENTER"
......
...@@ -375,6 +375,7 @@ cvtForD (ImportF callconv safety from nm ty) ...@@ -375,6 +375,7 @@ cvtForD (ImportF callconv safety from nm ty)
Unsafe -> PlayRisky Unsafe -> PlayRisky
Safe -> PlaySafe False Safe -> PlaySafe False
Threadsafe -> PlaySafe True Threadsafe -> PlaySafe True
Interruptible -> PlayInterruptible
cvtForD (ExportF callconv as nm ty) cvtForD (ExportF callconv as nm ty)
= do { nm' <- vNameL nm = do { nm' <- vNameL nm
......
...@@ -897,7 +897,7 @@ data ForeignImport = -- import of a C entity ...@@ -897,7 +897,7 @@ data ForeignImport = -- import of a C entity
-- * `Safety' is irrelevant for `CLabel' and `CWrapper' -- * `Safety' is irrelevant for `CLabel' and `CWrapper'
-- --
CImport CCallConv -- ccall or stdcall CImport CCallConv -- ccall or stdcall
Safety -- safe or unsafe Safety -- interruptible, safe or unsafe
FastString -- name of C header FastString -- name of C header
CImportSpec -- details of the C entity CImportSpec -- details of the C entity
deriving (Data, Typeable) deriving (Data, Typeable)
......
...@@ -452,6 +452,7 @@ data Token ...@@ -452,6 +452,7 @@ data Token
| ITdynamic | ITdynamic
| ITsafe | ITsafe
| ITthreadsafe | ITthreadsafe
| ITinterruptible
| ITunsafe | ITunsafe
| ITstdcallconv | ITstdcallconv
| ITccallconv | ITccallconv
...@@ -596,6 +597,7 @@ isSpecial ITlabel = True ...@@ -596,6 +597,7 @@ isSpecial ITlabel = True
isSpecial ITdynamic = True isSpecial ITdynamic = True
isSpecial ITsafe = True isSpecial ITsafe = True
isSpecial ITthreadsafe = True isSpecial ITthreadsafe = True
isSpecial ITinterruptible = True
isSpecial ITunsafe = True isSpecial ITunsafe = True
isSpecial ITccallconv = True isSpecial ITccallconv = True
isSpecial ITstdcallconv = True isSpecial ITstdcallconv = True
...@@ -658,6 +660,7 @@ reservedWordsFM = listToUFM $ ...@@ -658,6 +660,7 @@ reservedWordsFM = listToUFM $
( "dynamic", ITdynamic, bit ffiBit), ( "dynamic", ITdynamic, bit ffiBit),
( "safe", ITsafe, bit ffiBit), ( "safe", ITsafe, bit ffiBit),
( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove ( "threadsafe", ITthreadsafe, bit ffiBit), -- ToDo: remove
( "interruptible", ITinterruptible, bit ffiBit),
( "unsafe", ITunsafe, bit ffiBit), ( "unsafe", ITunsafe, bit ffiBit),
( "stdcall", ITstdcallconv, bit ffiBit), ( "stdcall", ITstdcallconv, bit ffiBit),
( "ccall", ITccallconv, bit ffiBit), ( "ccall", ITccallconv, bit ffiBit),
......
...@@ -248,6 +248,7 @@ incorrect. ...@@ -248,6 +248,7 @@ incorrect.
'dynamic' { L _ ITdynamic } 'dynamic' { L _ ITdynamic }
'safe' { L _ ITsafe } 'safe' { L _ ITsafe }
'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias 'threadsafe' { L _ ITthreadsafe } -- ToDo: remove deprecated alias
'interruptible' { L _ ITinterruptible }
'unsafe' { L _ ITunsafe } 'unsafe' { L _ ITunsafe }
'mdo' { L _ ITmdo } 'mdo' { L _ ITmdo }
'family' { L _ ITfamily } 'family' { L _ ITfamily }
...@@ -896,6 +897,7 @@ callconv :: { CCallConv } ...@@ -896,6 +897,7 @@ callconv :: { CCallConv }
safety :: { Safety } safety :: { Safety }
: 'unsafe' { PlayRisky } : 'unsafe' { PlayRisky }
| 'safe' { PlaySafe False } | 'safe' { PlaySafe False }
| 'interruptible' { PlayInterruptible }
| 'threadsafe' { PlaySafe True } -- deprecated alias | 'threadsafe' { PlaySafe True } -- deprecated alias
fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) } fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
...@@ -1791,6 +1793,7 @@ tyvarid :: { Located RdrName } ...@@ -1791,6 +1793,7 @@ tyvarid :: { Located RdrName }
| special_id { L1 $! mkUnqual tvName (unLoc $1) } | special_id { L1 $! mkUnqual tvName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") } | 'unsafe' { L1 $! mkUnqual tvName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual tvName (fsLit "safe") } | 'safe' { L1 $! mkUnqual tvName (fsLit "safe") }
| 'interruptible' { L1 $! mkUnqual tvName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") } | 'threadsafe' { L1 $! mkUnqual tvName (fsLit "threadsafe") }
tyvarsym :: { Located RdrName } tyvarsym :: { Located RdrName }
...@@ -1824,6 +1827,7 @@ varid :: { Located RdrName } ...@@ -1824,6 +1827,7 @@ varid :: { Located RdrName }
| special_id { L1 $! mkUnqual varName (unLoc $1) } | special_id { L1 $! mkUnqual varName (unLoc $1) }
| 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") } | 'unsafe' { L1 $! mkUnqual varName (fsLit "unsafe") }
| 'safe' { L1 $! mkUnqual varName (fsLit "safe") } | 'safe' { L1 $! mkUnqual varName (fsLit "safe") }
| 'interruptible' { L1 $! mkUnqual varName (fsLit "interruptible") }
| 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") } | 'threadsafe' { L1 $! mkUnqual varName (fsLit "threadsafe") }
| 'forall' { L1 $! mkUnqual varName (fsLit "forall") } | 'forall' { L1 $! mkUnqual varName (fsLit "forall") }
| 'family' { L1 $! mkUnqual varName (fsLit "family") } | 'family' { L1 $! mkUnqual varName (fsLit "family") }
...@@ -1850,7 +1854,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-' ...@@ -1850,7 +1854,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
-- These special_ids are treated as keywords in various places, -- These special_ids are treated as keywords in various places,
-- but as ordinary ids elsewhere. 'special_id' collects all these -- but as ordinary ids elsewhere. 'special_id' collects all these
-- except 'unsafe', 'forall', and 'family' whose treatment differs -- except 'unsafe', 'interruptible', 'forall', and 'family' whose treatment differs
-- depending on context -- depending on context
special_id :: { Located FastString } special_id :: { Located FastString }
special_id special_id
......
...@@ -14,7 +14,7 @@ ...@@ -14,7 +14,7 @@
module ForeignCall ( module ForeignCall (
ForeignCall(..), ForeignCall(..),
Safety(..), playSafe, Safety(..), playSafe, playInterruptible,
CExportSpec(..), CLabelString, isCLabelString, pprCLabelString, CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
CCallSpec(..), CCallSpec(..),
...@@ -63,6 +63,11 @@ data Safety ...@@ -63,6 +63,11 @@ data Safety
-- which is now an alias for "safe". This information -- which is now an alias for "safe". This information
-- is never used except to emit a deprecation warning. -- is never used except to emit a deprecation warning.
| PlayInterruptible -- Like PlaySafe, but additionally
-- the worker thread running this foreign call may
-- be unceremoniously killed, so it must be scheduled
-- on an unbound thread.
| PlayRisky -- None of the above can happen; the call will return | PlayRisky -- None of the above can happen; the call will return
-- without interacting with the runtime system at all -- without interacting with the runtime system at all
deriving ( Eq, Show, Data, Typeable ) deriving ( Eq, Show, Data, Typeable )
...@@ -72,11 +77,17 @@ data Safety ...@@ -72,11 +77,17 @@ data Safety
instance Outputable Safety where instance Outputable Safety where
ppr (PlaySafe False) = ptext (sLit "safe")