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.

8 files changed, 31 insertions, 15 deletions

diff --git a/compiler/cmm/Cmm.hs b/compiler/cmm/Cmm.hs
index 9c9f41051e..4ea7f00b6a 100644
--- 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
 
-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
diff --git a/compiler/cmm/CmmBuildInfoTables.hs b/compiler/cmm/CmmBuildInfoTables.hs
index 0e87c6cd84..0778e7c2d4 100644
--- 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
-        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
@@ -478,7 +478,7 @@ extendEnvsForSafeForeignCalls cafEnv slotEnv g =
                                     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
@@ -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
-  where tail (ZTail (MidForeignCall (Safe _ _) _ _ _) _) = True
+  where tail (ZTail (MidForeignCall (Safe _ _ _) _ _ _) _) = True
         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 (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 :
@@ -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)
-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
@@ -582,8 +582,9 @@ lowerSafeForeignCall state m@(MidForeignCall (Safe infotable _) _ _ _) tail = do
                   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)] <*>
diff --git a/compiler/cmm/CmmCPSGen.hs b/compiler/cmm/CmmCPSGen.hs
index a0baa51fa1..924ce9d4ab 100644
--- 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 ]
-		 [ 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,
diff --git a/compiler/cmm/CmmParse.y b/compiler/cmm/CmmParse.y
index ad388e582a..33a4b809d8 100644
--- 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
@@ -734,6 +736,7 @@ callishMachOps = listToUFM $
 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
@@ -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'"
+              CmmInterruptible ->
+                code (emitForeignCall' PlayInterruptible results 
+                   (CmmCallee expr' convention) args vols NoC_SRT ret)
 
 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'"
+		  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
diff --git a/compiler/cmm/CmmStackLayout.hs b/compiler/cmm/CmmStackLayout.hs
index 06204ef9c3..847019c07c 100644
--- 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
 
-      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
@@ -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])
-        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
diff --git a/compiler/cmm/MkZipCfgCmm.hs b/compiler/cmm/MkZipCfgCmm.hs
index 06830581ad..46f0659e1a 100644
--- 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
-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()
@@ -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
 
-mkSafeCall   t fs as upd =
+mkSafeCall   t fs as upd interruptible =
   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:
diff --git a/compiler/cmm/PprCmm.hs b/compiler/cmm/PprCmm.hs
index a9df2b9303..f5c5a49b92 100644
--- 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
+  ppr CmmInterruptible = ptext (sLit "_interruptible_call_")
 
 -- --------------------------------------------------------------------------
 -- Info tables. The current pretty printer needs refinement
diff --git a/compiler/cmm/ZipCfgCmmRep.hs b/compiler/cmm/ZipCfgCmmRep.hs
index b2328be890..aa16f0b198 100644
--- 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
+         Bool           -- is the call interruptible?
   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
-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