Use a better strategy for determining the offset applied to foreign function argument...
authorAndrew Martin <andrew.thaddeus@gmail.com>
Sat, 25 May 2019 19:36:14 +0000 (15:36 -0400)
committerMarge Bot <ben+marge-bot@smart-cactus.org>
Tue, 4 Jun 2019 05:09:43 +0000 (01:09 -0400)
23 files changed:
compiler/codeGen/StgCmmExpr.hs
compiler/codeGen/StgCmmForeign.hs
compiler/codeGen/StgCmmPrim.hs
compiler/stgSyn/CoreToStg.hs
compiler/stgSyn/StgSyn.hs
testsuite/tests/ffi/should_compile/ReducingFfiSignature.hs [new file with mode: 0644]
testsuite/tests/ffi/should_compile/all.T
testsuite/tests/ffi/should_fail/NonreducingFfiSignature.hs [new file with mode: 0644]
testsuite/tests/ffi/should_fail/NonreducingFfiSignature.stderr [new file with mode: 0644]
testsuite/tests/ffi/should_fail/all.T
testsuite/tests/ffi/should_run/T16650a.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650a.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650a_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650b.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650b.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650b_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650c.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650c.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650c_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650d.hs [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650d.stdout [new file with mode: 0644]
testsuite/tests/ffi/should_run/T16650d_c.c [new file with mode: 0644]
testsuite/tests/ffi/should_run/all.T

index 70a044a..b49cee3 100644 (file)
@@ -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
index c1103e7..45e5733 100644 (file)
@@ -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)
+
index 0a66756..5e3d035 100644 (file)
@@ -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
index 7f60bb2..12766e9 100644 (file)
@@ -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'
index 3a6cf3f..274b069 100644 (file)
@@ -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 (file)
index 0000000..b1af676
--- /dev/null
@@ -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
index 1aa32c8..c8dd636 100644 (file)
@@ -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 (file)
index 0000000..327e799
--- /dev/null
@@ -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 (file)
index 0000000..22a6c7d
--- /dev/null
@@ -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
index 38273db..afe4370 100644 (file)
@@ -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 (file)
index 0000000..ab1cd9c
--- /dev/null
@@ -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 (file)
index 0000000..daaac9e
--- /dev/null
@@ -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 (file)
index 0000000..6952060
--- /dev/null
@@ -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 (file)
index 0000000..763329f
--- /dev/null
@@ -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 (file)
index 0000000..b261da1
--- /dev/null
@@ -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 (file)
index 0000000..72d0c92
--- /dev/null
@@ -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 (file)
index 0000000..968731b
--- /dev/null
@@ -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 (file)
index 0000000..d00491f
--- /dev/null
@@ -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 (file)
index 0000000..f45bcaf
--- /dev/null
@@ -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 (file)
index 0000000..8bb4a46
--- /dev/null
@@ -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 (file)
index 0000000..d00491f
--- /dev/null
@@ -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 (file)
index 0000000..f45bcaf
--- /dev/null
@@ -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]);
+}
+
index 69b0f30..701372f 100644 (file)
@@ -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'])