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

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 63c9029..87bb94a 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,8 +13,8 @@
 {-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (
-	ForeignCall(..),
-	Safety(..), playSafe,
+        ForeignCall(..), isSafeForeignCall,
+	Safety(..), playSafe, playInterruptible,
 
 	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
 	CCallSpec(..), 
@@ -43,6 +43,9 @@ newtype ForeignCall = CCall CCallSpec
   deriving Eq
   {-! derive: Binary !-}
 
+isSafeForeignCall :: ForeignCall -> Bool
+isSafeForeignCall (CCall (CCallSpec _ _ safe)) = playSafe safe
+
 -- We may need more clues to distinguish foreign calls
 -- but this simple printer will do for now
 instance Outputable ForeignCall where
@@ -63,6 +66,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 +80,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 +247,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