X-Git-Url: http://git.megacz.com/?a=blobdiff_plain;f=compiler%2Ftypecheck%2FTcForeign.lhs;h=f51000d72ac2150370530ee166fcc3ae88e9a4a6;hb=8897e76874e10daa4dc695342e68b15e114a6de0;hp=e62133705eda01cafd1a373c160e64f199e923ea;hpb=ae987852c75d1f77b11370f299e265c68c16196f;p=ghc-hetmet.git

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index e621337..f51000d 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -33,7 +33,6 @@ import Id
 #if alpha_TARGET_ARCH
 import Type
 import SMRep
-import MachOp
 #endif
 import Name
 import OccName
@@ -70,22 +69,22 @@ tcForeignImports decls
 
 tcFImport :: ForeignDecl Name -> TcM (Id, ForeignDecl Id)
 tcFImport fo@(ForeignImport (L loc nm) hs_ty imp_decl)
- = addErrCtxt (foreignDeclCtxt fo)  $ do
-   sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
-   let 
-      -- drop the foralls before inspecting the structure
-      -- of the foreign type.
-	(_, t_ty)	  = tcSplitForAllTys sig_ty
-	(arg_tys, res_ty) = tcSplitFunTys t_ty
-	id		  = mkLocalId nm sig_ty
+ = addErrCtxt (foreignDeclCtxt fo)  $ 
+   do { sig_ty <- tcHsSigType (ForSigCtxt nm) hs_ty
+      ; let 
+          -- Drop the foralls before inspecting the
+          -- structure of the foreign type.
+	    (_, t_ty)	      = tcSplitForAllTys sig_ty
+	    (arg_tys, res_ty) = tcSplitFunTys t_ty
+	    id  	      = mkLocalId nm sig_ty
  		-- Use a LocalId to obey the invariant that locally-defined 
 		-- things are LocalIds.  However, it does not need zonking,
 		-- (so TcHsSyn.zonkForeignExports ignores it).
    
-   imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
-   -- can't use sig_ty here because it :: Type and we need HsType Id
-   -- hence the undefined
-   return (id, ForeignImport (L loc id) undefined imp_decl')
+      ; imp_decl' <- tcCheckFIType sig_ty arg_tys res_ty imp_decl
+         -- Can't use sig_ty here because sig_ty :: Type and 
+	 -- we need HsType Id hence the undefined
+      ; return (id, ForeignImport (L loc id) undefined imp_decl') }
 tcFImport d = pprPanic "tcFImport" (ppr d)
 \end{code}
 
@@ -97,7 +96,7 @@ tcCheckFIType _ arg_tys res_ty (DNImport spec) = do
     checkCg checkDotnet
     dflags <- getDOpts
     checkForeignArgs (isFFIDotnetTy dflags) arg_tys
-    checkForeignRes True{-non IO ok-} (isFFIDotnetTy dflags) res_ty
+    checkForeignRes nonIOok (isFFIDotnetTy dflags) res_ty
     let (DNCallSpec isStatic kind _ _ _ _) = spec
     case kind of
        DNMethod | not isStatic ->
@@ -109,12 +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 _ _ idecl@(CImport _ _ _ _ (CLabel _)) = do
-    checkCg checkCOrAsm
-    check (isFFILabelTy sig_ty) (illegalForeignTyErr empty sig_ty)
-    return idecl
+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
@@ -122,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
@@ -132,10 +135,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)
@@ -147,9 +151,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
@@ -189,7 +206,7 @@ checkFEDArgs :: [Type] -> TcM ()
 checkFEDArgs arg_tys
   = check (integral_args <= 32) err
   where
-    integral_args = sum [ (machRepByteWidth . argMachRep . primRepToCgRep) prim_rep
+    integral_args = sum [ (widthInBytes . argMachRep . primRepToCgRep) prim_rep
 			| prim_rep <- map typePrimRep arg_tys,
 			  primRepHint prim_rep /= FloatHint ]
     err = ptext (sLit "On Alpha, I can only handle 32 bytes of non-floating-point arguments to foreign export dynamic")
@@ -242,8 +259,9 @@ tcFExport d = pprPanic "tcFExport" (ppr d)
 
 \begin{code}
 tcCheckFEType :: Type -> ForeignExport -> TcM ()
-tcCheckFEType sig_ty (CExport (CExportStatic str _)) = do
+tcCheckFEType sig_ty (CExport (CExportStatic str cconv)) = do
     check (isCLabelString str) (badCName str)
+    checkCConv cconv
     checkForeignArgs isFFIExternalTy arg_tys
     checkForeignRes nonIOok isFFIExportResultTy res_ty
   where
@@ -340,11 +358,20 @@ checkCConv CCallConv  = return ()
 #if i386_TARGET_ARCH
 checkCConv StdCallConv = return ()
 #else
-checkCConv StdCallConv = addErrTc (text "calling convention not supported on this architecture: stdcall")
+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}