Use a better strategy for determining the offset applied to foreign function arguments that have an unlifted boxed type. We used to use the type of the argument. We now use the type of the foreign function. Add a test to confirm that the roundtrip conversion between an unlifted boxed type and Any is sound in the presence of a foreign function call.

23 files changed, 443 insertions, 45 deletions

diff --git a/compiler/codeGen/StgCmmExpr.hs b/compiler/codeGen/StgCmmExpr.hs
index 70a044a7ab..b49cee39c2 100644
--- a/compiler/codeGen/StgCmmExpr.hs
+++ b/compiler/codeGen/StgCmmExpr.hs
@@ -577,7 +577,7 @@ isSimpleScrut _                _           = return False
 
 isSimpleOp :: StgOp -> [StgArg] -> FCode Bool
 -- True iff the op cannot block or allocate
-isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _) _ = return $! not (playSafe safe)
+isSimpleOp (StgFCallOp (CCall (CCallSpec _ _ safe)) _ _) _ = return $! not (playSafe safe)
 -- dataToTag# evalautes its argument, see Note [dataToTag#] in primops.txt.pp
 isSimpleOp (StgPrimOp DataToTagOp) _ = return False
 isSimpleOp (StgPrimOp op) stg_args                  = do
diff --git a/compiler/codeGen/StgCmmForeign.hs b/compiler/codeGen/StgCmmForeign.hs
index c1103e7d77..45e5733fc1 100644
--- a/compiler/codeGen/StgCmmForeign.hs
+++ b/compiler/codeGen/StgCmmForeign.hs
@@ -34,7 +34,6 @@ import CmmUtils
 import MkGraph
 import Type
 import RepType
-import TysPrim
 import CLabel
 import SMRep
 import ForeignCall
@@ -44,20 +43,26 @@ import Outputable
 import UniqSupply
 import BasicTypes
 
+import TyCoRep
+import TysPrim
+import Util (zipEqual)
+
 import Control.Monad
 
 -----------------------------------------------------------------------------
 -- Code generation for Foreign Calls
 -----------------------------------------------------------------------------
 
--- | emit code for a foreign call, and return the results to the sequel.
---
+-- | Emit code for a foreign call, and return the results to the sequel.
+-- Precondition: the length of the arguments list is the same as the
+-- arity of the foreign function.
 cgForeignCall :: ForeignCall            -- the op
+              -> Type                   -- type of foreign function
               -> [StgArg]               -- x,y    arguments
               -> Type                   -- result type
               -> FCode ReturnKind
 
-cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
+cgForeignCall (CCall (CCallSpec target cconv safety)) typ stg_args res_ty
   = do  { dflags <- getDynFlags
         ; let -- in the stdcall calling convention, the symbol needs @size appended
               -- to it, where size is the total number of bytes of arguments.  We
@@ -70,7 +75,7 @@ cgForeignCall (CCall (CCallSpec target cconv safety)) stg_args res_ty
               -- ToDo: this might not be correct for 64-bit API
             arg_size (arg, _) = max (widthInBytes $ typeWidth $ cmmExprType dflags arg)
                                      (wORD_SIZE dflags)
-        ; cmm_args <- getFCallArgs stg_args
+        ; cmm_args <- getFCallArgs stg_args typ
         ; (res_regs, res_hints) <- newUnboxedTupleRegs res_ty
         ; let ((call_args, arg_hints), cmm_target)
                 = case target of
@@ -492,43 +497,128 @@ stack_SP     dflags = closureField dflags (oFFSET_StgStack_sp dflags)
 closureField :: DynFlags -> ByteOff -> ByteOff
 closureField dflags off = off + fixedHdrSize dflags
 
--- -----------------------------------------------------------------------------
+-- Note [Unlifted boxed arguments to foreign calls]
+-- ~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~~
+--
 -- For certain types passed to foreign calls, we adjust the actual
--- value passed to the call.  For ByteArray#/Array# we pass the
--- address of the actual array, not the address of the heap object.
-
-getFCallArgs :: [StgArg] -> FCode [(CmmExpr, ForeignHint)]
+-- value passed to the call.  For ByteArray#, Array#, SmallArray#,
+-- and ArrayArray#, we pass the address of the array's payload, not
+-- the address of the heap object. For example, consider
+--   foreign import "c_foo" foo :: ByteArray# -> Int# -> IO ()
+-- At a Haskell call like `foo x y`, we'll generate a C call that
+-- is more like
+--   c_foo( x+8, y )
+-- where the "+8" takes the heap pointer (x :: ByteArray#) and moves
+-- it past the header words of the ByteArray object to point directly
+-- to the data inside the ByteArray#. (The exact offset depends
+-- on the target architecture and on profiling) By contrast, (y :: Int#)
+-- requires no such adjustment.
+--
+-- This adjustment is performed by 'add_shim'. The size of the
+-- adjustment depends on the type of heap object. But
+-- how can we determine that type? There are two available options.
+-- We could use the types of the actual values that the foreign call
+-- has been applied to, or we could use the types present in the
+-- foreign function's type. Prior to GHC 8.10, we used the former
+-- strategy since it's a little more simple. However, in issue #16650
+-- and more compellingly in the comments of
+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939, it was
+-- demonstrated that this leads to bad behavior in the presence
+-- of unsafeCoerce#. Returning to the above example, suppose the
+-- Haskell call looked like
+--   foo (unsafeCoerce# p) 
+-- where the types of expressions comprising the arguments are
+--   p :: (Any :: TYPE 'UnliftedRep)
+--   i :: Int#
+-- so that the unsafe-coerce is between Any and ByteArray#.
+-- These two types have the same kind (they are both represented by
+-- a heap pointer) so no GC errors will occur if we do this unsafe coerce.
+-- By the time this gets to the code generator the cast has been
+-- discarded so we have
+--   foo p y
+-- But we *must* adjust the pointer to p by a ByteArray# shim,
+-- *not* by an Any shim (the Any shim involves no offset at all).
+--
+-- To avoid this bad behavior, we adopt the second strategy: use
+-- the types present in the foreign function's type.
+-- In collectStgFArgTypes, we convert the foreign function's
+-- type to a list of StgFArgType. Then, in add_shim, we interpret
+-- these as numeric offsets.
+
+getFCallArgs ::
+     [StgArg]
+  -> Type -- the type of the foreign function
+  -> FCode [(CmmExpr, ForeignHint)]
 -- (a) Drop void args
 -- (b) Add foreign-call shim code
 -- It's (b) that makes this differ from getNonVoidArgAmodes
-
-getFCallArgs args
-  = do  { mb_cmms <- mapM get args
+-- Precondition: args and typs have the same length
+-- See Note [Unlifted boxed arguments to foreign calls]
+getFCallArgs args typ
+  = do  { mb_cmms <- mapM get (zipEqual "getFCallArgs" args (collectStgFArgTypes typ))
         ; return (catMaybes mb_cmms) }
   where
-    get arg | null arg_reps
-            = return Nothing
-            | otherwise
-            = do { cmm <- getArgAmode (NonVoid arg)
-                 ; dflags <- getDynFlags
-                 ; return (Just (add_shim dflags arg_ty cmm, hint)) }
-            where
-              arg_ty   = stgArgType arg
-              arg_reps = typePrimRep arg_ty
-              hint     = typeForeignHint arg_ty
-
-add_shim :: DynFlags -> Type -> CmmExpr -> CmmExpr
-add_shim dflags arg_ty expr
-  | tycon == arrayPrimTyCon || tycon == mutableArrayPrimTyCon
-  = cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
-
-  | tycon == smallArrayPrimTyCon || tycon == smallMutableArrayPrimTyCon
-  = cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
-
-  | tycon == byteArrayPrimTyCon || tycon == mutableByteArrayPrimTyCon
-  = cmmOffsetB dflags expr (arrWordsHdrSize dflags)
-
-  | otherwise = expr
+    get (arg,typ)
+      | null arg_reps
+      = return Nothing
+      | otherwise
+      = do { cmm <- getArgAmode (NonVoid arg)
+           ; dflags <- getDynFlags
+           ; return (Just (add_shim dflags typ cmm, hint)) }
+      where
+        arg_ty   = stgArgType arg
+        arg_reps = typePrimRep arg_ty
+        hint     = typeForeignHint arg_ty
+
+-- The minimum amount of information needed to determine
+-- the offset to apply to an argument to a foreign call.
+-- See Note [Unlifted boxed arguments to foreign calls]
+data StgFArgType
+  = StgPlainType
+  | StgArrayType
+  | StgSmallArrayType
+  | StgByteArrayType
+
+-- See Note [Unlifted boxed arguments to foreign calls]
+add_shim :: DynFlags -> StgFArgType -> CmmExpr -> CmmExpr
+add_shim dflags ty expr = case ty of
+  StgPlainType -> expr
+  StgArrayType -> cmmOffsetB dflags expr (arrPtrsHdrSize dflags)
+  StgSmallArrayType -> cmmOffsetB dflags expr (smallArrPtrsHdrSize dflags)
+  StgByteArrayType -> cmmOffsetB dflags expr (arrWordsHdrSize dflags)
+
+-- From a function, extract information needed to determine
+-- the offset of each argument when used as a C FFI argument.
+-- See Note [Unlifted boxed arguments to foreign calls]
+collectStgFArgTypes :: Type -> [StgFArgType]
+collectStgFArgTypes = go [] 
+  where
+    -- Skip foralls
+    go bs (ForAllTy _ res) = go bs res
+    go bs (AppTy{}) = reverse bs
+    go bs (TyConApp{}) = reverse bs
+    go bs (LitTy{}) = reverse bs
+    go bs (TyVarTy{}) = reverse bs
+    go  _ (CastTy{}) = panic "myCollectTypeArgs: CastTy"
+    go  _ (CoercionTy{}) = panic "myCollectTypeArgs: CoercionTy"
+    go bs (FunTy {ft_arg = arg, ft_res=res}) =
+      go (typeToStgFArgType arg:bs) res
+
+-- Choose the offset based on the type. For anything other
+-- than an unlifted boxed type, there is no offset.
+-- See Note [Unlifted boxed arguments to foreign calls]
+typeToStgFArgType :: Type -> StgFArgType
+typeToStgFArgType typ
+  | tycon == arrayPrimTyCon = StgArrayType
+  | tycon == mutableArrayPrimTyCon = StgArrayType
+  | tycon == arrayArrayPrimTyCon = StgArrayType
+  | tycon == mutableArrayArrayPrimTyCon = StgArrayType
+  | tycon == smallArrayPrimTyCon = StgSmallArrayType
+  | tycon == smallMutableArrayPrimTyCon = StgSmallArrayType
+  | tycon == byteArrayPrimTyCon = StgByteArrayType
+  | tycon == mutableByteArrayPrimTyCon = StgByteArrayType
+  | otherwise = StgPlainType
   where
-    tycon           = tyConAppTyCon (unwrapType arg_ty)
-        -- should be a tycon app, since this is a foreign call
+  -- should be a tycon app, since this is a foreign call
+  tycon = tyConAppTyCon (unwrapType typ)
+
diff --git a/compiler/codeGen/StgCmmPrim.hs b/compiler/codeGen/StgCmmPrim.hs
index 0a667560f7..5e3d03579a 100644
--- a/compiler/codeGen/StgCmmPrim.hs
+++ b/compiler/codeGen/StgCmmPrim.hs
@@ -71,8 +71,8 @@ cgOpApp :: StgOp        -- The op
         -> FCode ReturnKind
 
 -- Foreign calls
-cgOpApp (StgFCallOp fcall _) stg_args res_ty
-  = cgForeignCall fcall stg_args res_ty
+cgOpApp (StgFCallOp fcall ty _) stg_args res_ty
+  = cgForeignCall fcall ty stg_args res_ty
       -- Note [Foreign call results]
 
 -- tagToEnum# is special: we need to pull the constructor
diff --git a/compiler/stgSyn/CoreToStg.hs b/compiler/stgSyn/CoreToStg.hs
index 7f60bb21d2..12766e90d4 100644
--- a/compiler/stgSyn/CoreToStg.hs
+++ b/compiler/stgSyn/CoreToStg.hs
@@ -539,7 +539,7 @@ coreToStgApp _ f args ticks = do
 
                 -- A regular foreign call.
                 FCallId call     -> ASSERT( saturated )
-                                    StgOpApp (StgFCallOp call (idUnique f)) args' res_ty
+                                    StgOpApp (StgFCallOp call (idType f) (idUnique f)) args' res_ty
 
                 TickBoxOpId {}   -> pprPanic "coreToStg TickBox" $ ppr (f,args')
                 _other           -> StgApp f args'
diff --git a/compiler/stgSyn/StgSyn.hs b/compiler/stgSyn/StgSyn.hs
index 3a6cf3f133..274b0696fb 100644
--- a/compiler/stgSyn/StgSyn.hs
+++ b/compiler/stgSyn/StgSyn.hs
@@ -686,10 +686,14 @@ data StgOp
 
   | StgPrimCallOp PrimCall
 
-  | StgFCallOp ForeignCall Unique
+  | StgFCallOp ForeignCall Type Unique 
         -- The Unique is occasionally needed by the C pretty-printer
         -- (which lacks a unique supply), notably when generating a
-        -- typedef for foreign-export-dynamic
+        -- typedef for foreign-export-dynamic. The Type, which is
+        -- obtained from the foreign import declaration itself, is
+        -- needed by the stg-to-cmm pass to determine the offset to
+        -- apply to unlifted boxed arguments in StgCmmForeign.
+        -- See Note [Unlifted boxed arguments to foreign calls]
 
 {-
 ************************************************************************
@@ -860,7 +864,7 @@ pprStgAlt indent (con, params, expr)
 pprStgOp :: StgOp -> SDoc
 pprStgOp (StgPrimOp  op)   = ppr op
 pprStgOp (StgPrimCallOp op)= ppr op
-pprStgOp (StgFCallOp op _) = ppr op
+pprStgOp (StgFCallOp op _ _) = ppr op
 
 instance Outputable AltType where
   ppr PolyAlt         = text "Polymorphic"
diff --git a/testsuite/tests/ffi/should_compile/ReducingFfiSignature.hs b/testsuite/tests/ffi/should_compile/ReducingFfiSignature.hs
new file mode 100644
index 0000000000..b1af676121
--- /dev/null
+++ b/testsuite/tests/ffi/should_compile/ReducingFfiSignature.hs
@@ -0,0 +1,27 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module ReducingFfiSignature
+  ( c_pow_1
+  , c_pow_2
+  , c_pow_3
+  ) where
+
+import Foreign.C.Types (CDouble(..))
+import Data.Kind (Type)
+
+type family Foo (x :: Type)
+
+type instance Foo Int = CDouble
+type instance Foo Bool = CDouble -> CDouble
+type instance Foo CDouble = CDouble -> CDouble -> CDouble
+
+foreign import ccall "math.h pow"
+  c_pow_1 :: CDouble -> CDouble -> Foo Int
+
+foreign import ccall "math.h pow"
+  c_pow_2 :: CDouble -> Foo Bool
+
+foreign import ccall "math.h pow"
+  c_pow_3 :: Foo CDouble
diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T
index 1aa32c87d5..c8dd636557 100644
--- a/testsuite/tests/ffi/should_compile/all.T
+++ b/testsuite/tests/ffi/should_compile/all.T
@@ -23,6 +23,7 @@ test('cc011', normal, compile, [''])
 test('cc012', normal, compile, [''])
 test('cc013', normal, compile, [''])
 test('cc014', normal, compile, [''])
+test('ReducingFfiSignature', normal, compile, [''])
 test('ffi-deriv1', normal, compile, [''])
 test('T1357', normal, compile, [''])
 test('T3624', normal, compile, [''])
diff --git a/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.hs b/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.hs
new file mode 100644
index 0000000000..327e799586
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.hs
@@ -0,0 +1,13 @@
+{-# LANGUAGE ForeignFunctionInterface #-}
+{-# LANGUAGE TypeFamilies #-}
+{-# LANGUAGE UnliftedFFITypes #-}
+
+module NonreducingFfiSignature (c_pow) where
+
+import Foreign.C.Types (CDouble(..))
+import Data.Kind (Type)
+
+type family Foo (x :: Type)
+
+foreign import ccall "math.h pow"
+  c_pow :: CDouble -> CDouble -> Foo Int
diff --git a/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.stderr b/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.stderr
new file mode 100644
index 0000000000..22a6c7dc26
--- /dev/null
+++ b/testsuite/tests/ffi/should_fail/NonreducingFfiSignature.stderr
@@ -0,0 +1,6 @@
+NonreducingFfiSignature.hs:12:1:
+     Unacceptable result type in foreign declaration:
+        ‘Foo Int’ cannot be marshalled in a foreign call
+     When checking declaration:
+        foreign import ccall safe "math.h pow" c_pow
+          :: CDouble -> CDouble -> Foo Int
diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T
index 38273db314..afe4370273 100644
--- a/testsuite/tests/ffi/should_fail/all.T
+++ b/testsuite/tests/ffi/should_fail/all.T
@@ -10,6 +10,7 @@ test('ccfail004', [extra_files(['Ccfail004A.hs'])], multimod_compile_fail, ['ccf
 test('ccfail005', normal, compile_fail, [''])
 test('ccall_value', normal, compile_fail, [''])
 test('capi_value_function', normal, compile_fail, [''])
+test('NonreducingFfiSignature', normal, compile_fail, [''])
 test('T5664', normal, compile_fail, ['-v0'])
 test('T7506', normal, compile_fail, [''])
 test('T7243', normal, compile_fail, [''])
diff --git a/testsuite/tests/ffi/should_run/T16650a.hs b/testsuite/tests/ffi/should_run/T16650a.hs
new file mode 100644
index 0000000000..ab1cd9c67e
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650a.hs
@@ -0,0 +1,47 @@
+{-# language GADTSyntax #-}
+{-# language KindSignatures #-}
+{-# language UnliftedFFITypes #-}
+{-# language ForeignFunctionInterface #-}
+{-# language MagicHash #-}
+{-# language UnboxedTuples #-}
+
+-- Test for shims when passing a ByteArray# to a foreign function.
+-- The bad behavior here was initially observed in the MR
+-- https://gitlab.haskell.org/ghc/ghc/merge_requests/939,
+-- but this test has been named after issue #16650 since it
+-- is closely related to the unexpected behavior there.
+
+import GHC.Exts
+import GHC.Word
+import GHC.IO
+import Data.Kind (Type)
+
+main :: IO ()
+main = do
+  mb0 <- luckySingleton
+  print =<< readByteArray mb0 0
+  case box mb0 of
+    Box x -> print =<< c_head_bytearray (unsafeCoerce# x)
+
+foreign import ccall unsafe "head_bytearray"
+  c_head_bytearray :: MutableByteArray# RealWorld -> IO Word8
+
+data Box :: Type where
+  Box :: (Any :: TYPE 'UnliftedRep) -> Box
+
+data MutableByteArray :: Type where
+  MutableByteArray :: MutableByteArray# RealWorld -> MutableByteArray
+
+box :: MutableByteArray -> Box
+{-# noinline box #-}
+box (MutableByteArray x) = Box (unsafeCoerce# x)
+
+luckySingleton :: IO MutableByteArray
+luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of
+  (# s1, marr# #) -> case writeWord8Array# marr# 0# 42## s1 of
+    s2 -> (# s2, MutableByteArray marr# #)
+
+readByteArray :: MutableByteArray -> Int -> IO Word8
+readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 ->
+  case readWord8Array# b# i# s0 of
+    (# s1, w #) -> (# s1, W8# w #)
diff --git a/testsuite/tests/ffi/should_run/T16650a.stdout b/testsuite/tests/ffi/should_run/T16650a.stdout
new file mode 100644
index 0000000000..daaac9e303
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650a.stdout
@@ -0,0 +1,2 @@
+42
+42
diff --git a/testsuite/tests/ffi/should_run/T16650a_c.c b/testsuite/tests/ffi/should_run/T16650a_c.c
new file mode 100644
index 0000000000..695206098d
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650a_c.c
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+// Take the first element of a byte array. The array
+// must have length >= 1.
+uint8_t head_bytearray (uint8_t *arr) {
+  return arr[0];
+}
diff --git a/testsuite/tests/ffi/should_run/T16650b.hs b/testsuite/tests/ffi/should_run/T16650b.hs
new file mode 100644
index 0000000000..763329fc8b
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650b.hs
@@ -0,0 +1,69 @@
+{-# language GADTSyntax #-}
+{-# language KindSignatures #-}
+{-# language UnliftedFFITypes #-}
+{-# language ForeignFunctionInterface #-}
+{-# language MagicHash #-}
+{-# language UnboxedTuples #-}
+
+-- Test for shims when passing an array of unlifted values
+-- to a foreign function.
+-- See test T16650a for more commentary.
+
+import GHC.Exts
+import GHC.Word
+import GHC.IO
+import Data.Kind (Type)
+
+main :: IO ()
+main = do
+  mb0 <- luckySingleton
+  mb1 <- luckySingleton
+  mbs <- newByteArrays 2
+  writeByteArrays mbs 0 mb0
+  writeByteArrays mbs 1 mb0
+  case box mbs of
+    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)
+  writeByteArrays mbs 1 mb1
+  case box mbs of
+    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)
+
+foreign import ccall unsafe "is_doubleton_homogenous"
+  c_is_doubleton_homogeneous :: MutableArrayArray# RealWorld -> IO Word8
+
+data Box :: Type where
+  Box :: (Any :: TYPE 'UnliftedRep) -> Box
+
+-- An array of bytes
+data MutableByteArray :: Type where
+  MutableByteArray :: MutableByteArray# RealWorld -> MutableByteArray
+
+-- A mutable array of mutable byte arrays
+data MutableByteArrays :: Type where
+  MutableByteArrays :: MutableArrayArray# RealWorld -> MutableByteArrays
+
+box :: MutableByteArrays -> Box
+{-# noinline box #-}
+box (MutableByteArrays x) = Box (unsafeCoerce# x)
+
+luckySingleton :: IO MutableByteArray
+luckySingleton = IO $ \s0 -> case newByteArray# 1# s0 of
+  (# s1, marr# #) -> case writeWord8Array# marr# 0# 42## s1 of
+    s2 -> (# s2, MutableByteArray marr# #)
+
+readByteArray :: MutableByteArray -> Int -> IO Word8
+readByteArray (MutableByteArray b#) (I# i#) = IO $ \s0 ->
+  case readWord8Array# b# i# s0 of
+    (# s1, w #) -> (# s1, W8# w #)
+
+-- Write a mutable byte array to the array of mutable byte arrays
+-- at the given index.
+writeByteArrays :: MutableByteArrays -> Int -> MutableByteArray -> IO ()
+writeByteArrays (MutableByteArrays maa#) (I# i#) (MutableByteArray a) = IO $ \s0 ->
+  case writeMutableByteArrayArray# maa# i# a s0 of
+    s1 -> (# s1, () #)
+
+-- Allocate a new array of mutable byte arrays. All elements are
+-- uninitialized. Attempting to read them will cause a crash.
+newByteArrays :: Int -> IO MutableByteArrays
+newByteArrays (I# len#) = IO $ \s0 -> case newArrayArray# len# s0 of
+  (# s1, a# #) -> (# s1, MutableByteArrays a# #)
diff --git a/testsuite/tests/ffi/should_run/T16650b.stdout b/testsuite/tests/ffi/should_run/T16650b.stdout
new file mode 100644
index 0000000000..b261da18d5
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650b.stdout
@@ -0,0 +1,2 @@
+1
+0
diff --git a/testsuite/tests/ffi/should_run/T16650b_c.c b/testsuite/tests/ffi/should_run/T16650b_c.c
new file mode 100644
index 0000000000..72d0c92d17
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650b_c.c
@@ -0,0 +1,17 @@
+#include <stdint.h>
+
+// Check to see if the first two elements in the array are
+// the same pointer. Technically, GHC only promises that this is
+// deterministic for arrays of unlifted identity-supporting
+// types (MutableByteArray#, TVar#, MutVar#, etc.). However,
+// in the tests, we assume that even for types that do not
+// support identity (all lifted types, ByteArray#, Array#, etc.),
+// GHC initializes every element in an array to the same pointer
+// with newArray#. This is the GHC's actual behavior, and if
+// newArray# stopped behaving this way, even if it wouldn't
+// be a semantic bug, it would be a performance bug. Consequently,
+// we assume this behavior in tests T16650c and T16650d.
+uint8_t is_doubleton_homogenous (void **arr) {
+  return (arr[0] == arr[1]);
+}
+
diff --git a/testsuite/tests/ffi/should_run/T16650c.hs b/testsuite/tests/ffi/should_run/T16650c.hs
new file mode 100644
index 0000000000..968731b3bd
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650c.hs
@@ -0,0 +1,43 @@
+{-# language GADTSyntax #-}
+{-# language KindSignatures #-}
+{-# language UnliftedFFITypes #-}
+{-# language ForeignFunctionInterface #-}
+{-# language MagicHash #-}
+{-# language UnboxedTuples #-}
+{-# language ExplicitForAll #-}
+
+-- Test for shims when passing an array of lifted values
+-- to a foreign function.
+-- See test T16650a for more commentary.
+
+import GHC.Exts
+import GHC.Word
+import GHC.IO
+import Data.Kind (Type)
+
+main :: IO ()
+main = do
+  mbs <- newArray 2 ((+55) :: Int -> Int)
+  case box mbs of
+    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)
+
+foreign import ccall unsafe "is_doubleton_homogenous"
+  c_is_doubleton_homogeneous :: forall (a :: Type).
+    MutableArray# RealWorld a -> IO Word8
+
+data Box :: Type where
+  Box :: (Any :: TYPE 'UnliftedRep) -> Box
+
+-- An array of unary integer functions
+data MutableArray :: Type where
+  MutableArray :: MutableArray# RealWorld (Int -> Int) -> MutableArray
+
+box :: MutableArray -> Box
+{-# noinline box #-}
+box (MutableArray x) = Box (unsafeCoerce# x)
+
+-- Allocate a new array of unary integer functions.
+newArray :: Int -> (Int -> Int) -> IO MutableArray
+newArray (I# len#) x = IO $ \s0 -> case newArray# len# x s0 of
+  (# s1, a# #) -> (# s1, MutableArray a# #)
+
diff --git a/testsuite/tests/ffi/should_run/T16650c.stdout b/testsuite/tests/ffi/should_run/T16650c.stdout
new file mode 100644
index 0000000000..d00491fd7e
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650c.stdout
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/ffi/should_run/T16650c_c.c b/testsuite/tests/ffi/should_run/T16650c_c.c
new file mode 100644
index 0000000000..f45bcafc0e
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650c_c.c
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+// See T16650b_c.c for commentary.
+uint8_t is_doubleton_homogenous (void **arr) {
+  return (arr[0] == arr[1]);
+}
+
diff --git a/testsuite/tests/ffi/should_run/T16650d.hs b/testsuite/tests/ffi/should_run/T16650d.hs
new file mode 100644
index 0000000000..8bb4a4697b
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650d.hs
@@ -0,0 +1,45 @@
+{-# language GADTSyntax #-}
+{-# language KindSignatures #-}
+{-# language UnliftedFFITypes #-}
+{-# language ForeignFunctionInterface #-}
+{-# language MagicHash #-}
+{-# language UnboxedTuples #-}
+{-# language ExplicitForAll #-}
+
+-- Test for shims when passing an array of lifted values
+-- to a foreign function.
+-- See test T16650a for more commentary.
+
+import GHC.Exts
+import GHC.Word
+import GHC.IO
+import Data.Kind (Type)
+
+main :: IO ()
+main = do
+  mbs <- newSmallArray 2 ((+55) :: Int -> Int)
+  case box mbs of
+    Box x -> print =<< c_is_doubleton_homogeneous (unsafeCoerce# x)
+
+foreign import ccall unsafe "is_doubleton_homogenous"
+  c_is_doubleton_homogeneous :: forall (a :: Type).
+    SmallMutableArray# RealWorld a -> IO Word8
+
+data Box :: Type where
+  Box :: (Any :: TYPE 'UnliftedRep) -> Box
+
+-- An array of unary integer functions
+data SmallMutableArray :: Type where
+  SmallMutableArray :: SmallMutableArray# RealWorld (Int -> Int)
+                    -> SmallMutableArray
+
+box :: SmallMutableArray -> Box
+{-# noinline box #-}
+box (SmallMutableArray x) = Box (unsafeCoerce# x)
+
+-- Allocate a new array of unary integer functions.
+newSmallArray :: Int -> (Int -> Int) -> IO SmallMutableArray
+newSmallArray (I# len#) x = IO $ \s0 -> case newSmallArray# len# x s0 of
+  (# s1, a# #) -> (# s1, SmallMutableArray a# #)
+
+
diff --git a/testsuite/tests/ffi/should_run/T16650d.stdout b/testsuite/tests/ffi/should_run/T16650d.stdout
new file mode 100644
index 0000000000..d00491fd7e
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650d.stdout
@@ -0,0 +1 @@
+1
diff --git a/testsuite/tests/ffi/should_run/T16650d_c.c b/testsuite/tests/ffi/should_run/T16650d_c.c
new file mode 100644
index 0000000000..f45bcafc0e
--- /dev/null
+++ b/testsuite/tests/ffi/should_run/T16650d_c.c
@@ -0,0 +1,7 @@
+#include <stdint.h>
+
+// See T16650b_c.c for commentary.
+uint8_t is_doubleton_homogenous (void **arr) {
+  return (arr[0] == arr[1]);
+}
+
diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T
index 69b0f30c2c..701372f8f1 100644
--- a/testsuite/tests/ffi/should_run/all.T
+++ b/testsuite/tests/ffi/should_run/all.T
@@ -191,6 +191,14 @@ test('T12134', [omit_ways(['ghci'])], compile_and_run, ['T12134_c.c'])
 
 test('T12614', [omit_ways(['ghci'])], compile_and_run, ['T12614_c.c'])
 
+test('T16650a', [omit_ways(['ghci'])], compile_and_run, ['T16650a_c.c'])
+
+test('T16650b', [omit_ways(['ghci'])], compile_and_run, ['T16650b_c.c'])
+
+test('T16650c', [omit_ways(['ghci'])], compile_and_run, ['T16650c_c.c'])
+
+test('T16650d', [omit_ways(['ghci'])], compile_and_run, ['T16650d_c.c'])
+
 test('PrimFFIInt8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIInt8_c.c'])
 
 test('PrimFFIWord8', [omit_ways(['ghci'])], compile_and_run, ['PrimFFIWord8_c.c'])