[Git][ghc/ghc][master] Use a better strategy for determining the offset applied to foreign function...
Marge Bot
gitlab at gitlab.haskell.org
Tue Jun 4 05:09:49 UTC 2019
Marge Bot pushed to branch master at Glasgow Haskell Compiler / GHC
Commits:
db78ac6f by Andrew Martin at 2019-06-04T05:09:43Z
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 changed files:
- 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
- testsuite/tests/ffi/should_compile/all.T
- + testsuite/tests/ffi/should_fail/NonreducingFfiSignature.hs
- + testsuite/tests/ffi/should_fail/NonreducingFfiSignature.stderr
- testsuite/tests/ffi/should_fail/all.T
- + testsuite/tests/ffi/should_run/T16650a.hs
- + testsuite/tests/ffi/should_run/T16650a.stdout
- + testsuite/tests/ffi/should_run/T16650a_c.c
- + testsuite/tests/ffi/should_run/T16650b.hs
- + testsuite/tests/ffi/should_run/T16650b.stdout
- + testsuite/tests/ffi/should_run/T16650b_c.c
- + testsuite/tests/ffi/should_run/T16650c.hs
- + testsuite/tests/ffi/should_run/T16650c.stdout
- + testsuite/tests/ffi/should_run/T16650c_c.c
- + testsuite/tests/ffi/should_run/T16650d.hs
- + testsuite/tests/ffi/should_run/T16650d.stdout
- + testsuite/tests/ffi/should_run/T16650d_c.c
- testsuite/tests/ffi/should_run/all.T
Changes:
=====================================
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
=====================================
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)
+
=====================================
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
=====================================
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'
=====================================
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"
=====================================
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
=====================================
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, [''])
=====================================
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
=====================================
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
=====================================
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, [''])
=====================================
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 #)
=====================================
testsuite/tests/ffi/should_run/T16650a.stdout
=====================================
@@ -0,0 +1,2 @@
+42
+42
=====================================
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];
+}
=====================================
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# #)
=====================================
testsuite/tests/ffi/should_run/T16650b.stdout
=====================================
@@ -0,0 +1,2 @@
+1
+0
=====================================
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]);
+}
+
=====================================
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# #)
+
=====================================
testsuite/tests/ffi/should_run/T16650c.stdout
=====================================
@@ -0,0 +1 @@
+1
=====================================
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]);
+}
+
=====================================
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# #)
+
+
=====================================
testsuite/tests/ffi/should_run/T16650d.stdout
=====================================
@@ -0,0 +1 @@
+1
=====================================
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]);
+}
+
=====================================
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'])
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/db78ac6f5d69618ff143ab4b572e7f58a1805687
--
View it on GitLab: https://gitlab.haskell.org/ghc/ghc/commit/db78ac6f5d69618ff143ab4b572e7f58a1805687
You're receiving this email because of your account on gitlab.haskell.org.
-------------- next part --------------
An HTML attachment was scrubbed...
URL: <http://mail.haskell.org/pipermail/ghc-commits/attachments/20190604/6be5a0a8/attachment-0001.html>
More information about the ghc-commits
mailing list