X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Fprelude%2FForeignCall.lhs;h=a92cabdec054a7d542d78a917790527a0624b34b;hp=63c902963ba78cbca5c39bb40d784658421d7b54;hb=83d563cb9ede0ba792836e529b1e2929db926355;hpb=f278f0676579f67075033a4f9857715909c4b71e

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 63c9029..a92cabd 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -14,7 +14,7 @@
 
 module ForeignCall (
 	ForeignCall(..),
-	Safety(..), playSafe,
+	Safety(..), playSafe, playInterruptible,
 
 	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.
 
+  | 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 )
@@ -72,11 +77,17 @@ data Safety
 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
+playSafe PlayInterruptible = True
 playSafe PlayRisky  = False
+
+playInterruptible :: Safety -> Bool
+playInterruptible PlayInterruptible = True
+playInterruptible _ = False
 \end{code}
 
 
@@ -233,13 +244,16 @@ instance Binary Safety where
     put_ bh (PlaySafe aa) = do
 	    putByte bh 0
 	    put_ bh aa
-    put_ bh PlayRisky = do
+    put_ bh PlayInterruptible = do
 	    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)
+	      1 -> do return PlayInterruptible
 	      _ -> do return PlayRisky
 
 instance Binary CExportSpec where