From 2da37f4f15790377900fa6c38ff8fdcd394dfaa2 Mon Sep 17 00:00:00 2001
From: Duncan Coutts <duncan@well-typed.com>
Date: Tue, 9 Jun 2009 10:48:26 +0000
Subject: [PATCH] Typechecking for "foreign import prim" The main restriction
 is that all args and results must be unboxed types. In
 particular we allow unboxed tuple results (which is a
 primary motivation for the whole feature). The normal rules
 apply about "void rep" result types like State#. We only
 allow "prim" calling convention for import, not export. The
 other forms of import, "dynamic", "wrapper" and data label
 are banned as a conseqence of checking that the imported
 name is a valid C string. We currently require prim imports
 to be marked unsafe, though this is essentially arbitrary
 as the safety information is unused.

---
 compiler/typecheck/TcForeign.lhs |   11 +++++++++++
 compiler/typecheck/TcType.lhs    |   34 ++++++++++++++++++++++++++++++++++
 2 files changed, 45 insertions(+)

diff --git a/compiler/typecheck/TcForeign.lhs b/compiler/typecheck/TcForeign.lhs
index 35f627e..23756d9 100644
--- a/compiler/typecheck/TcForeign.lhs
+++ b/compiler/typecheck/TcForeign.lhs
@@ -151,6 +151,16 @@ 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
+      checkCg (checkCOrAsmOrDotNetOrInterp)
+      checkCTarget target
+      check (safety == PlayRisky)
+            (text "A `foreign import prim' must always be annotated as `unsafe'")
+      dflags <- getDOpts
+      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
@@ -348,6 +358,7 @@ 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}
 
diff --git a/compiler/typecheck/TcType.lhs b/compiler/typecheck/TcType.lhs
index 738f1cd..f50b9b0 100644
--- a/compiler/typecheck/TcType.lhs
+++ b/compiler/typecheck/TcType.lhs
@@ -84,6 +84,8 @@ module TcType (
   isFFIExternalTy,     -- :: Type -> Bool
   isFFIDynArgumentTy,  -- :: Type -> Bool
   isFFIDynResultTy,    -- :: Type -> Bool
+  isFFIPrimArgumentTy, -- :: DynFlags -> Type -> Bool
+  isFFIPrimResultTy,   -- :: DynFlags -> Type -> Bool
   isFFILabelTy,        -- :: Type -> Bool
   isFFIDotnetTy,       -- :: DynFlags -> Type -> Bool
   isFFIDotnetObjTy,    -- :: Type -> Bool
@@ -1228,6 +1230,18 @@ isFFILabelTy :: Type -> Bool
 -- or a newtype of either.
 isFFILabelTy = checkRepTyConKey [ptrTyConKey, funPtrTyConKey]
 
+isFFIPrimArgumentTy :: DynFlags -> Type -> Bool
+-- Checks for valid argument type for a 'foreign import prim'
+-- Currently they must all be simple unlifted types.
+isFFIPrimArgumentTy dflags ty
+   = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
+
+isFFIPrimResultTy :: DynFlags -> Type -> Bool
+-- Checks for valid result type for a 'foreign import prim'
+-- Currently it must be an unlifted type, including unboxed tuples.
+isFFIPrimResultTy dflags ty
+   = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
+
 isFFIDotnetTy :: DynFlags -> Type -> Bool
 isFFIDotnetTy dflags ty
   = checkRepTyCon (\ tc -> (legalFIResultTyCon dflags tc || 
@@ -1353,6 +1367,26 @@ boxedMarshalableTyCon tc
 			 , stablePtrTyConKey
 			 , boolTyConKey
 			 ]
+
+legalFIPrimArgTyCon :: DynFlags -> TyCon -> Bool
+-- Check args of 'foreign import prim', only allow simple unlifted types.
+-- Strictly speaking it is unnecessary to ban unboxed tuples here since
+-- currently they're of the wrong kind to use in function args anyway.
+legalFIPrimArgTyCon dflags tc
+  = dopt Opt_UnliftedFFITypes dflags
+    && isUnLiftedTyCon tc
+    && not (isUnboxedTupleTyCon tc)
+
+legalFIPrimResultTyCon :: DynFlags -> TyCon -> Bool
+-- Check result type of 'foreign import prim'. Allow simple unlifted
+-- types and also unboxed tuple result types '... -> (# , , #)'
+legalFIPrimResultTyCon dflags tc
+  = dopt Opt_UnliftedFFITypes dflags
+    && isUnLiftedTyCon tc
+    && (isUnboxedTupleTyCon tc
+        || case tyConPrimRep tc of	-- Note [Marshalling VoidRep]
+	   VoidRep -> False
+	   _       -> True)
 \end{code}
 
 Note [Marshalling VoidRep]
-- 
1.7.10.4