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.

18 files changed, 304 insertions, 0 deletions

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