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

7 files changed, 73 insertions, 0 deletions

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', '')], ''])