Ensure that Any is Boxed in FFI imports/exports

We should only accept the type `Any` in foreign import/export
declarations when it has type `Type` or `UnliftedType`.
This patch adds a kind check, and a special error message triggered by
occurrences of `Any` in foreign import/export declarations at other
kinds.

Fixes #21305

10 files changed, 120 insertions, 11 deletions

diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 95afe9c982..5778050413 100644
--- a/compiler/GHC/Tc/Errors/Ppr.hs
+++ b/compiler/GHC/Tc/Errors/Ppr.hs
@@ -782,6 +782,9 @@ instance Diagnostic TcRnMessage where
                   innerMsg $$ text "A foreign-imported address (via &foo) must have type (Ptr a) or (FunPtr a)"
                 NotSimpleUnliftedType ->
                   innerMsg $$ text "foreign import prim only accepts simple unlifted types"
+                NotBoxedKindAny ->
+                  text "Expected kind" <+> quotes (text "Type") <+> text "or" <+> quotes (text "UnliftedType") <> comma $$
+                  text "but" <+> quotes (ppr ty) <+> text "has kind" <+> quotes (ppr (typeKind ty))
             ForeignDynNotPtr expected ty ->
               vcat [ text "Expected: Ptr/FunPtr" <+> pprParendType expected <> comma, text "  Actual:" <+> ppr ty ]
             SafeHaskellMustBeInIO ->
diff --git a/compiler/GHC/Tc/Utils/TcType.hs b/compiler/GHC/Tc/Utils/TcType.hs
index ee687b68f7..57f2dcd358 100644
--- a/compiler/GHC/Tc/Utils/TcType.hs
+++ b/compiler/GHC/Tc/Utils/TcType.hs
@@ -2024,7 +2024,7 @@ isFloatTy, isDoubleTy,
     isFloatPrimTy, isDoublePrimTy,
     isIntegerTy, isNaturalTy,
     isIntTy, isWordTy, isBoolTy,
-    isUnitTy, isCharTy, isAnyTy :: Type -> Bool
+    isUnitTy, isCharTy :: Type -> Bool
 isFloatTy      = is_tc floatTyConKey
 isDoubleTy     = is_tc doubleTyConKey
 isFloatPrimTy  = is_tc floatPrimTyConKey
@@ -2036,7 +2036,16 @@ isWordTy       = is_tc wordTyConKey
 isBoolTy       = is_tc boolTyConKey
 isUnitTy       = is_tc unitTyConKey
 isCharTy       = is_tc charTyConKey
-isAnyTy        = is_tc anyTyConKey
+
+-- | Check whether the type is of the form @Any :: k@,
+-- returning the kind @k@.
+anyTy_maybe :: Type -> Maybe Kind
+anyTy_maybe ty
+  | Just (tc, [k]) <- splitTyConApp_maybe ty
+  , getUnique tc == anyTyConKey
+  = Just k
+  | otherwise
+  = Nothing
 
 -- | Is the type inhabited by machine floating-point numbers?
 --
@@ -2166,6 +2175,7 @@ data TypeCannotBeMarshaledReason
   | NotABoxedMarshalableTyCon
   | ForeignLabelNotAPtr
   | NotSimpleUnliftedType
+  | NotBoxedKindAny
 
 isFFIArgumentTy :: DynFlags -> Safety -> Type -> Validity' IllegalForeignTypeReason
 -- Checks for valid argument type for a 'foreign import'
@@ -2208,22 +2218,44 @@ isFFILabelTy ty = checkRepTyCon ok ty
           | otherwise
           = NotValid ForeignLabelNotAPtr
 
+-- | Check validity for a type of the form @Any :: k@.
+--
+-- This function returns:
+--
+--  - @Just IsValid@ for @Any :: Type@ and @Any :: UnliftedType@,
+--  - @Just (NotValid ..)@ for @Any :: k@ if @k@ is not a kind of boxed types,
+--  - @Nothing@ if the type is not @Any@.
+checkAnyTy :: Type -> Maybe (Validity' IllegalForeignTypeReason)
+checkAnyTy  ty
+  | Just ki <- anyTy_maybe ty
+  = Just $
+      if isBoxedTypeKind ki
+      then IsValid
+      -- NB: don't allow things like @Any :: TYPE IntRep@, as per #21305.
+      else NotValid (TypeCannotBeMarshaled ty NotBoxedKindAny)
+  | otherwise
+  = Nothing
+
 isFFIPrimArgumentTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
 -- Checks for valid argument type for a 'foreign import prim'
--- Currently they must all be simple unlifted types, or the well-known type
--- Any, which can be used to pass the address to a Haskell object on the heap to
+-- Currently they must all be simple unlifted types, or Any (at kind Type or UnliftedType),
+-- which can be used to pass the address to a Haskell object on the heap to
 -- the foreign function.
 isFFIPrimArgumentTy dflags ty
-  | isAnyTy ty = IsValid
-  | otherwise  = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
+  | Just validity <- checkAnyTy ty
+  = validity
+  | otherwise
+  = checkRepTyCon (legalFIPrimArgTyCon dflags) ty
 
 isFFIPrimResultTy :: DynFlags -> Type -> Validity' IllegalForeignTypeReason
 -- Checks for valid result type for a 'foreign import prim' Currently
 -- it must be an unlifted type, including unboxed tuples, unboxed
--- sums, or the well-known type Any.
+-- sums, or the well-known type Any (at kind Type or UnliftedType).
 isFFIPrimResultTy dflags ty
-  | isAnyTy ty = IsValid
-  | otherwise = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
+  | Just validity <- checkAnyTy ty
+  = validity
+  | otherwise
+  = checkRepTyCon (legalFIPrimResultTyCon dflags) ty
 
 isFunPtrTy :: Type -> Bool
 isFunPtrTy ty
diff --git a/docs/users_guide/exts/ffi.rst b/docs/users_guide/exts/ffi.rst
index 22f8f33280..eed9f5a348 100644
--- a/docs/users_guide/exts/ffi.rst
+++ b/docs/users_guide/exts/ffi.rst
@@ -295,9 +295,10 @@ calling convention ``prim``, e.g.: ::
 
 This is used to import functions written in Cmm code that follow an
 internal GHC calling convention. The arguments and results must be
-unboxed types, except that an argument may be of type ``Any`` (by way of
+unboxed types, except that an argument may be of type ``Any :: Type``
+or ``Any :: UnliftedType`` (which can be arranged by way of
 ``unsafeCoerce#``) and the result type is allowed to be an unboxed tuple
-or the type ``Any``.
+or the types ``Any :: Type`` or ``Any :: UnliftedType``.
 
 This feature is not intended for use outside of the core libraries that
 come with GHC. For more details see the
diff --git a/testsuite/tests/ffi/should_fail/T21305_fail.hs b/testsuite/tests/ffi/should_fail/T21305_fail.hs
new file mode 100644
index 0000000000..c6f8d6863a
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/T21305_fail.hs
@@ -0,0 +1,7 @@
+{-# LANGUAGE DataKinds, GHCForeignImportPrim #-}
+
+module T21305_fail where
+
+import GHC.Exts
+
+foreign import prim "f" f :: Any @(TYPE IntRep) -> Any
diff --git a/testsuite/tests/ffi/should_fail/T21305_fail.stderr b/testsuite/tests/ffi/should_fail/T21305_fail.stderr
new file mode 100644
index 0000000000..d2ed006df8
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/T21305_fail.stderr
@@ -0,0 +1,7 @@
+
+T21305_fail.hs:7:1: error:
+    • Unacceptable argument type in foreign declaration:
+        Expected kind ‘Type’ or ‘UnliftedType’,
+        but ‘Any’ has kind ‘TYPE 'IntRep’
+    • When checking declaration:
+        foreign import prim safe "f" f :: Any @(TYPE IntRep) -> Any
diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T
index 24210dcca6..9080282782 100644
--- a/testsuite/tests/ffi/should_fail/all.T
+++ b/testsuite/tests/ffi/should_fail/all.T
@@ -17,6 +17,7 @@ test('T7243', normal, compile_fail, [''])
 test('T10461', normal, compile_fail, [''])
 test('T16702', normal, compile_fail, [''])
 test('T20116', normal, compile_fail, [''])
+test('T21305_fail', normal, compile_fail, [''])
 
 # UnsafeReenter tests implementation of an undefined behavior (calling Haskell
 # from an unsafe foreign function) and only makes sense in non-threaded way
diff --git a/testsuite/tests/ffi/should_run/T21305.hs b/testsuite/tests/ffi/should_run/T21305.hs
new file mode 100644
index 0000000000..a362fd1c37
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T21305.hs
@@ -0,0 +1,48 @@
+{-# LANGUAGE DataKinds, MagicHash, GHCForeignImportPrim, UnliftedFFITypes, UnboxedTuples #-}
+
+module Main where
+-- Here we ensure that foreign imports with boxed Any-typed
+-- arguments and results work as expected. To test the
+-- lifted case we pass Int64s; to test the unlifted case
+-- we pass a ByteArray#.
+import Data.Kind
+import GHC.Exts
+import GHC.Int
+import GHC.IO
+import Unsafe.Coerce
+
+foreign import prim "f" f :: Any @(TYPE LiftedRep)
+                          -> Any @Type
+                          -> Any @(TYPE UnliftedRep)
+                          -> (# Any :: Type, Any :: TYPE LiftedRep, Any :: UnliftedType #)
+main :: IO ()
+main = IO $ \ s1 ->
+  case newByteArray# 24# s1 of
+  { (# s2, mba #) ->
+  case writeByteArray# mba 0# [300, 4000, 50000] s2 of
+  { s3 ->
+  let
+    (# b', a', c' #) =
+        (f (unsafeCoerce (9 :: Int64))
+           (unsafeCoerce (80 :: Int64))
+           (unsafeCoerceUnlifted mba))
+    a, b :: Int64
+    a = unsafeCoerce a'
+    b = unsafeCoerce b'
+    c :: MutableByteArray# RealWorld
+    c = unsafeCoerceUnlifted c'
+  in
+  case readInt64Array# c 0# s3 of
+  { (# s4, e1 #) ->
+  case readInt64Array# c 1# s4 of
+  { (# s5, e2 #) ->
+    unIO (print [a, b, I64# e1, I64# e2]) s5 }}}}
+
+writeByteArray# :: MutableByteArray# RealWorld
+                -> Int#
+                -> [Int64]
+                -> State# RealWorld -> State# RealWorld
+writeByteArray# _   _   []          s = s
+writeByteArray# mba off (I64# i:is) s =
+  case writeInt64Array# mba off i s of
+    s' -> writeByteArray# mba (off +# 8#) is s'
diff --git a/testsuite/tests/ffi/should_run/T21305.stdout b/testsuite/tests/ffi/should_run/T21305.stdout
new file mode 100644
index 0000000000..5573a3f6e2
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T21305.stdout
@@ -0,0 +1 @@
+[9,80,300,770000]
diff --git a/testsuite/tests/ffi/should_run/T21305_cmm.cmm b/testsuite/tests/ffi/should_run/T21305_cmm.cmm
new file mode 100644
index 0000000000..f198af746a
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T21305_cmm.cmm
@@ -0,0 +1,6 @@
+#include "Cmm.h"
+
+f(P_ a, P_ b, P_ c) {
+  I64[c + SIZEOF_StgArrBytes + 8] = 770000;
+  return (b, a, c);
+}
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index 14c5b34af7..5402de20c7 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -224,3 +224,6 @@ test('IncallAffinity',
      ['IncallAffinity_c.c -no-hs-main'])
 
 test('T19237', normal, compile_and_run, ['T19237_c.c'])
+
+test('T21305', omit_ways(['ghci']), multi_compile_and_run,
+                 ['T21305', [('T21305_cmm.cmm', '')], ''])