diff --git a/compiler/GHC/Tc/Errors/Ppr.hs b/compiler/GHC/Tc/Errors/Ppr.hs
index 95afe9c98269477672feaa4564d6cdf9313763e3..57780504135cbe1252bbd783f5f30d0dc420f2f7 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 ee687b68f7349f264c66d0b71fb7463c50478269..57f2dcd358f4a7a46e232f778121ce8c9149b9da 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 22f8f33280b3919375d8966c66500639afbbf416..eed9f5a34812a9e80e7820b8c15d8d48cde890d6 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 0000000000000000000000000000000000000000..c6f8d6863a5525b902ca7fae1bf9eaf9426b8e57
--- /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 0000000000000000000000000000000000000000..d2ed006df8f083766bd32a580a652069713df5d4
--- /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 24210dcca6b4708588a9fdb3e4bce9411e9e3424..9080282782d4c2f2f1441a7336cfc9404c87e8de 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 0000000000000000000000000000000000000000..a362fd1c371882e5fc70f7fd8aee7a770b61e0e1
--- /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 0000000000000000000000000000000000000000..5573a3f6e29d7121dc4b298db67e45abe9754847
--- /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 0000000000000000000000000000000000000000..f198af746a97639bb8cef2ba9c1695892c4f53d4
--- /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 14c5b34af71e7ae5107d25a8ef0b6e7beae762e9..5402de20c703ef63c49194d29a54744761e9deb9 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', '')], ''])