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