Deprecate the threadsafe kind of foreign import

diff --git a/compiler/parser/Lexer.x b/compiler/parser/Lexer.x
index b4d40ce..4d8e0f0 100644 (file)
--- a/compiler/parser/Lexer.x
+++ b/compiler/parser/Lexer.x
@@ -688,7 +688,7 @@ reservedWordsFM = listToUFM $
        ( "label",      ITlabel,         bit ffiBit),
        ( "dynamic",    ITdynamic,       bit ffiBit),
        ( "safe",       ITsafe,          bit ffiBit),
-       ( "threadsafe", ITthreadsafe,    bit ffiBit),
+       ( "threadsafe", ITthreadsafe,    bit ffiBit),  -- ToDo: remove
        ( "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 7465adb..47b049e 100644 (file)
--- a/compiler/parser/Parser.y.pp
+++ b/compiler/parser/Parser.y.pp
@@ -240,7 +240,7 @@ incorrect.
  'label'       { L _ ITlabel } 
  'dynamic'     { L _ ITdynamic }
  'safe'                { L _ ITsafe }
- 'threadsafe'  { L _ ITthreadsafe }
+ 'threadsafe'  { L _ ITthreadsafe }  -- ToDo: remove deprecated alias
  'unsafe'      { L _ ITunsafe }
  'mdo'         { L _ ITmdo }
  'family'      { L _ ITfamily }
@@ -957,7 +957,7 @@ callconv :: { CallConv }
 safety :: { Safety }
        : 'unsafe'                      { PlayRisky }
        | 'safe'                        { PlaySafe  False }
-       | 'threadsafe'                  { PlaySafe  True }
+       | 'threadsafe'                  { PlaySafe  True } -- deprecated alias
 
 fspec :: { Located (Located FastString, Located RdrName, LHsType RdrName) }
        : STRING var '::' sigtypedoc     { LL (L (getLoc $1) (getSTRING $1), $2, $4) }

diff --git a/compiler/prelude/ForeignCall.lhs b/compiler/prelude/ForeignCall.lhs
index 27f5b4f..cae46be 100644 (file)
--- a/compiler/prelude/ForeignCall.lhs
+++ b/compiler/prelude/ForeignCall.lhs
@@ -13,7 +13,7 @@
 
 module ForeignCall (
        ForeignCall(..),
-       Safety(..), playSafe, playThreadSafe,
+       Safety(..), playSafe,
 
        CExportSpec(..), CLabelString, isCLabelString, pprCLabelString,
        CCallSpec(..), 
@@ -57,11 +57,14 @@ instance Outputable ForeignCall where
 data Safety
   = PlaySafe           -- Might invoke Haskell GC, or do a call back, or
                        -- switch threads, etc.  So make sure things are
-                       -- tidy before the call
-       Bool            -- => True, external function is also re-entrant.
-                       --    [if supported, RTS arranges for the external call
-                       --    to be executed by a separate OS thread, i.e.,
-                       --    _concurrently_ to the execution of other Haskell threads.]
+                       -- tidy before the call. Additionally, in the threaded
+                       -- RTS we arrange for the external call to be executed
+                       -- by a separate OS thread, i.e., _concurrently_ to the
+                       -- execution of other Haskell threads.
+
+      Bool              -- Indicates the deprecated "threadsafe" annotation
+                        -- which is now an alias for "safe". This information
+                        -- is never used except to emit a deprecation warning.
 
   | PlayRisky          -- None of the above can happen; the call will return
                        -- without interacting with the runtime system at all
@@ -77,10 +80,6 @@ instance Outputable Safety where
 playSafe :: Safety -> Bool
 playSafe PlaySafe{} = True
 playSafe PlayRisky  = False
-
-playThreadSafe :: Safety -> Bool
-playThreadSafe (PlaySafe x) = x
-playThreadSafe _ = False
 \end{code}
 
 

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index aa40d02..35f627e 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -108,14 +108,15 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
        _ -> return ()
     return (DNImport (withDNTypes spec (map toDNType arg_tys) (toDNType res_ty)))
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ _ _ _ (CLabel _)) 
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport _ safety _ _ (CLabel _))
   = ASSERT( null arg_tys )
     do { checkCg checkCOrAsm
+       ; checkSafety safety
        ; check (isFFILabelTy res_ty) (illegalForeignTyErr empty sig_ty)
        ; return idecl }             -- NB check res_ty not sig_ty!
                                     --    In case sig_ty is (forall a. ForeignPtr a)
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ CWrapper) = do
        -- Foreign wrapper (former f.e.d.)
        -- The type must be of the form ft -> IO (FunPtr ft), where ft is a
        -- valid foreign type.  For legacy reasons ft -> IO (Ptr ft) as well
@@ -123,6 +124,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
        -- is DEPRECATED, though.
     checkCg checkCOrAsmOrInterp
     checkCConv cconv
+    checkSafety safety
     case arg_tys of
         [arg1_ty] -> do checkForeignArgs isFFIExternalTy arg1_tys
                         checkForeignRes nonIOok  isFFIExportResultTy res1_ty
@@ -137,6 +139,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t
   | isDynamicTarget target = do -- Foreign import dynamic
       checkCg checkCOrAsmOrInterp
       checkCConv cconv
+      checkSafety safety
       case arg_tys of           -- The first arg must be Ptr, FunPtr, or Addr
         []                -> do
           check False (illegalForeignTyErr empty sig_ty)
@@ -151,6 +154,7 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t
   | otherwise = do              -- Normal foreign import
       checkCg (checkCOrAsmOrDotNetOrInterp)
       checkCConv cconv
+      checkSafety safety
       checkCTarget target
       dflags <- getDOpts
       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
@@ -347,6 +351,14 @@ checkCConv StdCallConv = addErrTc (text "calling convention not supported on thi
 checkCConv CmmCallConv = panic "checkCConv CmmCallConv"
 \end{code}
 
+Deprecated "threadsafe" calls
+
+\begin{code}
+checkSafety :: Safety -> TcM ()
+checkSafety (PlaySafe True) = addWarn (text "The `threadsafe' foreign import style is deprecated. Use `safe' instead.")
+checkSafety _               = return ()
+\end{code}
+
 Warnings
 
 \begin{code}