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.

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 9c9f410..4ea7f00 100644 (file)
--- a/compiler/cmm/Cmm.hs
+++ b/compiler/cmm/Cmm.hs
@@ -254,7 +254,7 @@ type HintedCmmFormals = [HintedCmmFormal]
 type HintedCmmFormal  = CmmHinted CmmFormal
 type HintedCmmActual  = CmmHinted CmmActual
 
 type HintedCmmFormal  = CmmHinted CmmFormal
 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'
 instance UserOfLocalRegs CmmStmt where
 
 -- | enable us to fold used registers over 'CmmActuals' and 'CmmFormals'
 instance UserOfLocalRegs CmmStmt where

diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 0e87c6c..0778e7c 100644 (file)
--- a/compiler/cmm/CmmBuildInfoTables.hs
+++ b/compiler/cmm/CmmBuildInfoTables.hs
@@ -459,7 +459,7 @@ extendEnvWithSafeForeignCalls transfers env g = fold_blocks block env g
                  l = case last of LastOther l -> l
                                   LastExit -> panic "extendEnvs lastExit"
         tail _ z (ZFirst _) = z
                  l = case last of LastOther l -> l
                                   LastExit -> panic "extendEnvs lastExit"
         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 fact env (ZHead h m) = tail (mid m fact) env h
         lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k
           tail (mid m fact) (extendBlockEnv env bid fact) h
         tail fact env (ZHead h m) = tail (mid m fact) env h
         lookup map k = expectJust "extendEnvWithSafeFCalls" $ lookupBlockEnv map k

@@ -478,7 +478,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
                                     LastExit -> panic "extendEnvs lastExit"
           tail _ z (ZFirst _) = z
           tail lives@(cafs, slots) (cafEnv, slotEnv)
                                     LastExit -> panic "extendEnvs lastExit"
           tail _ z (ZFirst _) = z
           tail lives@(cafs, slots) (cafEnv, slotEnv)

-               (ZHead h m@(MidForeignCall (Safe bid _) _ _ _)) =
+               (ZHead h m@(MidForeignCall (Safe bid _ _) _ _ _)) =

             let slots'   = removeLiveSlotDefs slots m
                 slotEnv' = extendBlockEnv slotEnv bid slots'
                 cafEnv'  = extendBlockEnv cafEnv  bid cafs
             let slots'   = removeLiveSlotDefs slots m
                 slotEnv' = extendBlockEnv slotEnv bid slots'
                 cafEnv'  = extendBlockEnv cafEnv  bid cafs

@@ -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.
 hasSafeForeignCall :: CmmBlock -> Bool
 hasSafeForeignCall (Block _ t) = tail t
 -- Check for foreign calls -- if none, then we can avoid copying the block.
 hasSafeForeignCall :: CmmBlock -> Bool
 hasSafeForeignCall (Block _ t) = tail t

-  where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
+  where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True

         tail (ZTail _ t) = tail t
         tail (ZLast _)   = False
 
         tail (ZTail _ t) = tail t
         tail (ZLast _)   = False
 

@@ -554,7 +554,7 @@ lowerSafeCallBlock state b = tail (return state) (ZBlock head (ZLast last))
         tail s b@(ZBlock (ZFirst _) _) =
           do state <- s
              return $ state { s_blocks = insertBlock (G.zip b) (s_blocks state) }
         tail s b@(ZBlock (ZFirst _) _) =
           do state <- s
              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
              let state' = state
                    { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :
           do state <- s
              let state' = state
                    { s_safeCalls = FloatingInfoTable emptyContInfoTable bid updfr_off :

@@ -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.
 lowerSafeForeignCall ::
   SafeState -> Middle -> ZTail Middle Last -> FuelMonad (SafeState, ZTail Middle Last)
 -- to lower a safe foreign call to a sequence of unsafe calls.
 lowerSafeForeignCall ::
   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)
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection
     let newTemp rep = getUniqueM >>= \u -> return (LocalReg u rep)
     -- Both 'id' and 'new_base' are KindNonPtr because they're
     -- RTS-only objects and are not subject to garbage collection

@@ -582,8 +582,9 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
                   saveThreadState <*>
                   caller_save <*>
                   mkUnsafeCall (ForeignTarget suspendThread
                   saveThreadState <*>
                   caller_save <*>
                   mkUnsafeCall (ForeignTarget suspendThread

-                                  (ForeignConvention CCallConv [AddrHint] [AddrHint]))
-                    [id] [CmmReg (CmmGlobal BaseReg)]
+                                  (ForeignConvention CCallConv [AddrHint, NoHint] [AddrHint]))
+                    -- 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
                                   (ForeignConvention CCallConv [AddrHint] [AddrHint]))
                     [new_base] [CmmReg (CmmLocal id)] <*>
         resume = mkUnsafeCall (ForeignTarget resumeThread
                                   (ForeignConvention CCallConv [AddrHint] [AddrHint]))
                     [new_base] [CmmReg (CmmLocal id)] <*>

diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index a0baa51..924ce9d 100644 (file)
--- a/compiler/cmm/CmmCPSGen.hs
+++ b/compiler/cmm/CmmCPSGen.hs
@@ -232,7 +232,9 @@ foreignCall uniques call results arguments =
     caller_save ++
     [CmmCall (CmmCallee suspendThread CCallConv)
                 [ CmmHinted id AddrHint ]
     caller_save ++
     [CmmCall (CmmCallee suspendThread CCallConv)
                 [ 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
                  CmmMayReturn,
      CmmCall call results new_args CmmUnsafe CmmMayReturn,
                 CmmUnsafe
                  CmmMayReturn,
      CmmCall call results new_args CmmUnsafe CmmMayReturn,

diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ad388e5..33a4b80 100644 (file)
--- a/compiler/cmm/CmmParse.y
+++ b/compiler/cmm/CmmParse.y
@@ -8,6 +8,8 @@
 --
 -----------------------------------------------------------------------------
 
 --
 -----------------------------------------------------------------------------
 

+-- TODO: Add support for interruptible/uninterruptible foreign call specification
+

 {
 {-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
 -- The NoMonomorphismRestriction deals with a Happy infelicity
 {
 {-# OPTIONS -Wwarn -w -XNoMonomorphismRestriction #-}
 -- The NoMonomorphismRestriction deals with a Happy infelicity

@@ -734,6 +736,7 @@ callishMachOps = listToUFM $
 parseSafety :: String -> P CmmSafety
 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 parseSafety "unsafe" = return CmmUnsafe
 parseSafety :: String -> P CmmSafety
 parseSafety "safe"   = return (CmmSafe NoC_SRT)
 parseSafety "unsafe" = return CmmUnsafe

+parseSafety "interruptible" = return CmmInterruptible

 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint
 parseSafety str      = fail ("unrecognised safety: " ++ str)
 
 parseCmmHint :: String -> P ForeignHint

@@ -864,6 +867,9 @@ foreignCall conv_string results_code expr_code args_code vols safety ret
                 code (emitForeignCall' (PlaySafe unused) results 
                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
                unused = panic "not used by emitForeignCall'"
                 code (emitForeignCall' (PlaySafe unused) results 
                    (CmmCallee expr' convention) args vols NoC_SRT ret) where
                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
 #ifdef mingw32_TARGET_OS
 
 adjCallTarget :: CCallConv -> CmmExpr -> [CmmHinted CmmExpr] -> CmmExpr
 #ifdef mingw32_TARGET_OS

@@ -898,6 +904,9 @@ primCall results_code name args_code vols safety
                    code (emitForeignCall' (PlaySafe unused) results 
                      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
                    unused = panic "not used by emitForeignCall'"
                    code (emitForeignCall' (PlaySafe unused) results 
                      (CmmPrim p) args vols NoC_SRT CmmMayReturn) where
                    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 rep addr_code val_code
 
 doStore :: CmmType -> ExtFCode CmmExpr  -> ExtFCode CmmExpr -> ExtCode
 doStore rep addr_code val_code

diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 06204ef..847019c 100644 (file)
--- a/compiler/cmm/CmmStackLayout.hs
+++ b/compiler/cmm/CmmStackLayout.hs
@@ -358,7 +358,7 @@ layout procPoints env entry_off g =
         fold_succs (setSuccSPs inSp) l areaMap
         where inSp = expectJust "sp in" $ Map.lookup (CallArea (Young id)) areaMap
 
         fold_succs (setSuccSPs inSp) l 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
             area      = CallArea (Young bid)
             areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize
         let young     = youngest_live areaMap $ removeLiveSlotDefs (live_in t) m
             area      = CallArea (Young bid)
             areaSize' = Map.insert area (widthInBytes (typeWidth gcWord)) areaSize

@@ -422,7 +422,7 @@ manifestSP areaMap entry_off g@(LGraph entry _blocks) =
           where spIn = sp_on_entry id
         replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> 
                     FuelMonad ([CmmBlock])
           where spIn = sp_on_entry id
         replTail :: (ZTail Middle Last -> CmmBlock) -> Int -> (ZTail Middle Last) -> 
                     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
             where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
         replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t
           replTail (\t' -> h (setSp spOff spOff' (ZTail (middle spOff m) t'))) spOff' t
             where spOff' = slot' (Just bid) + widthInBytes (typeWidth gcWord)
         replTail h spOff (ZTail m t) = replTail (h . ZTail (middle spOff m)) spOff t

diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 0683058..46f0659 100644 (file)
--- a/compiler/cmm/MkZipCfgCmm.hs
+++ b/compiler/cmm/MkZipCfgCmm.hs
@@ -64,7 +64,7 @@ mkCall       :: CmmExpr -> (Convention, Convention) -> CmmFormals -> CmmActuals
 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                   UpdFrameOffset -> CmmAGraph
   -- Native C-- calling convention
 mkCmmCall    :: CmmExpr ->              CmmFormals -> CmmActuals ->
                   UpdFrameOffset -> CmmAGraph
   -- Native C-- calling convention

-mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> CmmAGraph
+mkSafeCall    :: MidCallTarget -> CmmFormals -> CmmActuals -> UpdFrameOffset -> Bool -> CmmAGraph

 mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
   -- Never returns; like exit() or barf()
 mkUnsafeCall  :: MidCallTarget -> CmmFormals -> CmmActuals -> CmmAGraph
 mkFinalCall   :: CmmExpr -> CCallConv -> CmmActuals -> UpdFrameOffset -> CmmAGraph
   -- 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
 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 mkSwitch e tbl            = mkLast $ LastSwitch e tbl
 
 mkCbranch pred ifso ifnot = mkLast (LastCondBranch pred ifso ifnot)
 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
 
 -- For debugging purposes, we can stub out dead stack slots:
 mkUnsafeCall t fs as = mkMiddle $ MidForeignCall Unsafe t fs as
 
 -- For debugging purposes, we can stub out dead stack slots:

diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index a9df2b9..f5c5a49 100644 (file)
--- a/compiler/cmm/PprCmm.hs
+++ b/compiler/cmm/PprCmm.hs
@@ -143,6 +143,7 @@ pprTop (CmmData section ds) =
 instance Outputable CmmSafety where
   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
   ppr (CmmSafe srt) = ppr srt
 instance Outputable CmmSafety where
   ppr CmmUnsafe = ptext (sLit "_unsafe_call_")
   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

diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index b2328be..aa16f0b 100644 (file)
--- a/compiler/cmm/ZipCfgCmmRep.hs
+++ b/compiler/cmm/ZipCfgCmmRep.hs
@@ -165,6 +165,7 @@ data ForeignSafety
   = Unsafe              -- unsafe call
   | Safe BlockId        -- making infotable requires: 1. label 
          UpdFrameOffset --                            2. where the upd frame is
   = Unsafe              -- unsafe call
   | Safe BlockId        -- making infotable requires: 1. label 
          UpdFrameOffset --                            2. where the upd frame is

+         Bool           -- is the call interruptible?

   deriving Eq
 
 data ValueDirection = Arguments | Results
   deriving Eq
 
 data ValueDirection = Arguments | Results

@@ -484,7 +485,9 @@ ppr_fc (ForeignConvention c args res) =
   doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
 
 ppr_safety :: ForeignSafety -> SDoc
   doubleQuotes (ppr c) <+> text "args: " <+> ppr args <+> text " results: " <+> ppr res
 
 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_call_target :: MidCallTarget -> SDoc
 ppr_safety Unsafe         = text "unsafe"
 
 ppr_call_target :: MidCallTarget -> SDoc

diff --git a/compiler/codeGen/CgForeignCall.hs b/compiler/codeGen/CgForeignCall.hs
index ce689c4..8e8e34d 100644 (file)
--- a/compiler/codeGen/CgForeignCall.hs
+++ b/compiler/codeGen/CgForeignCall.hs
@@ -144,7 +144,8 @@ emitForeignCall' safety results target args vols _srt ret
     -- to this sequence of three CmmUnsafe calls.
     stmtC (CmmCall (CmmCallee suspendThread CCallConv) 
                        [ CmmHinted id AddrHint ]
     -- to this sequence of three CmmUnsafe calls.
     stmtC (CmmCall (CmmCallee suspendThread CCallConv) 
                        [ CmmHinted id AddrHint ]

-                       [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint ] 
+                       [ CmmHinted (CmmReg (CmmGlobal BaseReg)) AddrHint
+                       , CmmHinted (CmmLit (CmmInt (fromIntegral (fromEnum (playInterruptible safety))) wordWidth)) NoHint]

                        CmmUnsafe ret)
     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
     stmtC (CmmCall (CmmCallee resumeThread CCallConv) 
                        CmmUnsafe ret)
     stmtC (CmmCall temp_target results temp_args CmmUnsafe ret)
     stmtC (CmmCall (CmmCallee resumeThread CCallConv) 

diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index b98da50..83c4301 100644 (file)
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -127,7 +127,7 @@ emitForeignCall safety results target args _srt _ret
   | otherwise = do
     updfr_off <- getUpdFrameOff
     temp_target <- load_target_into_temp target
   | otherwise = do
     updfr_off <- getUpdFrameOff
     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)

 
 
 {-
 
 
 {-

diff --git a/compiler/deSugar/DsMeta.hs b/compiler/deSugar/DsMeta.hs
index b24daea..b809795 100644 (file)
--- a/compiler/deSugar/DsMeta.hs
+++ b/compiler/deSugar/DsMeta.hs
@@ -349,6 +349,7 @@ repCCallConv callConv    = notHandled "repCCallConv" (ppr callConv)
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []
 
 repSafety :: Safety -> DsM (Core TH.Safety)
 repSafety PlayRisky = rep2 unsafeName []

+repSafety PlayInterruptible = rep2 interruptibleName []

 repSafety (PlaySafe False) = rep2 safeName []
 repSafety (PlaySafe True) = rep2 threadsafeName []
 
 repSafety (PlaySafe False) = rep2 safeName []
 repSafety (PlaySafe True) = rep2 threadsafeName []
 

@@ -1716,6 +1717,7 @@ templateHaskellNames = [
     unsafeName,
     safeName,
     threadsafeName,
     unsafeName,
     safeName,
     threadsafeName,

+    interruptibleName,

     -- InlineSpec
     inlineSpecNoPhaseName, inlineSpecPhaseName,
     -- FunDep
     -- InlineSpec
     inlineSpecNoPhaseName, inlineSpecPhaseName,
     -- FunDep

@@ -1959,10 +1961,11 @@ cCallName = libFun (fsLit "cCall") cCallIdKey
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
 
 -- data Safety = ...
 stdCallName = libFun (fsLit "stdCall") stdCallIdKey
 
 -- data Safety = ...

-unsafeName, safeName, threadsafeName :: Name
+unsafeName, safeName, threadsafeName, interruptibleName :: Name

 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey
 unsafeName     = libFun (fsLit "unsafe") unsafeIdKey
 safeName       = libFun (fsLit "safe") safeIdKey
 threadsafeName = libFun (fsLit "threadsafe") threadsafeIdKey

+interruptibleName = libFun (fsLit "interruptible") interruptibleIdKey

 
 -- data InlineSpec = ...
 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name
 
 -- data InlineSpec = ...
 inlineSpecNoPhaseName, inlineSpecPhaseName :: Name

@@ -2235,10 +2238,11 @@ cCallIdKey      = mkPreludeMiscIdUnique 300
 stdCallIdKey    = mkPreludeMiscIdUnique 301
 
 -- data Safety = ...
 stdCallIdKey    = mkPreludeMiscIdUnique 301
 
 -- data Safety = ...

-unsafeIdKey, safeIdKey, threadsafeIdKey :: Unique
+unsafeIdKey, safeIdKey, threadsafeIdKey, interruptibleIdKey :: Unique

 unsafeIdKey     = mkPreludeMiscIdUnique 305
 safeIdKey       = mkPreludeMiscIdUnique 306
 threadsafeIdKey = mkPreludeMiscIdUnique 307
 unsafeIdKey     = mkPreludeMiscIdUnique 305
 safeIdKey       = mkPreludeMiscIdUnique 306
 threadsafeIdKey = mkPreludeMiscIdUnique 307

+interruptibleIdKey = mkPreludeMiscIdUnique 308

 
 -- data InlineSpec =
 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique
 
 -- data InlineSpec =
 inlineSpecNoPhaseIdKey, inlineSpecPhaseIdKey :: Unique

diff --git a/compiler/ghci/ByteCodeAsm.lhs b/compiler/ghci/ByteCodeAsm.lhs
index 0fa7c62..6f6e51d 100644 (file)
--- a/compiler/ghci/ByteCodeAsm.lhs
+++ b/compiler/ghci/ByteCodeAsm.lhs
@@ -309,8 +309,8 @@ mkBits findLabel st proto_insns
                ENTER              -> instr1 st bci_ENTER
                RETURN             -> instr1 st bci_RETURN
                RETURN_UBX rep     -> instr1 st (return_ubx rep)
                ENTER              -> instr1 st bci_ENTER
                RETURN             -> instr1 st bci_RETURN
                RETURN_UBX rep     -> instr1 st (return_ubx rep)

-               CCALL off m_addr   -> do (np, st2) <- addr st m_addr
-                                        instr3 st2 bci_CCALL off np
+               CCALL off m_addr int -> do (np, st2) <- addr st m_addr
+                                          instr4 st2 bci_CCALL off np int

                BRK_FUN array index info -> do
                   (p1, st2) <- ptr st  (BCOPtrArray array)
                   (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)
                BRK_FUN array index info -> do
                   (p1, st2) <- ptr st  (BCOPtrArray array)
                   (p2, st3) <- ptr st2 (BCOPtrBreakInfo info)

@@ -478,7 +478,7 @@ instrSize16s instr
         ENTER{}                 -> 1
         RETURN{}                -> 1
         RETURN_UBX{}            -> 1
         ENTER{}                 -> 1
         RETURN{}                -> 1
         RETURN_UBX{}            -> 1

-        CCALL{}                 -> 3
+        CCALL{}                 -> 4

         SWIZZLE{}               -> 3
         BRK_FUN{}               -> 4
 
         SWIZZLE{}               -> 3
         BRK_FUN{}               -> 4
 

diff --git a/compiler/ghci/ByteCodeGen.lhs b/compiler/ghci/ByteCodeGen.lhs
index 7d6bc23..d654586 100644 (file)
--- a/compiler/ghci/ByteCodeGen.lhs
+++ b/compiler/ghci/ByteCodeGen.lhs
@@ -923,7 +923,7 @@ generateCCall :: Word16 -> Sequel           -- stack and sequel depths
               -> [AnnExpr' Id VarSet]  -- args (atoms)
               -> BcM BCInstrList
 
               -> [AnnExpr' Id VarSet]  -- args (atoms)
               -> 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 
          -- useful constants
          addr_sizeW :: Word16
    = let 
          -- useful constants
          addr_sizeW :: Word16

@@ -1092,7 +1092,8 @@ generateCCall d0 s p (CCallSpec target cconv _) fn args_r_to_l
      recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
      let
          -- do the call
      recordItblMallocBc (ItblPtr (castFunPtrToPtr addr_of_marshaller))
      let
          -- 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
          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
                         `snocOL` RETURN_UBX (primRepToCgRep r_rep)
          -- slide and return
          wrapup       = mkSLIDE r_sizeW (d_after_r - r_sizeW - s)
                         `snocOL` RETURN_UBX (primRepToCgRep r_rep)

diff --git a/compiler/ghci/ByteCodeInstr.lhs b/compiler/ghci/ByteCodeInstr.lhs
index b83006b..d44a00b 100644 (file)
--- a/compiler/ghci/ByteCodeInstr.lhs
+++ b/compiler/ghci/ByteCodeInstr.lhs
@@ -127,6 +127,9 @@ data BCInstr
    -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
    | CCALL            Word16    -- stack frame size
                       (Ptr ())  -- addr of the glue code
    -- For doing calls to C (via glue code generated by ByteCodeFFI, or libffi)
    | CCALL            Word16    -- stack frame size
                       (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
    | SWIZZLE          Word16 -- to the ptr N words down the stack,
 
    -- For doing magic ByteArray passing to foreign calls
    | SWIZZLE          Word16 -- to the ptr N words down the stack,

@@ -217,9 +220,12 @@ instance Outputable BCInstr where
    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
    ppr CASEFAIL              = text "CASEFAIL"
    ppr (JMP lab)             = text "JMP"      <+> ppr lab
    ppr (TESTEQ_P  i lab)     = text "TESTEQ_P" <+> ppr i <+> text "__" <> ppr lab
    ppr CASEFAIL              = text "CASEFAIL"
    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 (show marshall_addr)
                                                <+> text "marshall code at" 
                                                <+> text (show marshall_addr)

+                                               <+> (if int == 1
+                                                    then text "(interruptible)"
+                                                    else empty)

    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
                                                <+> text "by" <+> ppr n
    ppr ENTER                 = text "ENTER"
    ppr (SWIZZLE stkoff n)    = text "SWIZZLE " <+> text "stkoff" <+> ppr stkoff
                                                <+> text "by" <+> ppr n
    ppr ENTER                 = text "ENTER"

diff --git a/compiler/hsSyn/Convert.lhs b/compiler/hsSyn/Convert.lhs
index cc54b84..fc5f897 100644 (file)
--- a/compiler/hsSyn/Convert.lhs
+++ b/compiler/hsSyn/Convert.lhs
@@ -375,6 +375,7 @@ cvtForD (ImportF callconv safety from nm ty)
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe False
                      Threadsafe -> PlaySafe True
                      Unsafe     -> PlayRisky
                      Safe       -> PlaySafe False
                      Threadsafe -> PlaySafe True

+                     Interruptible -> PlayInterruptible

 
 cvtForD (ExportF callconv as nm ty)
   = do { nm' <- vNameL nm
 
 cvtForD (ExportF callconv as nm ty)
   = do { nm' <- vNameL nm

diff --git a/compiler/hsSyn/HsDecls.lhs b/compiler/hsSyn/HsDecls.lhs
index d49afec..fd6d3bb 100644 (file)
--- a/compiler/hsSyn/HsDecls.lhs
+++ b/compiler/hsSyn/HsDecls.lhs
@@ -897,7 +897,7 @@ data ForeignImport = -- import of a C entity
                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
                     --
                     CImport  CCallConv       -- ccall or stdcall
                     --  * `Safety' is irrelevant for `CLabel' and `CWrapper'
                     --
                     CImport  CCallConv       -- ccall or stdcall

-                             Safety          -- safe or unsafe
+                             Safety          -- interruptible, safe or unsafe

                              FastString      -- name of C header
                              CImportSpec     -- details of the C entity
   deriving (Data, Typeable)
                              FastString      -- name of C header
                              CImportSpec     -- details of the C entity
   deriving (Data, Typeable)

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index f31e623..eab9419 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -452,6 +452,7 @@ data Token
   | ITdynamic
   | ITsafe
   | ITthreadsafe
   | ITdynamic
   | ITsafe
   | ITthreadsafe

+  | ITinterruptible

   | ITunsafe
   | ITstdcallconv
   | ITccallconv
   | ITunsafe
   | ITstdcallconv
   | ITccallconv

@@ -596,6 +597,7 @@ isSpecial ITlabel           = True
 isSpecial ITdynamic    = True
 isSpecial ITsafe       = True
 isSpecial ITthreadsafe         = True
 isSpecial ITdynamic    = True
 isSpecial ITsafe       = True
 isSpecial ITthreadsafe         = True

+isSpecial ITinterruptible = True

 isSpecial ITunsafe     = True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True
 isSpecial ITunsafe     = True
 isSpecial ITccallconv   = True
 isSpecial ITstdcallconv = True

@@ -658,6 +660,7 @@ reservedWordsFM = listToUFM $
        ( "dynamic",    ITdynamic,       bit ffiBit),
        ( "safe",       ITsafe,          bit ffiBit),
        ( "threadsafe", ITthreadsafe,    bit ffiBit),  -- ToDo: remove
        ( "dynamic",    ITdynamic,       bit ffiBit),
        ( "safe",       ITsafe,          bit ffiBit),
        ( "threadsafe", ITthreadsafe,    bit ffiBit),  -- ToDo: remove

+       ( "interruptible", ITinterruptible, bit ffiBit),

        ( "unsafe",     ITunsafe,        bit ffiBit),
        ( "stdcall",    ITstdcallconv,   bit ffiBit),
        ( "ccall",      ITccallconv,     bit ffiBit),
        ( "unsafe",     ITunsafe,        bit ffiBit),
        ( "stdcall",    ITstdcallconv,   bit ffiBit),
        ( "ccall",      ITccallconv,     bit ffiBit),

diff --git a/compiler/parser/Parser.y.pp b/compiler/parser/Parser.y.pp
index 7ab7c44..a45ad87 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -248,6 +248,7 @@ incorrect.
  'dynamic'     { L _ ITdynamic }
  'safe'                { L _ ITsafe }
  'threadsafe'  { L _ ITthreadsafe }  -- ToDo: remove deprecated alias
  'dynamic'     { L _ ITdynamic }
  'safe'                { L _ ITsafe }
  'threadsafe'  { L _ ITthreadsafe }  -- ToDo: remove deprecated alias

+ 'interruptible' { L _ ITinterruptible }

  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'family'      { L _ ITfamily }
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'family'      { L _ ITfamily }

@@ -896,6 +897,7 @@ callconv :: { CCallConv }
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe  False }
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe  False }

+       | 'interruptible'               { PlayInterruptible }

        | 'threadsafe'                  { PlaySafe  True } -- deprecated alias
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        | 'threadsafe'                  { PlaySafe  True } -- deprecated alias
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }

@@ -1791,6 +1793,7 @@ tyvarid   :: { Located RdrName }
        | special_id            { L1 $! mkUnqual tvName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual tvName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual tvName (fsLit "safe") }
        | special_id            { L1 $! mkUnqual tvName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual tvName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual tvName (fsLit "safe") }

+       | 'interruptible'       { L1 $! mkUnqual tvName (fsLit "interruptible") }

        | 'threadsafe'          { L1 $! mkUnqual tvName (fsLit "threadsafe") }
 
 tyvarsym :: { Located RdrName }
        | 'threadsafe'          { L1 $! mkUnqual tvName (fsLit "threadsafe") }
 
 tyvarsym :: { Located RdrName }

@@ -1824,6 +1827,7 @@ varid :: { Located RdrName }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }
        | special_id            { L1 $! mkUnqual varName (unLoc $1) }
        | 'unsafe'              { L1 $! mkUnqual varName (fsLit "unsafe") }
        | 'safe'                { L1 $! mkUnqual varName (fsLit "safe") }

+       | 'interruptible'       { L1 $! mkUnqual varName (fsLit "interruptible") }

        | 'threadsafe'          { L1 $! mkUnqual varName (fsLit "threadsafe") }
        | 'forall'              { L1 $! mkUnqual varName (fsLit "forall") }
        | 'family'              { L1 $! mkUnqual varName (fsLit "family") }
        | 'threadsafe'          { L1 $! mkUnqual varName (fsLit "threadsafe") }
        | 'forall'              { L1 $! mkUnqual varName (fsLit "forall") }
        | 'family'              { L1 $! mkUnqual varName (fsLit "family") }

@@ -1850,7 +1854,7 @@ varsym_no_minus :: { Located RdrName } -- varsym not including '-'
 
 -- These special_ids are treated as keywords in various places, 
 -- but as ordinary ids elsewhere.   'special_id' collects all these
 
 -- These special_ids are treated as keywords in various places, 
 -- 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 
 special_id :: { Located FastString }
 special_id
 -- depending on context 
 special_id :: { Located FastString }
 special_id

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 63c9029..a92cabd 100644 (file)
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -14,7 +14,7 @@
 
 module ForeignCall (
        ForeignCall(..),
 
 module ForeignCall (
        ForeignCall(..),

-       Safety(..), playSafe,
+       Safety(..), playSafe, playInterruptible,

 
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
        CCallSpec(..), 
 
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
        CCallSpec(..), 

@@ -63,6 +63,11 @@ data Safety
                         -- which is now an alias for "safe". This information
                         -- is never used except to emit a deprecation warning.
 
                         -- which is now an alias for "safe". This information
                         -- 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
                        -- without interacting with the runtime system at all
   deriving ( Eq, Show, Data, Typeable )
   | PlayRisky          -- None of the above can happen; the call will return
                        -- without interacting with the runtime system at all
   deriving ( Eq, Show, Data, Typeable )

@@ -72,11 +77,17 @@ data Safety
 instance Outputable Safety where
   ppr (PlaySafe False) = ptext (sLit "safe")
   ppr (PlaySafe True)  = ptext (sLit "threadsafe")
 instance Outputable Safety where
   ppr (PlaySafe False) = ptext (sLit "safe")
   ppr (PlaySafe True)  = ptext (sLit "threadsafe")

+  ppr PlayInterruptible = ptext (sLit "interruptible")

   ppr PlayRisky = ptext (sLit "unsafe")
 
 playSafe :: Safety -> Bool
 playSafe PlaySafe{} = True
   ppr PlayRisky = ptext (sLit "unsafe")
 
 playSafe :: Safety -> Bool
 playSafe PlaySafe{} = True

+playSafe PlayInterruptible = True

 playSafe PlayRisky  = False
 playSafe PlayRisky  = False

+
+playInterruptible :: Safety -> Bool
+playInterruptible PlayInterruptible = True
+playInterruptible _ = False

 \end{code}
 
 
 \end{code}
 
 

@@ -233,13 +244,16 @@ instance Binary Safety where
     put_ bh (PlaySafe aa) = do
            putByte bh 0
            put_ bh aa
     put_ bh (PlaySafe aa) = do
            putByte bh 0
            put_ bh aa

-    put_ bh PlayRisky = do
+    put_ bh PlayInterruptible = do

            putByte bh 1
            putByte bh 1

+    put_ bh PlayRisky = do
+           putByte bh 2

     get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
                      return (PlaySafe aa)
     get bh = do
            h <- getByte bh
            case h of
              0 -> do aa <- get bh
                      return (PlaySafe aa)

+             1 -> do return PlayInterruptible

              _ -> do return PlayRisky
 
 instance Binary CExportSpec where
              _ -> do return PlayRisky
 
 instance Binary CExportSpec where

diff --git a/docs/users_guide/ffi-chap.xml b/docs/users_guide/ffi-chap.xml
index 5ef50a6..b33e95a 100644 (file)
--- a/docs/users_guide/ffi-chap.xml
+++ b/docs/users_guide/ffi-chap.xml
@@ -476,6 +476,15 @@ int main(int argc, char *argv[])
           threads, but there may be an arbitrary number of foreign
           calls in progress at any one time, regardless of
           the <literal>+RTS -N</literal> value.</para>
           threads, but there may be an arbitrary number of foreign
           calls in progress at any one time, regardless of
           the <literal>+RTS -N</literal> value.</para>

+
+        <para>If a call is annotated as <literal>interruptible</literal>
+          and the program was multithreaded, the call may be
+          interrupted in the event that the Haskell thread receives an
+          exception.  The mechanism by which the interrupt occurs
+          is platform dependent, but is intended to cause blocking
+          system calls to return immediately with an interrupted error
+          code.  The underlying operating system thread is not to be
+          destroyed.</para>

       </sect3>
 
       <sect3 id="haskell-threads-and-os-threads">
       </sect3>
 
       <sect3 id="haskell-threads-and-os-threads">

diff --git a/includes/rts/Constants.h b/includes/rts/Constants.h
index 354abbb..140aaa4 100644 (file)
--- a/includes/rts/Constants.h
+++ b/includes/rts/Constants.h
@@ -223,8 +223,8 @@
 #define BlockedOnGA_NoSend  9
 /* Only relevant for THREADED_RTS: */
 #define BlockedOnCCall      10
 #define BlockedOnGA_NoSend  9
 /* Only relevant for THREADED_RTS: */
 #define BlockedOnCCall      10

-#define BlockedOnCCall_NoUnblockExc 11
-   /* same as above but don't unblock async exceptions in resumeThread() */
+#define BlockedOnCCall_Interruptible 11
+   /* same as above but permit killing the worker thread */

 
 /* Involved in a message sent to tso->msg_cap */
 #define BlockedOnMsgThrowTo 12
 
 /* Involved in a message sent to tso->msg_cap */
 #define BlockedOnMsgThrowTo 12

diff --git a/includes/rts/OSThreads.h b/includes/rts/OSThreads.h
index 106e1e7..5d3e6ba 100644 (file)
--- a/includes/rts/OSThreads.h
+++ b/includes/rts/OSThreads.h
@@ -165,6 +165,7 @@ typedef void OSThreadProcAttr OSThreadProc(void *);
 extern int  createOSThread        ( OSThreadId* tid, 
                                    OSThreadProc *startProc, void *param);
 extern rtsBool osThreadIsAlive    ( OSThreadId id );
 extern int  createOSThread        ( OSThreadId* tid, 
                                    OSThreadProc *startProc, void *param);
 extern rtsBool osThreadIsAlive    ( OSThreadId id );

+extern void interruptOSThread (OSThreadId id);

 
 //
 // Condition Variables
 
 //
 // Condition Variables

diff --git a/includes/rts/Threads.h b/includes/rts/Threads.h
index ca3e8b2..c974142 100644 (file)
--- a/includes/rts/Threads.h
+++ b/includes/rts/Threads.h
@@ -31,7 +31,7 @@ StgTSO *createStrictIOThread  (Capability *cap, nat stack_size,
                               StgClosure *closure);
 
 // Suspending/resuming threads around foreign calls
                               StgClosure *closure);
 
 // Suspending/resuming threads around foreign calls

-void *        suspendThread (StgRegTable *);
+void *        suspendThread (StgRegTable *, rtsBool interruptible);

 StgRegTable * resumeThread  (void *);
 
 //
 StgRegTable * resumeThread  (void *);
 
 //

diff --git a/rts/Interpreter.c b/rts/Interpreter.c
index 9a38a7e..da7ee21 100644 (file)
--- a/rts/Interpreter.c
+++ b/rts/Interpreter.c
@@ -1356,6 +1356,7 @@ run_BCO:
            void *tok;
            int stk_offset            = BCO_NEXT;
            int o_itbl                = BCO_NEXT;
            void *tok;
            int stk_offset            = BCO_NEXT;
            int o_itbl                = BCO_NEXT;

+           int interruptible         = BCO_NEXT;

            void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
            int ret_dyn_size = 
                RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE
            void(*marshall_fn)(void*) = (void (*)(void*))BCO_LIT(o_itbl);
            int ret_dyn_size = 
                RET_DYN_BITMAP_SIZE + RET_DYN_NONPTR_REGS_SIZE

@@ -1444,7 +1445,7 @@ run_BCO:
             ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
 
            SAVE_STACK_POINTERS;
             ((StgRetDyn *)Sp)->payload[0] = (StgClosure *)obj;
 
            SAVE_STACK_POINTERS;

-           tok = suspendThread(&cap->r);
+           tok = suspendThread(&cap->r, interruptible ? rtsTrue : rtsFalse);

 
            // We already made a copy of the arguments above.
             ffi_call(cif, fn, ret, argptrs);
 
            // We already made a copy of the arguments above.
             ffi_call(cif, fn, ret, argptrs);

diff --git a/rts/RaiseAsync.c b/rts/RaiseAsync.c
index ad830cf..b94ccea 100644 (file)
--- a/rts/RaiseAsync.c
+++ b/rts/RaiseAsync.c
@@ -127,7 +127,7 @@ suspendComputation(Capability *cap, StgTSO *tso, StgUpdateFrame *stop_here)
    Capability, and it is
 
      - NotBlocked, BlockedOnMsgThrowTo,
    Capability, and it is
 
      - NotBlocked, BlockedOnMsgThrowTo,

-       BlockedOnCCall
+       BlockedOnCCall_Interruptible

 
      - or it is masking exceptions (TSO_BLOCKEX)
 
 
      - or it is masking exceptions (TSO_BLOCKEX)
 

@@ -392,8 +392,29 @@ check_target:
            return THROWTO_SUCCESS;
        }
 
            return THROWTO_SUCCESS;
        }
 

+    case BlockedOnCCall_Interruptible:
+#ifdef THREADED_RTS
+    {
+        Task *task = NULL;
+        // walk suspended_ccalls to find the correct worker thread
+        InCall *incall;
+        for (incall = cap->suspended_ccalls; incall != NULL; incall = incall->next) {
+            if (incall->suspended_tso == target) {
+                task = incall->task;
+                break;
+            }
+        }
+        if (task != NULL) {
+            raiseAsync(cap, target, msg->exception, rtsFalse, NULL);
+            interruptWorkerTask(task);
+            return THROWTO_SUCCESS;
+        } else {
+            debugTraceCap(DEBUG_sched, cap, "throwTo: could not find worker thread to kill");
+        }
+        // fall to next
+    }
+#endif

     case BlockedOnCCall:
     case BlockedOnCCall:

-    case BlockedOnCCall_NoUnblockExc:

        blockedThrowTo(cap,target,msg);
        return THROWTO_BLOCKED;
 
        blockedThrowTo(cap,target,msg);
        return THROWTO_BLOCKED;
 

diff --git a/rts/Schedule.c b/rts/Schedule.c
index 8db125d..0850749 100644 (file)
--- a/rts/Schedule.c
+++ b/rts/Schedule.c
@@ -1716,13 +1716,17 @@ recoverSuspendedTask (Capability *cap, Task *task)
  * the whole system.
  *
  * The Haskell thread making the C call is put to sleep for the
  * the whole system.
  *
  * The Haskell thread making the C call is put to sleep for the

- * duration of the call, on the susepended_ccalling_threads queue.  We
+ * duration of the call, on the suspended_ccalling_threads queue.  We

  * give out a token to the task, which it can use to resume the thread
  * on return from the C function.
  * give out a token to the task, which it can use to resume the thread
  * on return from the C function.

+ *
+ * If this is an interruptible C call, this means that the FFI call may be
+ * unceremoniously terminated and should be scheduled on an
+ * unbound worker thread.

  * ------------------------------------------------------------------------- */
    
 void *
  * ------------------------------------------------------------------------- */
    
 void *

-suspendThread (StgRegTable *reg)
+suspendThread (StgRegTable *reg, rtsBool interruptible)

 {
   Capability *cap;
   int saved_errno;
 {
   Capability *cap;
   int saved_errno;

@@ -1751,12 +1755,10 @@ suspendThread (StgRegTable *reg)
 
   threadPaused(cap,tso);
 
 
   threadPaused(cap,tso);
 

-  if ((tso->flags & TSO_BLOCKEX) == 0)  {
-      tso->why_blocked = BlockedOnCCall;
-      tso->flags |= TSO_BLOCKEX;
-      tso->flags &= ~TSO_INTERRUPTIBLE;
+  if (interruptible) {
+    tso->why_blocked = BlockedOnCCall_Interruptible;

   } else {
   } else {

-      tso->why_blocked = BlockedOnCCall_NoUnblockExc;
+    tso->why_blocked = BlockedOnCCall;

   }
 
   // Hand back capability
   }
 
   // Hand back capability

@@ -1815,12 +1817,11 @@ resumeThread (void *task_)
 
     traceEventRunThread(cap, tso);
     
 
     traceEventRunThread(cap, tso);
     

-    if (tso->why_blocked == BlockedOnCCall) {
+    if ((tso->flags & TSO_BLOCKEX) == 0) {

         // avoid locking the TSO if we don't have to
         if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
             awakenBlockedExceptionQueue(cap,tso);
         }
         // avoid locking the TSO if we don't have to
         if (tso->blocked_exceptions != END_BLOCKED_EXCEPTIONS_QUEUE) {
             awakenBlockedExceptionQueue(cap,tso);
         }

-       tso->flags &= ~(TSO_BLOCKEX | TSO_INTERRUPTIBLE);

     }
     
     /* Reset blocking status */
     }
     
     /* Reset blocking status */

@@ -2331,7 +2332,7 @@ deleteThread (Capability *cap STG_UNUSED, StgTSO *tso)
     // we must own all Capabilities.
 
     if (tso->why_blocked != BlockedOnCCall &&
     // we must own all Capabilities.
 
     if (tso->why_blocked != BlockedOnCCall &&

-       tso->why_blocked != BlockedOnCCall_NoUnblockExc) {
+       tso->why_blocked != BlockedOnCCall_Interruptible) {

        throwToSingleThreaded(tso->cap,tso,NULL);
     }
 }
        throwToSingleThreaded(tso->cap,tso,NULL);
     }
 }

@@ -2343,7 +2344,7 @@ deleteThread_(Capability *cap, StgTSO *tso)
   // like deleteThread(), but we delete threads in foreign calls, too.
 
     if (tso->why_blocked == BlockedOnCCall ||
   // like deleteThread(), but we delete threads in foreign calls, too.
 
     if (tso->why_blocked == BlockedOnCCall ||

-       tso->why_blocked == BlockedOnCCall_NoUnblockExc) {
+       tso->why_blocked == BlockedOnCCall_Interruptible) {

        tso->what_next = ThreadKilled;
        appendToRunQueue(tso->cap, tso);
     } else {
        tso->what_next = ThreadKilled;
        appendToRunQueue(tso->cap, tso);
     } else {

diff --git a/rts/Task.c b/rts/Task.c
index e93d60d..f26785a 100644 (file)
--- a/rts/Task.c
+++ b/rts/Task.c
@@ -409,6 +409,15 @@ startWorkerTask (Capability *cap)
   RELEASE_LOCK(&task->lock);
 }
 
   RELEASE_LOCK(&task->lock);
 }
 

+void
+interruptWorkerTask (Task *task)
+{
+  ASSERT(osThreadId() != task->id);    // seppuku not allowed
+  ASSERT(task->incall->suspended_tso); // use this only for FFI calls
+  interruptOSThread(task->id);
+  debugTrace(DEBUG_sched, "interrupted worker task %lu", task->id);
+}
+

 #endif /* THREADED_RTS */
 
 #ifdef DEBUG
 #endif /* THREADED_RTS */
 
 #ifdef DEBUG

diff --git a/rts/Task.h b/rts/Task.h
index 566c042..38e4763 100644 (file)
--- a/rts/Task.h
+++ b/rts/Task.h
@@ -225,6 +225,11 @@ INLINE_HEADER Task *myTask (void);
 //
 void startWorkerTask (Capability *cap);
 
 //
 void startWorkerTask (Capability *cap);
 

+// Interrupts a worker task that is performing an FFI call.  The thread
+// should not be destroyed.
+//
+void interruptWorkerTask (Task *task);
+

 #endif /* THREADED_RTS */
 
 // -----------------------------------------------------------------------------
 #endif /* THREADED_RTS */
 
 // -----------------------------------------------------------------------------

diff --git a/rts/Threads.c b/rts/Threads.c
index 6635ed5..7344134 100644 (file)
--- a/rts/Threads.c
+++ b/rts/Threads.c
@@ -492,8 +492,8 @@ printThreadBlockage(StgTSO *tso)
   case BlockedOnCCall:
     debugBelch("is blocked on an external call");
     break;
   case BlockedOnCCall:
     debugBelch("is blocked on an external call");
     break;

-  case BlockedOnCCall_NoUnblockExc:
-    debugBelch("is blocked on an external call (exceptions were already blocked)");
+  case BlockedOnCCall_Interruptible:
+    debugBelch("is blocked on an external call (but may be interrupted)");

     break;
   case BlockedOnSTM:
     debugBelch("is blocked on an STM operation");
     break;
   case BlockedOnSTM:
     debugBelch("is blocked on an STM operation");

diff --git a/rts/posix/OSThreads.c b/rts/posix/OSThreads.c
index 343536e..2831553 100644 (file)
--- a/rts/posix/OSThreads.c
+++ b/rts/posix/OSThreads.c
@@ -57,6 +57,10 @@
 #include <mach/mach.h>
 #endif
 
 #include <mach/mach.h>
 #endif
 

+#ifdef HAVE_SIGNAL_H
+# include <signal.h>
+#endif
+

 /*
  * This (allegedly) OS threads independent layer was initially
  * abstracted away from code that used Pthreads, so the functions
 /*
  * This (allegedly) OS threads independent layer was initially
  * abstracted away from code that used Pthreads, so the functions

@@ -290,6 +294,12 @@ setThreadAffinity (nat n GNUC3_ATTRIBUTE(__unused__),
 }
 #endif
 
 }
 #endif
 

+void
+interruptOSThread (OSThreadId id)
+{
+    pthread_kill(id, SIGPIPE);
+}
+

 #else /* !defined(THREADED_RTS) */
 
 int
 #else /* !defined(THREADED_RTS) */
 
 int

diff --git a/rts/sm/MarkWeak.c b/rts/sm/MarkWeak.c
index e65c176..d4d708e 100644 (file)
--- a/rts/sm/MarkWeak.c
+++ b/rts/sm/MarkWeak.c
@@ -270,8 +270,10 @@ static rtsBool tidyThreadList (generation *gen)
         
         // if the thread is not masking exceptions but there are
         // pending exceptions on its queue, then something has gone
         
         // if the thread is not masking exceptions but there are
         // pending exceptions on its queue, then something has gone

-        // wrong:
+        // wrong.  However, pending exceptions are OK if there is an
+        // uninterruptible FFI call.

         ASSERT(t->blocked_exceptions == END_BLOCKED_EXCEPTIONS_QUEUE
         ASSERT(t->blocked_exceptions == END_BLOCKED_EXCEPTIONS_QUEUE

+               || t->why_blocked == BlockedOnCCall

                || (t->flags & TSO_BLOCKEX));
         
         if (tmp == NULL) {
                || (t->flags & TSO_BLOCKEX));
         
         if (tmp == NULL) {

diff --git a/rts/win32/OSThreads.c b/rts/win32/OSThreads.c
index cb00bd6..44db42f 100644 (file)
--- a/rts/win32/OSThreads.c
+++ b/rts/win32/OSThreads.c
@@ -269,6 +269,25 @@ setThreadAffinity (nat n, nat m) // cap N of M
     }
 }
 
     }
 }
 

+typedef BOOL (WINAPI *PCSIO)(HANDLE);
+
+void
+interruptOSThread (OSThreadId id)
+{
+    HANDLE hdl;
+    PCSIO pCSIO;
+    if (!(hdl = OpenThread(THREAD_TERMINATE,FALSE,id))) {
+        sysErrorBelch("interruptOSThread: OpenThread");
+        stg_exit(EXIT_FAILURE);
+    }
+    pCSIO = (PCSIO) GetProcAddress(GetModuleHandle(TEXT("Kernel32.dll")), "CancelSynchronousIo");
+    if ( NULL != pCSIO ) {
+        pCSIO(hdl);
+    } else {
+        // Nothing to do, unfortunately
+    }
+}
+

 #else /* !defined(THREADED_RTS) */
 
 int
 #else /* !defined(THREADED_RTS) */
 
 int