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

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 4423d03..87bb94a 100644
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -10,10 +10,11 @@
 -- any warnings in the module. See
 --     http://hackage.haskell.org/trac/ghc/wiki/Commentary/CodingStyle#Warnings
 -- for details
+{-# LANGUAGE DeriveDataTypeable #-}
 
 module ForeignCall (
-	ForeignCall(..),
-	Safety(..), playSafe,
+        ForeignCall(..), isSafeForeignCall,
+	Safety(..), playSafe, playInterruptible,
 
 	CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
 	CCallSpec(..), 
@@ -27,6 +28,7 @@ import Outputable
 import Module
 
 import Data.Char
+import Data.Data
 \end{code}
 
 
@@ -41,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
@@ -61,20 +66,31 @@ 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 )
+  deriving ( Eq, Show, Data, Typeable )
 	-- Show used just for Show Lex.Token, I think
   {-! derive: Binary !-}
 
 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}
 
 
@@ -89,6 +105,7 @@ data CExportSpec
   = CExportStatic		-- foreign export ccall foo :: ty
 	CLabelString		-- C Name of exported function
 	CCallConv
+  deriving (Data, Typeable)
   {-! derive: Binary !-}
 
 data CCallSpec
@@ -121,7 +138,7 @@ data CCallTarget
   --	Used when importing a label as "foreign import ccall "dynamic" ..."
   | DynamicTarget
   
-  deriving( Eq )
+  deriving( Eq, Data, Typeable )
   {-! derive: Binary !-}
 
 isDynamicTarget :: CCallTarget -> Bool
@@ -146,7 +163,7 @@ See: http://www.programmersheaven.com/2/Calling-conventions
 
 \begin{code}
 data CCallConv = CCallConv | StdCallConv | CmmCallConv | PrimCallConv
-  deriving (Eq)
+  deriving (Eq, Data, Typeable)
   {-! derive: Binary !-}
 
 instance Outputable CCallConv where
@@ -230,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