X-Git-Url: http://git.megacz.com/?p=ghc-hetmet.git;a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=35f627e48d37aa597a053fd977b4a7c006ba3fa2;hp=aa40d02cd2b1524a5e0179ed768e5df78e284338;hb=5cb496dc86fac0b6023c08d4a0d7467df8d7b540;hpb=2016964946f0bff4753295bd4918f98cc1195a7c

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index aa40d02..35f627e 100644
--- 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}