The Big INLINE Patch: totally reorganise way that INLINE pragmas work

[ghc-hetmet.git] / compiler / typecheck / TcForeign.lhs

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index aa40d02..83f719b 100644 (file)
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -35,7 +35,6 @@ import Type
 import SMRep
 #endif
 import Name
-import OccName
 import TcType
 import DynFlags
 import Outputable
@@ -92,30 +91,16 @@ tcFImport d = pprPanic "tcFImport" (ppr d)
 ------------ Checking types for foreign import ----------------------
 \begin{code}
 tcCheckFIType :: Type -> [Type] -> Type -> ForeignImport -> TcM ForeignImport
-tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
-    checkCg checkDotnet
-    dflags <- getDOpts
-    checkForeignArgs (isFFIDotnetTy dflags) arg_tys
-    checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
-    let (DNCallSpec isStatic kind _ _ _ _) = spec
-    case kind of
-       DNMethod | not isStatic ->
-         case arg_tys of
-          [] -> addErrTc illegalDNMethodSig
-          _  
-           | not (isFFIDotnetObjTy (last arg_tys)) -> addErrTc illegalDNMethodSig
-           | otherwise -> return ()
-       _ -> 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
+    do { checkCg checkCOrAsmOrInterp
+       ; 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 +108,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
@@ -133,10 +119,11 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv _ _ _ CWrapper) = do
         _ -> addErrTc (illegalForeignTyErr empty sig_ty)
     return idecl
 
-tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction target))
+tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ (CFunction target))
   | 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)
@@ -148,9 +135,22 @@ tcCheckFIType sig_ty arg_tys res_ty idecl@(CImport cconv safety _ _ (CFunction t
           checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
           checkForeignRes nonIOok (isFFIImportResultTy dflags) res_ty
           return idecl
+  | cconv == PrimCallConv = do
+      dflags <- getDOpts
+      check (dopt Opt_GHCForeignImportPrim dflags)
+            (text "Use -XGHCForeignImportPrim to allow `foreign import prim'.")
+      checkCg (checkCOrAsmOrDotNetOrInterp)
+      checkCTarget target
+      check (playSafe safety)
+            (text "The safe/unsafe annotation should not be used with `foreign import prim'.")
+      checkForeignArgs (isFFIPrimArgumentTy dflags) arg_tys
+      -- prim import result is more liberal, allows (#,,#)
+      checkForeignRes nonIOok (isFFIPrimResultTy dflags) res_ty
+      return idecl
   | otherwise = do              -- Normal foreign import
       checkCg (checkCOrAsmOrDotNetOrInterp)
       checkCConv cconv
+      checkSafety safety
       checkCTarget target
       dflags <- getDOpts
       checkForeignArgs (isFFIArgumentTy dflags safety) arg_tys
@@ -235,7 +235,7 @@ tcFExport fo@(ForeignExport (L loc nm) hs_ty spec) =
    -- is *stable* (i.e. the compiler won't change it later),
    -- because this name will be referred to by the C code stub.
    id  <- mkStableIdFromName nm sig_ty loc mkForeignExportOcc
-   return (L loc (VarBind id rhs), ForeignExport (L loc id) undefined spec)
+   return (mkVarBind id rhs, ForeignExport (L loc id) undefined spec)
 tcFExport d = pprPanic "tcFExport" (ppr d)
 \end{code}
 
@@ -244,6 +244,7 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
 \begin{code}
 tcCheckFEType :: Type -> ForeignExport -> TcM ()
 tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
+    checkCg checkCOrAsm
     check (isCLabelString str) (badCName str)
     checkCConv cconv
     checkForeignArgs isFFIExternalTy arg_tys
@@ -253,7 +254,6 @@ tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
       -- the structure of the foreign type.
     (_, t_ty) = tcSplitForAllTys sig_ty
     (arg_tys, res_ty) = tcSplitFunTys t_ty
-tcCheckFEType _ d = pprPanic "tcCheckFEType" (ppr d)
 \end{code}
 
 
@@ -294,14 +294,6 @@ checkForeignRes non_io_result_ok pred_res_ty ty
 \end{code}
 
 \begin{code}
-checkDotnet :: HscTarget -> Maybe SDoc
-#if defined(mingw32_TARGET_OS)
-checkDotnet HscC   = Nothing
-checkDotnet _      = Just (text "requires C code generation (-fvia-C)")
-#else
-checkDotnet _      = Just (text "requires .NET support (-filx or win32)")
-#endif
-
 checkCOrAsm :: HscTarget -> Maybe SDoc
 checkCOrAsm HscC   = Nothing
 checkCOrAsm HscAsm = Nothing
@@ -344,9 +336,18 @@ checkCConv StdCallConv = return ()
 #else
 checkCConv StdCallConv = addErrTc (text "calling convention not supported on this platform: stdcall")
 #endif
+checkCConv PrimCallConv = addErrTc (text "The `prim' calling convention can only be used with `foreign import'")
 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}
@@ -373,10 +374,5 @@ foreignDeclCtxt :: ForeignDecl Name -> SDoc
 foreignDeclCtxt fo
   = hang (ptext (sLit "When checking declaration:"))
          4 (ppr fo)
-
-illegalDNMethodSig :: SDoc
-illegalDNMethodSig
-  = ptext (sLit "'This pointer' expected as last argument")
-
 \end{code}