diff options
Diffstat (limited to 'testsuite/tests/ffi')
124 files changed, 3546 insertions, 0 deletions
diff --git a/testsuite/tests/ffi/Makefile b/testsuite/tests/ffi/Makefile new file mode 100644 index 0000000000..9a36a1c5fe --- /dev/null +++ b/testsuite/tests/ffi/Makefile @@ -0,0 +1,3 @@ +TOP=../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ffi/should_compile/1357.hs b/testsuite/tests/ffi/should_compile/1357.hs new file mode 100644 index 0000000000..1f5479bc1c --- /dev/null +++ b/testsuite/tests/ffi/should_compile/1357.hs @@ -0,0 +1,5 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module T where + +import Foreign +foreign import ccall "f" f :: FunPtr (Int -> IO ()) diff --git a/testsuite/tests/ffi/should_compile/1357.stderr b/testsuite/tests/ffi/should_compile/1357.stderr new file mode 100644 index 0000000000..cd1cb7031a --- /dev/null +++ b/testsuite/tests/ffi/should_compile/1357.stderr @@ -0,0 +1,3 @@ + +1357.hs:5:1: + Warning: possible missing & in foreign import of FunPtr diff --git a/testsuite/tests/ffi/should_compile/3624.hs b/testsuite/tests/ffi/should_compile/3624.hs new file mode 100644 index 0000000000..8f42efc055 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/3624.hs @@ -0,0 +1,4 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Test where + +foreign import ccall "path/to/foo.h foo" foo :: Int -> IO Float diff --git a/testsuite/tests/ffi/should_compile/3742.hs b/testsuite/tests/ffi/should_compile/3742.hs new file mode 100644 index 0000000000..c16b6009eb --- /dev/null +++ b/testsuite/tests/ffi/should_compile/3742.hs @@ -0,0 +1,12 @@ +module ShouldCompile where + +import Foreign +import Foreign.C + +-- extra space before the function name: +foreign import ccall unsafe " g_get_application_name" + g_get_application_name :: (IO (Ptr CChar)) + +-- and after: +foreign import ccall unsafe "g_get_application_name " + g_get_application_name' :: (IO (Ptr CChar)) diff --git a/testsuite/tests/ffi/should_compile/Makefile b/testsuite/tests/ffi/should_compile/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ffi/should_compile/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ffi/should_compile/all.T b/testsuite/tests/ffi/should_compile/all.T new file mode 100644 index 0000000000..ff8bc64b5d --- /dev/null +++ b/testsuite/tests/ffi/should_compile/all.T @@ -0,0 +1,38 @@ + +def ffi( opts ): + opts.extra_hc_opts = '-XForeignFunctionInterface -optc-Wno-implicit' + +setTestOpts(ffi) + +test('cc001', normal, compile, ['']) + +# Non-static C call +# cc004 test also uses stdcall, so it only works on i386. +if config.platform.startswith('i386-'): + ways = expect_fail_for(['extcore','optextcore']) +else: + ways = expect_fail +test('cc004', ways, compile, ['']) + +# foreign label +test('cc005', expect_fail_for(['extcore','optextcore']), compile, ['']) + +# Missing: +# test('cc006', normal, compile, ['']) + +test('cc007', normal, compile, ['']) +# foreign label +test('cc008', expect_fail_for(['extcore','optextcore']), compile, ['']) +# foreign label +test('cc009', expect_fail_for(['extcore','optextcore']), compile, ['']) +# Non-static C call +test('cc010', expect_fail_for(['extcore','optextcore']), compile, ['']) +test('cc011', normal, compile, ['']) +test('cc012', normal, compile, ['']) +test('cc013', normal, compile, ['']) +test('cc014', normal, compile, ['']) +test('ffi-deriv1', normal, compile, ['']) + +test('1357', normal, compile, ['']) +test('3624', normal, compile, ['']) +test('3742', normal, compile, ['']) diff --git a/testsuite/tests/ffi/should_compile/cc001.hs b/testsuite/tests/ffi/should_compile/cc001.hs new file mode 100644 index 0000000000..cd7318d000 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc001.hs @@ -0,0 +1,21 @@ +-- !!! cc001 -- ccall with standard boxed arguments and results + +module ShouldCompile where + +-- simple functions + +foreign import ccall unsafe "a" a :: IO Int + +foreign import ccall unsafe "b" b :: Int -> IO Int + +foreign import ccall unsafe "c" + c :: Int -> Char -> Float -> Double -> IO Float + +-- simple monadic code + +d = a >>= \ x -> + b x >>= \ y -> + c y 'f' 1.0 2.0 + + + diff --git a/testsuite/tests/ffi/should_compile/cc001.stderr b/testsuite/tests/ffi/should_compile/cc001.stderr new file mode 100644 index 0000000000..e69de29bb2 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc001.stderr diff --git a/testsuite/tests/ffi/should_compile/cc004.hs b/testsuite/tests/ffi/should_compile/cc004.hs new file mode 100644 index 0000000000..fb754223b2 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc004.hs @@ -0,0 +1,67 @@ +{-# LANGUAGE MagicHash, UnliftedFFITypes #-} +-- !!! cc004 -- foreign declarations +module ShouldCompile where + +import Foreign +import GHC.Exts +import Data.Int +import Data.Word + +-- importing functions + +-- We can't import the same function using both stdcall and ccall +-- calling conventions in the same file when compiling via C (this is a +-- restriction in the C backend caused by the need to emit a prototype +-- for stdcall functions). +foreign import stdcall "p" m_stdcall :: StablePtr a -> IO (StablePtr b) +foreign import ccall unsafe "q" m_ccall :: ByteArray# -> IO Int + +-- We can't redefine the calling conventions of certain functions (those from +-- math.h). +foreign import stdcall "my_sin" my_sin :: Double -> IO Double +foreign import stdcall "my_cos" my_cos :: Double -> IO Double + +foreign import stdcall "m1" m8 :: IO Int8 +foreign import stdcall "m2" m16 :: IO Int16 +foreign import stdcall "m3" m32 :: IO Int32 +foreign import stdcall "m4" m64 :: IO Int64 + +foreign import stdcall "dynamic" d8 :: Ptr a -> IO Int8 +foreign import stdcall "dynamic" d16 :: Ptr a -> IO Int16 +foreign import stdcall "dynamic" d32 :: Ptr a -> IO Int32 +foreign import stdcall "dynamic" d64 :: Ptr a -> IO Int64 + +foreign import ccall unsafe "kitchen" + sink :: Ptr a + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO () + + +foreign import ccall unsafe "dynamic" + sink2 :: Ptr a + -> (Ptr b + -> ByteArray# + -> MutableByteArray# RealWorld + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Word8 + -> Word16 + -> Word32 + -> Float + -> Double + -> IO ()) + diff --git a/testsuite/tests/ffi/should_compile/cc005.hs b/testsuite/tests/ffi/should_compile/cc005.hs new file mode 100644 index 0000000000..e057cfd233 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc005.hs @@ -0,0 +1,108 @@ +-- !!! cc005 -- foreign export declarations +module ShouldCompile (d8) where + +import Foreign.Ptr --import Foreign + --import GlaExts + --import Int + --import Word +type Addr = Ptr () +foreign import ccall "wrapper" d8 :: (Int -> IO ()) -> IO Addr + +-- exporting functions +{- +m_stdcall :: Int -> IO Int +m_stdcall x = return x + +x = putChar + +foreign export ccall "m1" doo :: Int -> IO Int + +doo :: Eq a => a -> IO Int +doo _ = return 2 + +foreign export ccall "listAppend" plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a]) + +plusplus :: StablePtr [a] -> StablePtr [a] -> IO (StablePtr [a]) +plusplus x y = do + l1 <- deRefStablePtr x + l2 <- deRefStablePtr y + makeStablePtr (l1 ++ l2) + +foreign export ccall "m11" m_stdcall :: Int -> IO Int + +m_ccall :: Int -> Int -> IO Int +m_ccall x y = return (x-y) + +foreign export ccall "m2" m_ccall :: Int -> Int -> IO Int + +foreign export ccall "putcha" putChar :: Char -> IO () + +foreign export stdcall "Math" "sin" my_sin :: Double -> IO Double +foreign export stdcall "Math" "cos" my_cos :: Double -> IO Double + +my_sin = undefined +my_cos = undefined + +foreign export stdcall "m111" m8 :: IO Int8 +foreign export stdcall "m22" m16 :: IO Int16 +foreign export stdcall "m3" m32 :: IO Int32 +foreign export stdcall "m4" m64 :: IO Int64 + +m8 = undefined +m16 = undefined +m32 = undefined +m64 = undefined + +foreign export stdcall dynamic d8 :: (Addr -> IO Int8) -> IO Addr +foreign export stdcall dynamic d16 :: (Addr -> IO Int16) -> IO Addr +foreign export stdcall dynamic d32 :: (Addr -> IO Int32) -> IO Addr +foreign export stdcall dynamic d64 :: (Addr -> IO Int64) -> IO Addr + + +d8 = undefined +d16 = undefined +d32 = undefined +d64 = undefined + + +foreign export ccall "kitchen" + sink :: --ForeignObj +-- -> ByteArray Int +-- -> MutableByteArray Int RealWorld + Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO Int + +sink = undefined +sink2 = undefined + +foreign export ccall dynamic + sink2 :: (--ForeignObj +-- -> ByteArray Int +-- -> MutableByteArray Int RealWorld + StablePtr a + -> Int + -> Int8 + -> Int16 + -> Int32 + -> Int64 + -> Word8 + -> Word16 + -> Word32 + -> Word64 + -> Float + -> Double + -> IO ()) + -> IO Addr + + +-} diff --git a/testsuite/tests/ffi/should_compile/cc007.hs b/testsuite/tests/ffi/should_compile/cc007.hs new file mode 100644 index 0000000000..99337cc37f --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc007.hs @@ -0,0 +1,4 @@ +-- !!! cc007 -- foreign import with external name equal to Haskell name. +module ShouldCompile where + +foreign import ccall sine :: Double -> Double diff --git a/testsuite/tests/ffi/should_compile/cc008.hs b/testsuite/tests/ffi/should_compile/cc008.hs new file mode 100644 index 0000000000..2dd0bc99eb --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc008.hs @@ -0,0 +1,8 @@ +-- !!! cc008 -- foreign export dynamic returning newtype of Addr +module ShouldCompile where + +import Foreign +type Addr = Ptr () +newtype NPtr a = NPtr Addr + +foreign import ccall "wrapper" mkFoo :: IO () -> IO (NPtr Int) diff --git a/testsuite/tests/ffi/should_compile/cc009.hs b/testsuite/tests/ffi/should_compile/cc009.hs new file mode 100644 index 0000000000..3ece3a9a24 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc009.hs @@ -0,0 +1,8 @@ +-- !!! cc009 -- foreign label returning newtype of Addr +module ShouldCompile where + +import Foreign +type Addr = Ptr () +newtype NPtr a = NPtr Addr + +foreign import ccall "&" foo :: NPtr Int diff --git a/testsuite/tests/ffi/should_compile/cc009_inc.h b/testsuite/tests/ffi/should_compile/cc009_inc.h new file mode 100644 index 0000000000..be2f5392f8 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc009_inc.h @@ -0,0 +1 @@ +extern void *foo; diff --git a/testsuite/tests/ffi/should_compile/cc010.hs b/testsuite/tests/ffi/should_compile/cc010.hs new file mode 100644 index 0000000000..dd34730d42 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc010.hs @@ -0,0 +1,5 @@ +module ShouldCompile where +import Foreign +foreign import ccall "dynamic" imp :: Ptr () -> Int +f1 a = imp a + 1 +f2 a = imp a + 2 diff --git a/testsuite/tests/ffi/should_compile/cc011.hs b/testsuite/tests/ffi/should_compile/cc011.hs new file mode 100644 index 0000000000..25cce84bd3 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc011.hs @@ -0,0 +1,9 @@ +module ShouldCompile where + +import Foreign + +-- !!! test that a recursive newtype can be used as an argument or result +-- type of a foreign import. + +newtype T = T (Ptr T) +foreign import ccall foo :: T -> IO T diff --git a/testsuite/tests/ffi/should_compile/cc011.stderr-hugs b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs new file mode 100644 index 0000000000..d6f9e1788c --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc011.stderr-hugs @@ -0,0 +1,2 @@ +cc011.c: In function `hugsprim_foo_0': +cc011.c:16: warning: assignment makes pointer from integer without a cast diff --git a/testsuite/tests/ffi/should_compile/cc012.hs b/testsuite/tests/ffi/should_compile/cc012.hs new file mode 100644 index 0000000000..288f9acd02 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc012.hs @@ -0,0 +1,6 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- !!! test that infix operators can be exported with foreign export, +-- and that we can export something which isn't defined in this module. +module ShouldCompile where +foreign export ccall "plusInt" (+) :: Int -> Int -> Int + diff --git a/testsuite/tests/ffi/should_compile/cc013.hs b/testsuite/tests/ffi/should_compile/cc013.hs new file mode 100644 index 0000000000..09dd2ef2ef --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc013.hs @@ -0,0 +1,14 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +-- !!! test that exporting the same thing multiple times works. +module ShouldCompile where + +import Data.Int + +foreign export ccall "addByte" (+) :: Int8 -> Int8 -> Int8 +foreign export ccall "addInt" (+) :: Int16 -> Int16 -> Int16 +foreign export ccall "addLong" (+) :: Int32 -> Int32 -> Int32 + +foreign export ccall "divByte" div :: Int8 -> Int8 -> Int8 +foreign export ccall "divInt" div :: Int16 -> Int16 -> Int16 +foreign export ccall "divLong" div :: Int32 -> Int32 -> Int32 + diff --git a/testsuite/tests/ffi/should_compile/cc014.hs b/testsuite/tests/ffi/should_compile/cc014.hs new file mode 100644 index 0000000000..bbf2d765ed --- /dev/null +++ b/testsuite/tests/ffi/should_compile/cc014.hs @@ -0,0 +1,4 @@ +module Blah ( foo ) where +import Foreign.Ptr ( FunPtr ) +type Bar = Int -> Double -> Double -> Double -> IO () +foreign import ccall unsafe "dynamic" foo :: FunPtr Bar -> Bar diff --git a/testsuite/tests/ffi/should_compile/ffi-deriv1.hs b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs new file mode 100644 index 0000000000..94d0df2fa4 --- /dev/null +++ b/testsuite/tests/ffi/should_compile/ffi-deriv1.hs @@ -0,0 +1,23 @@ +{-# LANGUAGE GeneralizedNewtypeDeriving #-} +
+-- Tests newtype unwrapping for the IO monad itself
+-- Notice the RenderM monad, which is used in the
+-- type of the callback function
+
+module ShouldCompile where
+
+import Foreign.Ptr
+newtype RenderM a = RenderM (IO a) deriving (Functor, Monad)
+
+type RenderCallback = Int -> Int -> RenderM ()
+
+foreign import ccall duma_onRender :: FunPtr RenderCallback -> RenderM ()
+
+foreign import ccall "wrapper" mkRenderCallback
+ :: RenderCallback -> RenderM (FunPtr RenderCallback)
+
+onRender :: RenderCallback -> RenderM ()
+onRender f = mkRenderCallback f >>= duma_onRender
+
+
+
diff --git a/testsuite/tests/ffi/should_fail/Makefile b/testsuite/tests/ffi/should_fail/Makefile new file mode 100644 index 0000000000..9101fbd40a --- /dev/null +++ b/testsuite/tests/ffi/should_fail/Makefile @@ -0,0 +1,3 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk diff --git a/testsuite/tests/ffi/should_fail/T3066.hs b/testsuite/tests/ffi/should_fail/T3066.hs new file mode 100644 index 0000000000..2d71946843 --- /dev/null +++ b/testsuite/tests/ffi/should_fail/T3066.hs @@ -0,0 +1,7 @@ +{-# LANGUAGE ForeignFunctionInterface, RankNTypes #-} +module Foo where + +import Foreign +type X u = Ptr () +foreign import ccall bla :: (forall u. X u) -> IO () + diff --git a/testsuite/tests/ffi/should_fail/T3066.stderr b/testsuite/tests/ffi/should_fail/T3066.stderr new file mode 100644 index 0000000000..ac0a07d60a --- /dev/null +++ b/testsuite/tests/ffi/should_fail/T3066.stderr @@ -0,0 +1,6 @@ + +T3066.hs:6:1: + Unacceptable argument type in foreign declaration: forall u. X u + When checking declaration: + foreign import ccall safe "static bla" bla + :: (forall u. X u) -> IO () diff --git a/testsuite/tests/ffi/should_fail/all.T b/testsuite/tests/ffi/should_fail/all.T new file mode 100644 index 0000000000..bc6ee95e62 --- /dev/null +++ b/testsuite/tests/ffi/should_fail/all.T @@ -0,0 +1,8 @@ + +# Missing: +# test('cc002', normal, compile_fail, ['']) + +test('ccfail001', only_compiler_types(['ghc']), compile_fail, ['']) +test('ccfail002', only_compiler_types(['ghc']), compile_fail, ['']) +test('ccfail003', only_compiler_types(['ghc']), compile_fail, ['']) +test('T3066', only_compiler_types(['ghc']), compile_fail, ['']) diff --git a/testsuite/tests/ffi/should_fail/ccfail001.hs b/testsuite/tests/ffi/should_fail/ccfail001.hs new file mode 100644 index 0000000000..cd8eb83665 --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail001.hs @@ -0,0 +1,10 @@ + +{-# LANGUAGE ForeignFunctionInterface, MagicHash #-} + +-- Trac #1037 + +module Foo where + +import GHC.Prim + +foreign import ccall foo :: Int -> State# RealWorld diff --git a/testsuite/tests/ffi/should_fail/ccfail001.stderr b/testsuite/tests/ffi/should_fail/ccfail001.stderr new file mode 100644 index 0000000000..813c5d187c --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail001.stderr @@ -0,0 +1,6 @@ + +ccfail001.hs:10:1: + Unacceptable result type in foreign declaration: State# RealWorld + When checking declaration: + foreign import ccall safe "static foo" foo + :: Int -> State# RealWorld diff --git a/testsuite/tests/ffi/should_fail/ccfail002.hs b/testsuite/tests/ffi/should_fail/ccfail002.hs new file mode 100644 index 0000000000..977faa2f7c --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail002.hs @@ -0,0 +1,11 @@ + +{-# LANGUAGE ForeignFunctionInterface, UnboxedTuples, MagicHash, UnliftedFFITypes #-} + +-- Test for Trac #1680 + +module ShouldFail where + +import GHC.Exts + +foreign import ccall unsafe "foo" + foo :: Int# -> Int# -> Int# -> (# Int# , Int#, Int# #) diff --git a/testsuite/tests/ffi/should_fail/ccfail002.stderr b/testsuite/tests/ffi/should_fail/ccfail002.stderr new file mode 100644 index 0000000000..dfff4272cd --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail002.stderr @@ -0,0 +1,7 @@ + +ccfail002.hs:10:1: + Unacceptable result type in foreign declaration: + (# Int#, Int#, Int# #) + When checking declaration: + foreign import ccall unsafe "static foo" foo + :: Int# -> Int# -> Int# -> (# Int#, Int#, Int# #) diff --git a/testsuite/tests/ffi/should_fail/ccfail003.hs b/testsuite/tests/ffi/should_fail/ccfail003.hs new file mode 100644 index 0000000000..f16556cb3f --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail003.hs @@ -0,0 +1,11 @@ +{-# LANGUAGE UnliftedFFITypes, MagicHash #-} +-- !!! illegal types in foreign export delarations +module ShouldFail where + +import GHC.Exts + +foreign export ccall foo :: Int# -> IO () +foo i | i ==# 0# = return () + +foreign export ccall bar :: Int -> Int# +bar _ = 42# diff --git a/testsuite/tests/ffi/should_fail/ccfail003.stderr b/testsuite/tests/ffi/should_fail/ccfail003.stderr new file mode 100644 index 0000000000..7933b8c48e --- /dev/null +++ b/testsuite/tests/ffi/should_fail/ccfail003.stderr @@ -0,0 +1,8 @@ + +ccfail003.hs:7:1: + Unacceptable argument type in foreign declaration: Int# + When checking declaration: foreign export ccall "foo" foo :: Int# -> IO () + +ccfail003.hs:10:1: + Unacceptable result type in foreign declaration: Int# + When checking declaration: foreign export ccall "bar" bar :: Int -> Int# diff --git a/testsuite/tests/ffi/should_run/1288.hs b/testsuite/tests/ffi/should_run/1288.hs new file mode 100644 index 0000000000..8b3a8f8417 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288.hs @@ -0,0 +1,6 @@ +import Foreign
+import Foreign.C
+
+foreign import stdcall "test" ctest :: CInt -> IO ()
+
+main = ctest 3
diff --git a/testsuite/tests/ffi/should_run/1288.stdout b/testsuite/tests/ffi/should_run/1288.stdout new file mode 100644 index 0000000000..ef6be0406e --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288.stdout @@ -0,0 +1 @@ +The argument passed was 3 diff --git a/testsuite/tests/ffi/should_run/1288_c.c b/testsuite/tests/ffi/should_run/1288_c.c new file mode 100644 index 0000000000..f240d29529 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288_c.c @@ -0,0 +1,6 @@ +#include <stdio.h>
+
+void __attribute__((stdcall)) test(int arg)
+{
+ printf("The argument passed was %i\n", arg );
+}
diff --git a/testsuite/tests/ffi/should_run/1288_ghci.hs b/testsuite/tests/ffi/should_run/1288_ghci.hs new file mode 100644 index 0000000000..8b3a8f8417 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288_ghci.hs @@ -0,0 +1,6 @@ +import Foreign
+import Foreign.C
+
+foreign import stdcall "test" ctest :: CInt -> IO ()
+
+main = ctest 3
diff --git a/testsuite/tests/ffi/should_run/1288_ghci.stdout b/testsuite/tests/ffi/should_run/1288_ghci.stdout new file mode 100644 index 0000000000..ef6be0406e --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288_ghci.stdout @@ -0,0 +1 @@ +The argument passed was 3 diff --git a/testsuite/tests/ffi/should_run/1288_ghci_c.c b/testsuite/tests/ffi/should_run/1288_ghci_c.c new file mode 100644 index 0000000000..f240d29529 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1288_ghci_c.c @@ -0,0 +1,6 @@ +#include <stdio.h>
+
+void __attribute__((stdcall)) test(int arg)
+{
+ printf("The argument passed was %i\n", arg );
+}
diff --git a/testsuite/tests/ffi/should_run/1679.hs b/testsuite/tests/ffi/should_run/1679.hs new file mode 100644 index 0000000000..15f8630004 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1679.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +import System.Mem +import Foreign +import Control.Exception + +-- Test for #1679. If there's a GC during a foreign call, the +-- interpreter could sometimes crash, because it was using the old +-- pointer to the byte code instructions, which has now moved. The +-- tricky bit is allocating enough so that the old instructions are +-- overwritten, hence performGC followed by sum [1..100000]. + +foreign import ccall "wrapper" mkF :: IO () -> IO (FunPtr (IO ())) +foreign import ccall "dynamic" call_F :: FunPtr (IO ()) -> IO () + +main = do + fun <- mkF (do performGC + print (sum [1..100000])) + call_F fun + putStrLn "ok" diff --git a/testsuite/tests/ffi/should_run/1679.stdout b/testsuite/tests/ffi/should_run/1679.stdout new file mode 100644 index 0000000000..ad2afa7c36 --- /dev/null +++ b/testsuite/tests/ffi/should_run/1679.stdout @@ -0,0 +1,2 @@ +5000050000 +ok diff --git a/testsuite/tests/ffi/should_run/2276.hs b/testsuite/tests/ffi/should_run/2276.hs new file mode 100644 index 0000000000..0ee1ee91ff --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276.hs @@ -0,0 +1,7 @@ +import Foreign
+import Foreign.C
+
+foreign import stdcall "&test" ptest :: FunPtr (CInt -> IO ())
+foreign import stdcall "dynamic" ctest :: FunPtr (CInt -> IO ()) -> CInt -> IO ()
+
+main = ctest ptest 3
diff --git a/testsuite/tests/ffi/should_run/2276.stdout b/testsuite/tests/ffi/should_run/2276.stdout new file mode 100644 index 0000000000..ef6be0406e --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276.stdout @@ -0,0 +1 @@ +The argument passed was 3 diff --git a/testsuite/tests/ffi/should_run/2276_c.c b/testsuite/tests/ffi/should_run/2276_c.c new file mode 100644 index 0000000000..f240d29529 --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276_c.c @@ -0,0 +1,6 @@ +#include <stdio.h>
+
+void __attribute__((stdcall)) test(int arg)
+{
+ printf("The argument passed was %i\n", arg );
+}
diff --git a/testsuite/tests/ffi/should_run/2276_ghci.hs b/testsuite/tests/ffi/should_run/2276_ghci.hs new file mode 100644 index 0000000000..0ee1ee91ff --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276_ghci.hs @@ -0,0 +1,7 @@ +import Foreign
+import Foreign.C
+
+foreign import stdcall "&test" ptest :: FunPtr (CInt -> IO ())
+foreign import stdcall "dynamic" ctest :: FunPtr (CInt -> IO ()) -> CInt -> IO ()
+
+main = ctest ptest 3
diff --git a/testsuite/tests/ffi/should_run/2276_ghci.stdout b/testsuite/tests/ffi/should_run/2276_ghci.stdout new file mode 100644 index 0000000000..ef6be0406e --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276_ghci.stdout @@ -0,0 +1 @@ +The argument passed was 3 diff --git a/testsuite/tests/ffi/should_run/2276_ghci_c.c b/testsuite/tests/ffi/should_run/2276_ghci_c.c new file mode 100644 index 0000000000..f240d29529 --- /dev/null +++ b/testsuite/tests/ffi/should_run/2276_ghci_c.c @@ -0,0 +1,6 @@ +#include <stdio.h>
+
+void __attribute__((stdcall)) test(int arg)
+{
+ printf("The argument passed was %i\n", arg );
+}
diff --git a/testsuite/tests/ffi/should_run/2469.hs b/testsuite/tests/ffi/should_run/2469.hs new file mode 100644 index 0000000000..dc68ad73bf --- /dev/null +++ b/testsuite/tests/ffi/should_run/2469.hs @@ -0,0 +1,15 @@ +import Foreign +import Foreign.C + +type IOF = Int -> IO Int + +foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) +foreign import ccall "dynamic" f_io :: FunPtr IOF -> IOF + +double_io :: Int -> IO Int +double_io x = return (x * 2) + +main = do + double2 <- wrap_f_io double_io + x <- f_io double2 42 + return () diff --git a/testsuite/tests/ffi/should_run/2594.hs b/testsuite/tests/ffi/should_run/2594.hs new file mode 100644 index 0000000000..cdfcfc71fd --- /dev/null +++ b/testsuite/tests/ffi/should_run/2594.hs @@ -0,0 +1,38 @@ +{-# options -fffi #-} + +import Foreign +import Foreign.C.Types + +main = do + wprint <- wrap8 print + call8 wprint + wprint <- wrap16 print + call16 wprint + wprint <- wrap32 print + call32 wprint + wprint <- wrap64 print + call64 wprint + +foreign import ccall "wrapper" + wrap8 :: (Int8 -> IO ()) -> IO (FunPtr (Int8 -> IO ())) + +foreign import ccall "FunPtrBug.h call8" + call8 :: FunPtr (Int8 -> IO ()) -> IO () + +foreign import ccall "wrapper" + wrap16 :: (Int16 -> IO ()) -> IO (FunPtr (Int16 -> IO ())) + +foreign import ccall "FunPtrBug.h call16" + call16 :: FunPtr (Int16 -> IO ()) -> IO () + +foreign import ccall "wrapper" + wrap32 :: (Int32 -> IO ()) -> IO (FunPtr (Int32 -> IO ())) + +foreign import ccall "FunPtrBug.h call32" + call32 :: FunPtr (Int32 -> IO ()) -> IO () + +foreign import ccall "wrapper" + wrap64 :: (Int64 -> IO ()) -> IO (FunPtr (Int64 -> IO ())) + +foreign import ccall "FunPtrBug.h call64" + call64 :: FunPtr (Int64 -> IO ()) -> IO () diff --git a/testsuite/tests/ffi/should_run/2594.stdout b/testsuite/tests/ffi/should_run/2594.stdout new file mode 100644 index 0000000000..bfb2cfef51 --- /dev/null +++ b/testsuite/tests/ffi/should_run/2594.stdout @@ -0,0 +1,4 @@ +-1 +-1 +-1 +-1 diff --git a/testsuite/tests/ffi/should_run/2594_c.c b/testsuite/tests/ffi/should_run/2594_c.c new file mode 100644 index 0000000000..f0dd3007fa --- /dev/null +++ b/testsuite/tests/ffi/should_run/2594_c.c @@ -0,0 +1,7 @@ + +#include "2594_c.h" + +void call8 (funtype8 fun) { fun(-1); } +void call16(funtype16 fun) { fun(-1); } +void call32(funtype32 fun) { fun(-1); } +void call64(funtype64 fun) { fun(-1); } diff --git a/testsuite/tests/ffi/should_run/2594_c.h b/testsuite/tests/ffi/should_run/2594_c.h new file mode 100644 index 0000000000..5847b26662 --- /dev/null +++ b/testsuite/tests/ffi/should_run/2594_c.h @@ -0,0 +1,15 @@ + +#include "HsFFI.h" + +typedef void (* funtype8)(HsInt8); +typedef void (* funtype16)(HsInt16); +typedef void (* funtype32)(HsInt32); +typedef void (* funtype64)(HsInt64); + +void call8(funtype8 fun); +void call16(funtype16 fun); +void call32(funtype32 fun); +void call64(funtype64 fun); + +int cmain(); + diff --git a/testsuite/tests/ffi/should_run/2917a.hs b/testsuite/tests/ffi/should_run/2917a.hs new file mode 100644 index 0000000000..cdfaabcd2a --- /dev/null +++ b/testsuite/tests/ffi/should_run/2917a.hs @@ -0,0 +1,42 @@ +import Foreign +import Control.Monad + +-- check that all pointers returned by allocaBytes and mallocBytes are +-- 16-byte aligned +main = do + sequence [ allocaBytes x $ return | x <- [1..500] ] >>= check 16 + (replicateM 500 (alloca $ return) :: IO [Ptr Align32]) >>= check 32 + (replicateM 500 (alloca $ return) :: IO [Ptr Align64]) >>= check 64 + (replicateM 500 (alloca $ return) :: IO [Ptr Align128]) >>= check 128 + (replicateM 500 (alloca $ return) :: IO [Ptr Align256]) >>= check 256 + -- mapM mallocBytes [1..500] >>= check 16 + +check :: Int -> [Ptr a] -> IO () +check align xs = do + let bad = [ p | p <- xs, (p `minusPtr` nullPtr) .&. (align-1) /= 0 ] + when (not $ null bad) $ + putStrLn ("FAIL: " ++ show align ++ " " ++ show bad) + +data Align32 = Align32 + +instance Storable Align32 where + sizeOf _ = 32 + alignment _ = 32 + +data Align64 = Align64 + +instance Storable Align64 where + sizeOf _ = 64 + alignment _ = 64 + +data Align128 = Align128 + +instance Storable Align128 where + sizeOf _ = 128 + alignment _ = 128 + +data Align256 = Align256 + +instance Storable Align256 where + sizeOf _ = 256 + alignment _ = 256 diff --git a/testsuite/tests/ffi/should_run/4038.hs b/testsuite/tests/ffi/should_run/4038.hs new file mode 100644 index 0000000000..9250fb9082 --- /dev/null +++ b/testsuite/tests/ffi/should_run/4038.hs @@ -0,0 +1,33 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +import Foreign +import Foreign.C + +type IOF = Int -> IO Int + +foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) +foreign import ccall "dynamic" f_io :: FunPtr IOF -> IOF + +-- The value of n needs to be adjusted to avoid overflowing the +-- C stack. n is the number of times the f calls itself, and each +-- C call allocates a bit over 16 kB on a 64 bit processor. +-- (Remember that there is no tail call optimization of foreign functions.) +-- A typical C stack is 8 MB, so n = 400 will allocate about 4.8 MB +-- on a 64 bit system. If you have a 128 bit processor you'll have to +-- reduce it. +-- +-- Under ghci this test segfaults for smaller n, probably +-- because more of the C stack is allocated for other use than +-- when compiled. +-- +-- On *nix systems, the C stack size can be examined and changed by +-- the "ulimit -s" command. +-- +n = 300 + +f :: Int -> IO Int +f 0 = return 42 +f n = do + f' <- wrap_f_io f + f_io f' (n-1) + +main = f n >>= print diff --git a/testsuite/tests/ffi/should_run/4038.stdout b/testsuite/tests/ffi/should_run/4038.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/ffi/should_run/4038.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/ffi/should_run/4221.hs b/testsuite/tests/ffi/should_run/4221.hs new file mode 100644 index 0000000000..eba782e636 --- /dev/null +++ b/testsuite/tests/ffi/should_run/4221.hs @@ -0,0 +1,42 @@ +{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-} +module Main(main) where + +import Foreign.Ptr +import Foreign.ForeignPtr +import Foreign.C + +data FnBlob + +foreign import ccall "&free_fn_blob" free_fn_blob :: FunPtr (Ptr FnBlob -> IO ()) + +foreign import ccall safe "call_fn_blob" call_fn_blob :: Ptr FnBlob -> CDouble -> CDouble + +type DoubleFn = CDouble -> CDouble + +foreign import ccall unsafe "create_fn_blob" create_fn_blob :: FunPtr DoubleFn -> FunPtr (FunPtr DoubleFn -> IO ()) -> IO (Ptr FnBlob) + +foreign import ccall unsafe "&freeHaskellFunctionPtr" free_fun_ptr :: FunPtr (FunPtr DoubleFn -> IO()) + +foreign import ccall "wrapper" wrapDoubleFn :: DoubleFn -> IO (FunPtr DoubleFn) + +createFnBlob :: DoubleFn -> IO (ForeignPtr FnBlob) +createFnBlob dfn = do + dfn_ptr <- wrapDoubleFn dfn + ptr_fnblob <- create_fn_blob dfn_ptr free_fun_ptr + newForeignPtr free_fn_blob ptr_fnblob + +callFnBlob :: ForeignPtr FnBlob -> CDouble -> IO (CDouble) +callFnBlob fnblob d = withForeignPtr fnblob $ + \ptrblob -> return $! call_fn_blob ptrblob d + +main = do + putStrLn "start" + step 0 + putStrLn "done" + +step n | n > 1000 = return () +step n = do + fnBlob <- createFnBlob (+ n) + result <- callFnBlob fnBlob 0 + putStrLn $ "step " ++ show n ++ ": " ++ show result + step (n + 1) diff --git a/testsuite/tests/ffi/should_run/4221.stdout b/testsuite/tests/ffi/should_run/4221.stdout new file mode 100644 index 0000000000..237bd7fc81 --- /dev/null +++ b/testsuite/tests/ffi/should_run/4221.stdout @@ -0,0 +1,1003 @@ +start +step 0.0: 0.0 +step 1.0: 1.0 +step 2.0: 2.0 +step 3.0: 3.0 +step 4.0: 4.0 +step 5.0: 5.0 +step 6.0: 6.0 +step 7.0: 7.0 +step 8.0: 8.0 +step 9.0: 9.0 +step 10.0: 10.0 +step 11.0: 11.0 +step 12.0: 12.0 +step 13.0: 13.0 +step 14.0: 14.0 +step 15.0: 15.0 +step 16.0: 16.0 +step 17.0: 17.0 +step 18.0: 18.0 +step 19.0: 19.0 +step 20.0: 20.0 +step 21.0: 21.0 +step 22.0: 22.0 +step 23.0: 23.0 +step 24.0: 24.0 +step 25.0: 25.0 +step 26.0: 26.0 +step 27.0: 27.0 +step 28.0: 28.0 +step 29.0: 29.0 +step 30.0: 30.0 +step 31.0: 31.0 +step 32.0: 32.0 +step 33.0: 33.0 +step 34.0: 34.0 +step 35.0: 35.0 +step 36.0: 36.0 +step 37.0: 37.0 +step 38.0: 38.0 +step 39.0: 39.0 +step 40.0: 40.0 +step 41.0: 41.0 +step 42.0: 42.0 +step 43.0: 43.0 +step 44.0: 44.0 +step 45.0: 45.0 +step 46.0: 46.0 +step 47.0: 47.0 +step 48.0: 48.0 +step 49.0: 49.0 +step 50.0: 50.0 +step 51.0: 51.0 +step 52.0: 52.0 +step 53.0: 53.0 +step 54.0: 54.0 +step 55.0: 55.0 +step 56.0: 56.0 +step 57.0: 57.0 +step 58.0: 58.0 +step 59.0: 59.0 +step 60.0: 60.0 +step 61.0: 61.0 +step 62.0: 62.0 +step 63.0: 63.0 +step 64.0: 64.0 +step 65.0: 65.0 +step 66.0: 66.0 +step 67.0: 67.0 +step 68.0: 68.0 +step 69.0: 69.0 +step 70.0: 70.0 +step 71.0: 71.0 +step 72.0: 72.0 +step 73.0: 73.0 +step 74.0: 74.0 +step 75.0: 75.0 +step 76.0: 76.0 +step 77.0: 77.0 +step 78.0: 78.0 +step 79.0: 79.0 +step 80.0: 80.0 +step 81.0: 81.0 +step 82.0: 82.0 +step 83.0: 83.0 +step 84.0: 84.0 +step 85.0: 85.0 +step 86.0: 86.0 +step 87.0: 87.0 +step 88.0: 88.0 +step 89.0: 89.0 +step 90.0: 90.0 +step 91.0: 91.0 +step 92.0: 92.0 +step 93.0: 93.0 +step 94.0: 94.0 +step 95.0: 95.0 +step 96.0: 96.0 +step 97.0: 97.0 +step 98.0: 98.0 +step 99.0: 99.0 +step 100.0: 100.0 +step 101.0: 101.0 +step 102.0: 102.0 +step 103.0: 103.0 +step 104.0: 104.0 +step 105.0: 105.0 +step 106.0: 106.0 +step 107.0: 107.0 +step 108.0: 108.0 +step 109.0: 109.0 +step 110.0: 110.0 +step 111.0: 111.0 +step 112.0: 112.0 +step 113.0: 113.0 +step 114.0: 114.0 +step 115.0: 115.0 +step 116.0: 116.0 +step 117.0: 117.0 +step 118.0: 118.0 +step 119.0: 119.0 +step 120.0: 120.0 +step 121.0: 121.0 +step 122.0: 122.0 +step 123.0: 123.0 +step 124.0: 124.0 +step 125.0: 125.0 +step 126.0: 126.0 +step 127.0: 127.0 +step 128.0: 128.0 +step 129.0: 129.0 +step 130.0: 130.0 +step 131.0: 131.0 +step 132.0: 132.0 +step 133.0: 133.0 +step 134.0: 134.0 +step 135.0: 135.0 +step 136.0: 136.0 +step 137.0: 137.0 +step 138.0: 138.0 +step 139.0: 139.0 +step 140.0: 140.0 +step 141.0: 141.0 +step 142.0: 142.0 +step 143.0: 143.0 +step 144.0: 144.0 +step 145.0: 145.0 +step 146.0: 146.0 +step 147.0: 147.0 +step 148.0: 148.0 +step 149.0: 149.0 +step 150.0: 150.0 +step 151.0: 151.0 +step 152.0: 152.0 +step 153.0: 153.0 +step 154.0: 154.0 +step 155.0: 155.0 +step 156.0: 156.0 +step 157.0: 157.0 +step 158.0: 158.0 +step 159.0: 159.0 +step 160.0: 160.0 +step 161.0: 161.0 +step 162.0: 162.0 +step 163.0: 163.0 +step 164.0: 164.0 +step 165.0: 165.0 +step 166.0: 166.0 +step 167.0: 167.0 +step 168.0: 168.0 +step 169.0: 169.0 +step 170.0: 170.0 +step 171.0: 171.0 +step 172.0: 172.0 +step 173.0: 173.0 +step 174.0: 174.0 +step 175.0: 175.0 +step 176.0: 176.0 +step 177.0: 177.0 +step 178.0: 178.0 +step 179.0: 179.0 +step 180.0: 180.0 +step 181.0: 181.0 +step 182.0: 182.0 +step 183.0: 183.0 +step 184.0: 184.0 +step 185.0: 185.0 +step 186.0: 186.0 +step 187.0: 187.0 +step 188.0: 188.0 +step 189.0: 189.0 +step 190.0: 190.0 +step 191.0: 191.0 +step 192.0: 192.0 +step 193.0: 193.0 +step 194.0: 194.0 +step 195.0: 195.0 +step 196.0: 196.0 +step 197.0: 197.0 +step 198.0: 198.0 +step 199.0: 199.0 +step 200.0: 200.0 +step 201.0: 201.0 +step 202.0: 202.0 +step 203.0: 203.0 +step 204.0: 204.0 +step 205.0: 205.0 +step 206.0: 206.0 +step 207.0: 207.0 +step 208.0: 208.0 +step 209.0: 209.0 +step 210.0: 210.0 +step 211.0: 211.0 +step 212.0: 212.0 +step 213.0: 213.0 +step 214.0: 214.0 +step 215.0: 215.0 +step 216.0: 216.0 +step 217.0: 217.0 +step 218.0: 218.0 +step 219.0: 219.0 +step 220.0: 220.0 +step 221.0: 221.0 +step 222.0: 222.0 +step 223.0: 223.0 +step 224.0: 224.0 +step 225.0: 225.0 +step 226.0: 226.0 +step 227.0: 227.0 +step 228.0: 228.0 +step 229.0: 229.0 +step 230.0: 230.0 +step 231.0: 231.0 +step 232.0: 232.0 +step 233.0: 233.0 +step 234.0: 234.0 +step 235.0: 235.0 +step 236.0: 236.0 +step 237.0: 237.0 +step 238.0: 238.0 +step 239.0: 239.0 +step 240.0: 240.0 +step 241.0: 241.0 +step 242.0: 242.0 +step 243.0: 243.0 +step 244.0: 244.0 +step 245.0: 245.0 +step 246.0: 246.0 +step 247.0: 247.0 +step 248.0: 248.0 +step 249.0: 249.0 +step 250.0: 250.0 +step 251.0: 251.0 +step 252.0: 252.0 +step 253.0: 253.0 +step 254.0: 254.0 +step 255.0: 255.0 +step 256.0: 256.0 +step 257.0: 257.0 +step 258.0: 258.0 +step 259.0: 259.0 +step 260.0: 260.0 +step 261.0: 261.0 +step 262.0: 262.0 +step 263.0: 263.0 +step 264.0: 264.0 +step 265.0: 265.0 +step 266.0: 266.0 +step 267.0: 267.0 +step 268.0: 268.0 +step 269.0: 269.0 +step 270.0: 270.0 +step 271.0: 271.0 +step 272.0: 272.0 +step 273.0: 273.0 +step 274.0: 274.0 +step 275.0: 275.0 +step 276.0: 276.0 +step 277.0: 277.0 +step 278.0: 278.0 +step 279.0: 279.0 +step 280.0: 280.0 +step 281.0: 281.0 +step 282.0: 282.0 +step 283.0: 283.0 +step 284.0: 284.0 +step 285.0: 285.0 +step 286.0: 286.0 +step 287.0: 287.0 +step 288.0: 288.0 +step 289.0: 289.0 +step 290.0: 290.0 +step 291.0: 291.0 +step 292.0: 292.0 +step 293.0: 293.0 +step 294.0: 294.0 +step 295.0: 295.0 +step 296.0: 296.0 +step 297.0: 297.0 +step 298.0: 298.0 +step 299.0: 299.0 +step 300.0: 300.0 +step 301.0: 301.0 +step 302.0: 302.0 +step 303.0: 303.0 +step 304.0: 304.0 +step 305.0: 305.0 +step 306.0: 306.0 +step 307.0: 307.0 +step 308.0: 308.0 +step 309.0: 309.0 +step 310.0: 310.0 +step 311.0: 311.0 +step 312.0: 312.0 +step 313.0: 313.0 +step 314.0: 314.0 +step 315.0: 315.0 +step 316.0: 316.0 +step 317.0: 317.0 +step 318.0: 318.0 +step 319.0: 319.0 +step 320.0: 320.0 +step 321.0: 321.0 +step 322.0: 322.0 +step 323.0: 323.0 +step 324.0: 324.0 +step 325.0: 325.0 +step 326.0: 326.0 +step 327.0: 327.0 +step 328.0: 328.0 +step 329.0: 329.0 +step 330.0: 330.0 +step 331.0: 331.0 +step 332.0: 332.0 +step 333.0: 333.0 +step 334.0: 334.0 +step 335.0: 335.0 +step 336.0: 336.0 +step 337.0: 337.0 +step 338.0: 338.0 +step 339.0: 339.0 +step 340.0: 340.0 +step 341.0: 341.0 +step 342.0: 342.0 +step 343.0: 343.0 +step 344.0: 344.0 +step 345.0: 345.0 +step 346.0: 346.0 +step 347.0: 347.0 +step 348.0: 348.0 +step 349.0: 349.0 +step 350.0: 350.0 +step 351.0: 351.0 +step 352.0: 352.0 +step 353.0: 353.0 +step 354.0: 354.0 +step 355.0: 355.0 +step 356.0: 356.0 +step 357.0: 357.0 +step 358.0: 358.0 +step 359.0: 359.0 +step 360.0: 360.0 +step 361.0: 361.0 +step 362.0: 362.0 +step 363.0: 363.0 +step 364.0: 364.0 +step 365.0: 365.0 +step 366.0: 366.0 +step 367.0: 367.0 +step 368.0: 368.0 +step 369.0: 369.0 +step 370.0: 370.0 +step 371.0: 371.0 +step 372.0: 372.0 +step 373.0: 373.0 +step 374.0: 374.0 +step 375.0: 375.0 +step 376.0: 376.0 +step 377.0: 377.0 +step 378.0: 378.0 +step 379.0: 379.0 +step 380.0: 380.0 +step 381.0: 381.0 +step 382.0: 382.0 +step 383.0: 383.0 +step 384.0: 384.0 +step 385.0: 385.0 +step 386.0: 386.0 +step 387.0: 387.0 +step 388.0: 388.0 +step 389.0: 389.0 +step 390.0: 390.0 +step 391.0: 391.0 +step 392.0: 392.0 +step 393.0: 393.0 +step 394.0: 394.0 +step 395.0: 395.0 +step 396.0: 396.0 +step 397.0: 397.0 +step 398.0: 398.0 +step 399.0: 399.0 +step 400.0: 400.0 +step 401.0: 401.0 +step 402.0: 402.0 +step 403.0: 403.0 +step 404.0: 404.0 +step 405.0: 405.0 +step 406.0: 406.0 +step 407.0: 407.0 +step 408.0: 408.0 +step 409.0: 409.0 +step 410.0: 410.0 +step 411.0: 411.0 +step 412.0: 412.0 +step 413.0: 413.0 +step 414.0: 414.0 +step 415.0: 415.0 +step 416.0: 416.0 +step 417.0: 417.0 +step 418.0: 418.0 +step 419.0: 419.0 +step 420.0: 420.0 +step 421.0: 421.0 +step 422.0: 422.0 +step 423.0: 423.0 +step 424.0: 424.0 +step 425.0: 425.0 +step 426.0: 426.0 +step 427.0: 427.0 +step 428.0: 428.0 +step 429.0: 429.0 +step 430.0: 430.0 +step 431.0: 431.0 +step 432.0: 432.0 +step 433.0: 433.0 +step 434.0: 434.0 +step 435.0: 435.0 +step 436.0: 436.0 +step 437.0: 437.0 +step 438.0: 438.0 +step 439.0: 439.0 +step 440.0: 440.0 +step 441.0: 441.0 +step 442.0: 442.0 +step 443.0: 443.0 +step 444.0: 444.0 +step 445.0: 445.0 +step 446.0: 446.0 +step 447.0: 447.0 +step 448.0: 448.0 +step 449.0: 449.0 +step 450.0: 450.0 +step 451.0: 451.0 +step 452.0: 452.0 +step 453.0: 453.0 +step 454.0: 454.0 +step 455.0: 455.0 +step 456.0: 456.0 +step 457.0: 457.0 +step 458.0: 458.0 +step 459.0: 459.0 +step 460.0: 460.0 +step 461.0: 461.0 +step 462.0: 462.0 +step 463.0: 463.0 +step 464.0: 464.0 +step 465.0: 465.0 +step 466.0: 466.0 +step 467.0: 467.0 +step 468.0: 468.0 +step 469.0: 469.0 +step 470.0: 470.0 +step 471.0: 471.0 +step 472.0: 472.0 +step 473.0: 473.0 +step 474.0: 474.0 +step 475.0: 475.0 +step 476.0: 476.0 +step 477.0: 477.0 +step 478.0: 478.0 +step 479.0: 479.0 +step 480.0: 480.0 +step 481.0: 481.0 +step 482.0: 482.0 +step 483.0: 483.0 +step 484.0: 484.0 +step 485.0: 485.0 +step 486.0: 486.0 +step 487.0: 487.0 +step 488.0: 488.0 +step 489.0: 489.0 +step 490.0: 490.0 +step 491.0: 491.0 +step 492.0: 492.0 +step 493.0: 493.0 +step 494.0: 494.0 +step 495.0: 495.0 +step 496.0: 496.0 +step 497.0: 497.0 +step 498.0: 498.0 +step 499.0: 499.0 +step 500.0: 500.0 +step 501.0: 501.0 +step 502.0: 502.0 +step 503.0: 503.0 +step 504.0: 504.0 +step 505.0: 505.0 +step 506.0: 506.0 +step 507.0: 507.0 +step 508.0: 508.0 +step 509.0: 509.0 +step 510.0: 510.0 +step 511.0: 511.0 +step 512.0: 512.0 +step 513.0: 513.0 +step 514.0: 514.0 +step 515.0: 515.0 +step 516.0: 516.0 +step 517.0: 517.0 +step 518.0: 518.0 +step 519.0: 519.0 +step 520.0: 520.0 +step 521.0: 521.0 +step 522.0: 522.0 +step 523.0: 523.0 +step 524.0: 524.0 +step 525.0: 525.0 +step 526.0: 526.0 +step 527.0: 527.0 +step 528.0: 528.0 +step 529.0: 529.0 +step 530.0: 530.0 +step 531.0: 531.0 +step 532.0: 532.0 +step 533.0: 533.0 +step 534.0: 534.0 +step 535.0: 535.0 +step 536.0: 536.0 +step 537.0: 537.0 +step 538.0: 538.0 +step 539.0: 539.0 +step 540.0: 540.0 +step 541.0: 541.0 +step 542.0: 542.0 +step 543.0: 543.0 +step 544.0: 544.0 +step 545.0: 545.0 +step 546.0: 546.0 +step 547.0: 547.0 +step 548.0: 548.0 +step 549.0: 549.0 +step 550.0: 550.0 +step 551.0: 551.0 +step 552.0: 552.0 +step 553.0: 553.0 +step 554.0: 554.0 +step 555.0: 555.0 +step 556.0: 556.0 +step 557.0: 557.0 +step 558.0: 558.0 +step 559.0: 559.0 +step 560.0: 560.0 +step 561.0: 561.0 +step 562.0: 562.0 +step 563.0: 563.0 +step 564.0: 564.0 +step 565.0: 565.0 +step 566.0: 566.0 +step 567.0: 567.0 +step 568.0: 568.0 +step 569.0: 569.0 +step 570.0: 570.0 +step 571.0: 571.0 +step 572.0: 572.0 +step 573.0: 573.0 +step 574.0: 574.0 +step 575.0: 575.0 +step 576.0: 576.0 +step 577.0: 577.0 +step 578.0: 578.0 +step 579.0: 579.0 +step 580.0: 580.0 +step 581.0: 581.0 +step 582.0: 582.0 +step 583.0: 583.0 +step 584.0: 584.0 +step 585.0: 585.0 +step 586.0: 586.0 +step 587.0: 587.0 +step 588.0: 588.0 +step 589.0: 589.0 +step 590.0: 590.0 +step 591.0: 591.0 +step 592.0: 592.0 +step 593.0: 593.0 +step 594.0: 594.0 +step 595.0: 595.0 +step 596.0: 596.0 +step 597.0: 597.0 +step 598.0: 598.0 +step 599.0: 599.0 +step 600.0: 600.0 +step 601.0: 601.0 +step 602.0: 602.0 +step 603.0: 603.0 +step 604.0: 604.0 +step 605.0: 605.0 +step 606.0: 606.0 +step 607.0: 607.0 +step 608.0: 608.0 +step 609.0: 609.0 +step 610.0: 610.0 +step 611.0: 611.0 +step 612.0: 612.0 +step 613.0: 613.0 +step 614.0: 614.0 +step 615.0: 615.0 +step 616.0: 616.0 +step 617.0: 617.0 +step 618.0: 618.0 +step 619.0: 619.0 +step 620.0: 620.0 +step 621.0: 621.0 +step 622.0: 622.0 +step 623.0: 623.0 +step 624.0: 624.0 +step 625.0: 625.0 +step 626.0: 626.0 +step 627.0: 627.0 +step 628.0: 628.0 +step 629.0: 629.0 +step 630.0: 630.0 +step 631.0: 631.0 +step 632.0: 632.0 +step 633.0: 633.0 +step 634.0: 634.0 +step 635.0: 635.0 +step 636.0: 636.0 +step 637.0: 637.0 +step 638.0: 638.0 +step 639.0: 639.0 +step 640.0: 640.0 +step 641.0: 641.0 +step 642.0: 642.0 +step 643.0: 643.0 +step 644.0: 644.0 +step 645.0: 645.0 +step 646.0: 646.0 +step 647.0: 647.0 +step 648.0: 648.0 +step 649.0: 649.0 +step 650.0: 650.0 +step 651.0: 651.0 +step 652.0: 652.0 +step 653.0: 653.0 +step 654.0: 654.0 +step 655.0: 655.0 +step 656.0: 656.0 +step 657.0: 657.0 +step 658.0: 658.0 +step 659.0: 659.0 +step 660.0: 660.0 +step 661.0: 661.0 +step 662.0: 662.0 +step 663.0: 663.0 +step 664.0: 664.0 +step 665.0: 665.0 +step 666.0: 666.0 +step 667.0: 667.0 +step 668.0: 668.0 +step 669.0: 669.0 +step 670.0: 670.0 +step 671.0: 671.0 +step 672.0: 672.0 +step 673.0: 673.0 +step 674.0: 674.0 +step 675.0: 675.0 +step 676.0: 676.0 +step 677.0: 677.0 +step 678.0: 678.0 +step 679.0: 679.0 +step 680.0: 680.0 +step 681.0: 681.0 +step 682.0: 682.0 +step 683.0: 683.0 +step 684.0: 684.0 +step 685.0: 685.0 +step 686.0: 686.0 +step 687.0: 687.0 +step 688.0: 688.0 +step 689.0: 689.0 +step 690.0: 690.0 +step 691.0: 691.0 +step 692.0: 692.0 +step 693.0: 693.0 +step 694.0: 694.0 +step 695.0: 695.0 +step 696.0: 696.0 +step 697.0: 697.0 +step 698.0: 698.0 +step 699.0: 699.0 +step 700.0: 700.0 +step 701.0: 701.0 +step 702.0: 702.0 +step 703.0: 703.0 +step 704.0: 704.0 +step 705.0: 705.0 +step 706.0: 706.0 +step 707.0: 707.0 +step 708.0: 708.0 +step 709.0: 709.0 +step 710.0: 710.0 +step 711.0: 711.0 +step 712.0: 712.0 +step 713.0: 713.0 +step 714.0: 714.0 +step 715.0: 715.0 +step 716.0: 716.0 +step 717.0: 717.0 +step 718.0: 718.0 +step 719.0: 719.0 +step 720.0: 720.0 +step 721.0: 721.0 +step 722.0: 722.0 +step 723.0: 723.0 +step 724.0: 724.0 +step 725.0: 725.0 +step 726.0: 726.0 +step 727.0: 727.0 +step 728.0: 728.0 +step 729.0: 729.0 +step 730.0: 730.0 +step 731.0: 731.0 +step 732.0: 732.0 +step 733.0: 733.0 +step 734.0: 734.0 +step 735.0: 735.0 +step 736.0: 736.0 +step 737.0: 737.0 +step 738.0: 738.0 +step 739.0: 739.0 +step 740.0: 740.0 +step 741.0: 741.0 +step 742.0: 742.0 +step 743.0: 743.0 +step 744.0: 744.0 +step 745.0: 745.0 +step 746.0: 746.0 +step 747.0: 747.0 +step 748.0: 748.0 +step 749.0: 749.0 +step 750.0: 750.0 +step 751.0: 751.0 +step 752.0: 752.0 +step 753.0: 753.0 +step 754.0: 754.0 +step 755.0: 755.0 +step 756.0: 756.0 +step 757.0: 757.0 +step 758.0: 758.0 +step 759.0: 759.0 +step 760.0: 760.0 +step 761.0: 761.0 +step 762.0: 762.0 +step 763.0: 763.0 +step 764.0: 764.0 +step 765.0: 765.0 +step 766.0: 766.0 +step 767.0: 767.0 +step 768.0: 768.0 +step 769.0: 769.0 +step 770.0: 770.0 +step 771.0: 771.0 +step 772.0: 772.0 +step 773.0: 773.0 +step 774.0: 774.0 +step 775.0: 775.0 +step 776.0: 776.0 +step 777.0: 777.0 +step 778.0: 778.0 +step 779.0: 779.0 +step 780.0: 780.0 +step 781.0: 781.0 +step 782.0: 782.0 +step 783.0: 783.0 +step 784.0: 784.0 +step 785.0: 785.0 +step 786.0: 786.0 +step 787.0: 787.0 +step 788.0: 788.0 +step 789.0: 789.0 +step 790.0: 790.0 +step 791.0: 791.0 +step 792.0: 792.0 +step 793.0: 793.0 +step 794.0: 794.0 +step 795.0: 795.0 +step 796.0: 796.0 +step 797.0: 797.0 +step 798.0: 798.0 +step 799.0: 799.0 +step 800.0: 800.0 +step 801.0: 801.0 +step 802.0: 802.0 +step 803.0: 803.0 +step 804.0: 804.0 +step 805.0: 805.0 +step 806.0: 806.0 +step 807.0: 807.0 +step 808.0: 808.0 +step 809.0: 809.0 +step 810.0: 810.0 +step 811.0: 811.0 +step 812.0: 812.0 +step 813.0: 813.0 +step 814.0: 814.0 +step 815.0: 815.0 +step 816.0: 816.0 +step 817.0: 817.0 +step 818.0: 818.0 +step 819.0: 819.0 +step 820.0: 820.0 +step 821.0: 821.0 +step 822.0: 822.0 +step 823.0: 823.0 +step 824.0: 824.0 +step 825.0: 825.0 +step 826.0: 826.0 +step 827.0: 827.0 +step 828.0: 828.0 +step 829.0: 829.0 +step 830.0: 830.0 +step 831.0: 831.0 +step 832.0: 832.0 +step 833.0: 833.0 +step 834.0: 834.0 +step 835.0: 835.0 +step 836.0: 836.0 +step 837.0: 837.0 +step 838.0: 838.0 +step 839.0: 839.0 +step 840.0: 840.0 +step 841.0: 841.0 +step 842.0: 842.0 +step 843.0: 843.0 +step 844.0: 844.0 +step 845.0: 845.0 +step 846.0: 846.0 +step 847.0: 847.0 +step 848.0: 848.0 +step 849.0: 849.0 +step 850.0: 850.0 +step 851.0: 851.0 +step 852.0: 852.0 +step 853.0: 853.0 +step 854.0: 854.0 +step 855.0: 855.0 +step 856.0: 856.0 +step 857.0: 857.0 +step 858.0: 858.0 +step 859.0: 859.0 +step 860.0: 860.0 +step 861.0: 861.0 +step 862.0: 862.0 +step 863.0: 863.0 +step 864.0: 864.0 +step 865.0: 865.0 +step 866.0: 866.0 +step 867.0: 867.0 +step 868.0: 868.0 +step 869.0: 869.0 +step 870.0: 870.0 +step 871.0: 871.0 +step 872.0: 872.0 +step 873.0: 873.0 +step 874.0: 874.0 +step 875.0: 875.0 +step 876.0: 876.0 +step 877.0: 877.0 +step 878.0: 878.0 +step 879.0: 879.0 +step 880.0: 880.0 +step 881.0: 881.0 +step 882.0: 882.0 +step 883.0: 883.0 +step 884.0: 884.0 +step 885.0: 885.0 +step 886.0: 886.0 +step 887.0: 887.0 +step 888.0: 888.0 +step 889.0: 889.0 +step 890.0: 890.0 +step 891.0: 891.0 +step 892.0: 892.0 +step 893.0: 893.0 +step 894.0: 894.0 +step 895.0: 895.0 +step 896.0: 896.0 +step 897.0: 897.0 +step 898.0: 898.0 +step 899.0: 899.0 +step 900.0: 900.0 +step 901.0: 901.0 +step 902.0: 902.0 +step 903.0: 903.0 +step 904.0: 904.0 +step 905.0: 905.0 +step 906.0: 906.0 +step 907.0: 907.0 +step 908.0: 908.0 +step 909.0: 909.0 +step 910.0: 910.0 +step 911.0: 911.0 +step 912.0: 912.0 +step 913.0: 913.0 +step 914.0: 914.0 +step 915.0: 915.0 +step 916.0: 916.0 +step 917.0: 917.0 +step 918.0: 918.0 +step 919.0: 919.0 +step 920.0: 920.0 +step 921.0: 921.0 +step 922.0: 922.0 +step 923.0: 923.0 +step 924.0: 924.0 +step 925.0: 925.0 +step 926.0: 926.0 +step 927.0: 927.0 +step 928.0: 928.0 +step 929.0: 929.0 +step 930.0: 930.0 +step 931.0: 931.0 +step 932.0: 932.0 +step 933.0: 933.0 +step 934.0: 934.0 +step 935.0: 935.0 +step 936.0: 936.0 +step 937.0: 937.0 +step 938.0: 938.0 +step 939.0: 939.0 +step 940.0: 940.0 +step 941.0: 941.0 +step 942.0: 942.0 +step 943.0: 943.0 +step 944.0: 944.0 +step 945.0: 945.0 +step 946.0: 946.0 +step 947.0: 947.0 +step 948.0: 948.0 +step 949.0: 949.0 +step 950.0: 950.0 +step 951.0: 951.0 +step 952.0: 952.0 +step 953.0: 953.0 +step 954.0: 954.0 +step 955.0: 955.0 +step 956.0: 956.0 +step 957.0: 957.0 +step 958.0: 958.0 +step 959.0: 959.0 +step 960.0: 960.0 +step 961.0: 961.0 +step 962.0: 962.0 +step 963.0: 963.0 +step 964.0: 964.0 +step 965.0: 965.0 +step 966.0: 966.0 +step 967.0: 967.0 +step 968.0: 968.0 +step 969.0: 969.0 +step 970.0: 970.0 +step 971.0: 971.0 +step 972.0: 972.0 +step 973.0: 973.0 +step 974.0: 974.0 +step 975.0: 975.0 +step 976.0: 976.0 +step 977.0: 977.0 +step 978.0: 978.0 +step 979.0: 979.0 +step 980.0: 980.0 +step 981.0: 981.0 +step 982.0: 982.0 +step 983.0: 983.0 +step 984.0: 984.0 +step 985.0: 985.0 +step 986.0: 986.0 +step 987.0: 987.0 +step 988.0: 988.0 +step 989.0: 989.0 +step 990.0: 990.0 +step 991.0: 991.0 +step 992.0: 992.0 +step 993.0: 993.0 +step 994.0: 994.0 +step 995.0: 995.0 +step 996.0: 996.0 +step 997.0: 997.0 +step 998.0: 998.0 +step 999.0: 999.0 +step 1000.0: 1000.0 +done diff --git a/testsuite/tests/ffi/should_run/4221_c.c b/testsuite/tests/ffi/should_run/4221_c.c new file mode 100644 index 0000000000..0c5ca228c1 --- /dev/null +++ b/testsuite/tests/ffi/should_run/4221_c.c @@ -0,0 +1,26 @@ +#include<stdio.h> +#include<stdlib.h> + +typedef double (*hs_function_ptr)(double); + +typedef struct { + hs_function_ptr fn; + void (*free_fn)(hs_function_ptr); +} fn_blob; + +fn_blob* create_fn_blob(hs_function_ptr fn, void (*free_fn)(hs_function_ptr)) { + fn_blob* new_blob = malloc(sizeof(fn_blob)); + new_blob->fn = fn; + new_blob->free_fn = free_fn; + return new_blob; +} + +double call_fn_blob(fn_blob* fn_blob, double arg) { + return(fn_blob->fn(arg)); +} + +void free_fn_blob(fn_blob* dead_blob) { + dead_blob->free_fn(dead_blob->fn); + free(dead_blob); +} + diff --git a/testsuite/tests/ffi/should_run/Makefile b/testsuite/tests/ffi/should_run/Makefile new file mode 100644 index 0000000000..c30f5565f4 --- /dev/null +++ b/testsuite/tests/ffi/should_run/Makefile @@ -0,0 +1,15 @@ +TOP=../../.. +include $(TOP)/mk/boilerplate.mk +include $(TOP)/mk/test.mk + +ffi018_ghci_setup : + '$(TEST_HC)' $(TEST_HC_OPTS) -c ffi018_ghci_c.c + +1288_ghci_setup : + '$(TEST_HC)' $(TEST_HC_OPTS) -c 1288_ghci_c.c + +2276_ghci_setup : + '$(TEST_HC)' $(TEST_HC_OPTS) -c 2276_ghci_c.c + +ffi002_setup : + '$(TEST_HC)' $(TEST_HC_OPTS) -c ffi002.hs diff --git a/testsuite/tests/ffi/should_run/all.T b/testsuite/tests/ffi/should_run/all.T new file mode 100644 index 0000000000..434397d065 --- /dev/null +++ b/testsuite/tests/ffi/should_run/all.T @@ -0,0 +1,167 @@ + +# Args to compile_and_run are: +# extra compile flags +# extra run flags +# expected process return value, if not zero + +# Doesn't work with External Core due to __labels +test('fed001', compose(only_compiler_types(['ghc']), + expect_fail_for(['extcore','optextcore'])), + compile_and_run, ['']) + +# Omit GHCi for these two, as they use foreign export +test('ffi001', omit_ways(['ghci']), compile_and_run, ['']) +test('ffi002', [ omit_ways(['ghci']), + extra_clean(['ffi002_c.o']), + compile_cmd_prefix('$MAKE ffi002_setup && ') ], + # The ffi002_setup hack is to ensure that we generate + # ffi002_stub.h before compiling ffi002_c.c, which + # needs it. + compile_and_run, ['ffi002_c.c -no-hs-main']) + +test('ffi003', normal, compile_and_run, ['']) + +# ffi004 calls printf, which is not supported (the FFI spec says that +# calling varargs functions is deprecated). It stopped working in GHC 6.9. +test('ffi004', skip, compile_and_run, ['']) + +# omit prof ways, because this test exits before the RTS has a chance to +# generate profiling info. +# +# On x86, the test suffers from floating-point differences due to the +# use of 80-bit internal precision when using the native code generator. +# +test('ffi005', [ omit_ways(prof_ways), + if_arch('i386', skip), + if_platform('i386-apple-darwin', expect_broken(4105)), + exit_code(3) ], + compile_and_run, ['']) + +# ffi[006-009] don't work with External Core due to non-static-C foreign calls + +test('ffi006', expect_fail_for(['extcore','optextcore']), compile_and_run, ['']) + +# Skip ffi00{7,8} for GHCi. These tests both try to exit or raise an +# error from a foreign export, which shuts down the runtime. When +# GHCi is running, this results in GHCi's main thread also trying to +# shut down, and a race ensues to see who gets to call exit() first. +# Sometimes we end up with the wrong exit code, or get an extra +# 'interrupted' message from the GHCi thread shutting down. + +test('ffi007', compose( omit_ways(['ghci']), + expect_fail_for(['extcore','optextcore']) ), + compile_and_run, ['']) + +test('ffi008', compose(expect_fail_for(['extcore','optextcore']), + compose(exit_code(1), + omit_ways(['ghci']))), + compile_and_run, ['']) + +# On i386, we need -msse2 to get reliable floating point results +maybe_skip = normal +opts = '' +if config.platform.startswith('i386-'): + if config.compiler_type == 'ghc' and \ + version_ge(config.compiler_version, '6.13'): + opts = '-msse2' + else: + maybe_skip = only_ways(['ghci']) + +test('ffi009', [skip_if_fast, expect_fail_for(['extcore','optextcore']), + maybe_skip] ,compile_and_run, [opts]) + +# Doesn't work with External Core due to __labels +test('ffi010', expect_fail_for(['extcore','optextcore']), compile_and_run, ['']) + +test('ffi011', normal, compile_and_run, ['']) + +# The stdcall calling convention works on Windows, and sometimes on +# Linux, and fails everywhhere else. For now, we test only on Windows, +# because it's difficult to discover whether a given Linux supports +# it. + +if config.platform == 'i386-unknown-mingw32': + skip_if_not_windows = normal +else: + skip_if_not_windows = skip + +test('ffi012', skip_if_not_windows, compile_and_run, ['']) + +# Doesn't work with External Core due to __labels +test('ffi013', expect_fail_for(['extcore','optextcore']), compile_and_run, ['']) + +# threaded2 sometimes gives ffi014: Main_dDu: interrupted +test('ffi014', only_ways(['threaded1','threaded2']), compile_and_run, ['ffi014_cbits.c']) + +# GHCi can't handle the separate C file (ToDo: fix this somehow) +test('ffi015', [ omit_ways(['ghci']), extra_clean(['ffi015_cbits.o']) ], + compile_and_run, ['ffi015_cbits.c']) + +# GHCi can't handle foreign import "&" +test('ffi016', omit_ways(['ghci']), compile_and_run, ['']) + +test('ffi017', normal, compile_and_run, ['']) + +test('ffi018', [ omit_ways(['ghci']), extra_clean(['ffi018_c.o']) ], + compile_and_run, ['ffi018_c.c']) + +test('ffi018_ghci', [ only_ways(['ghci']), + cmd_prefix('$MAKE ffi018_ghci_setup && '), + extra_clean(['ffi018_ghci_c.o']) ], + compile_and_run, ['ffi018_ghci_c.o']) + +test('ffi019', normal, compile_and_run, ['']) + +# This one originally failed only GHCi, but doesn't hurt to test all ways. +test('1679', normal, compile_and_run, ['']) + +test('1288', [ omit_ways(['ghci']), + extra_clean(['1288_c.o']) ], + compile_and_run, ['1288_c.c']) +test('1288_ghci', [ only_ways(['ghci']), + cmd_prefix('$MAKE --no-print-directory 1288_ghci_setup && '), + extra_clean(['1288_ghci_c.o']) ], + compile_and_run, ['1288_ghci_c.o']) + +test('2276', [ omit_ways(['ghci']), + extra_clean(['2276_c.o']) ], + compile_and_run, ['2276_c.c']) +test('2276_ghci', [ only_ways(['ghci']), + cmd_prefix('$MAKE --no-print-directory 2276_ghci_setup && '), + extra_clean(['2276_ghci_c.o']) ], + compile_and_run, ['-fobject-code 2276_ghci_c.o']) + +test('2469', normal, compile_and_run, ['-optc-std=gnu99']) + +test('2594', omit_ways(['ghci']), compile_and_run, ['2594_c.c']) + +test('fptr01', [ omit_ways(['ghci']), extra_clean(['fptr01_c.o']) ], + compile_and_run, ['fptr01_c.c']) +test('fptr02', normal, compile_and_run, ['']) + +test('fptrfail01', [ compose(omit_ways(['ghci']), exit_code(1)), + extra_clean(['fptrfail01_c.o']) ], + compile_and_run, ['fptrfail01_c.c']) + +test('2917a', normal, compile_and_run, ['']) + +# omit prof ways, because this test causes the RTS to exit (correctly) +# without generating profiling information. +test('ffi020', [ omit_ways(prof_ways), + exit_code(1) ], compile_and_run, ['']) + + +test('ffi021', normal, compile_and_run, ['']) + +test('ffi022', normal, compile_and_run, ['']) + +if config.platform == 'i386-unknown-mingw32': + # This test needs a larger C stack than we get by default on Windows + flagsFor4038 = ['-optl-Wl,--stack,10485760'] +else: + flagsFor4038 = [''] +test('4038', normal, compile_and_run, flagsFor4038) + +test('4221', [ omit_ways(['ghci']), extra_clean(['4221_c.o']) ], + compile_and_run, ['4221_c.c']) + diff --git a/testsuite/tests/ffi/should_run/fed001.hs b/testsuite/tests/ffi/should_run/fed001.hs new file mode 100644 index 0000000000..a832c58ac4 --- /dev/null +++ b/testsuite/tests/ffi/should_run/fed001.hs @@ -0,0 +1,30 @@ +import Control.Monad +import Foreign +import Foreign.Ptr + +type CInt = Int32 +type CSize = Word32 + +foreign import ccall "wrapper" + mkComparator :: (Ptr Int -> Ptr Int -> IO CInt) + -> IO (Ptr (Ptr Int -> Ptr Int -> IO CInt)) + +foreign import ccall + qsort :: Ptr Int -> CSize -> CSize -> Ptr (Ptr Int -> Ptr Int -> IO CInt) + -> IO () + +compareInts :: Ptr Int -> Ptr Int -> IO CInt +compareInts a1 a2 = do + i1 <- peek a1 + i2 <- peek a2 + return (fromIntegral (i1 - i2 :: Int)) + +main :: IO () +main = do + let values = [ 12, 56, 90, 34, 78 ] :: [Int] + n = length values + buf <- mallocArray n + zipWithM_ (pokeElemOff buf) [ 0 .. ] values + c <- mkComparator compareInts + qsort buf (fromIntegral n) (fromIntegral (sizeOf (head values))) c + mapM (peekElemOff buf) [ 0 .. n-1 ] >>= (print :: [Int] -> IO ()) diff --git a/testsuite/tests/ffi/should_run/fed001.stdout b/testsuite/tests/ffi/should_run/fed001.stdout new file mode 100644 index 0000000000..fb5139007e --- /dev/null +++ b/testsuite/tests/ffi/should_run/fed001.stdout @@ -0,0 +1 @@ +[12,34,56,78,90] diff --git a/testsuite/tests/ffi/should_run/ffi001.hs b/testsuite/tests/ffi/should_run/ffi001.hs new file mode 100644 index 0000000000..864b0bda45 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi001.hs @@ -0,0 +1,19 @@ + + +-- !!! A simple FFI test + +-- This one provoked a bogus renamer error in 4.08.1: +-- panic: tcLookupGlobalValue: <THIS>.PrelIOBase.returnIO{-0B,s-} +-- (the error was actually in DsMonad.dsLookupGlobalValue!) + +module Main where + +import Foreign + +foreign export ccall "gccd" mygcd :: Int -> Int -> Int + +main = putStrLn "No bug" + +mygcd a b = if (a==b) then a + else if (a<b) then mygcd a (b-a) + else mygcd (a-b) a diff --git a/testsuite/tests/ffi/should_run/ffi001.stdout b/testsuite/tests/ffi/should_run/ffi001.stdout new file mode 100644 index 0000000000..695e5e77f1 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi001.stdout @@ -0,0 +1 @@ +No bug diff --git a/testsuite/tests/ffi/should_run/ffi002.hs b/testsuite/tests/ffi/should_run/ffi002.hs new file mode 100644 index 0000000000..0186f32700 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi002.hs @@ -0,0 +1,12 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Foo where + +foreign export ccall foo :: Int -> IO Int + +foo :: Int -> IO Int +foo n = return (length (f n)) + +f :: Int -> [Int] +f 0 = [] +f n = n:(f (n-1)) + diff --git a/testsuite/tests/ffi/should_run/ffi002.stdout b/testsuite/tests/ffi/should_run/ffi002.stdout new file mode 100644 index 0000000000..01ef0d9f4d --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi002.stdout @@ -0,0 +1,5 @@ +2500 +2500 +2500 +2500 +2500 diff --git a/testsuite/tests/ffi/should_run/ffi002_c.c b/testsuite/tests/ffi/should_run/ffi002_c.c new file mode 100644 index 0000000000..1e5edd2424 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi002_c.c @@ -0,0 +1,21 @@ +#include <stdio.h> +#include "ffi002_stub.h" + +#include "RtsAPI.h" + +extern void __stginit_Foo ( void ); + +int main(int argc, char *argv[]) +{ + int i; + + startupHaskell(argc, argv, __stginit_Foo); + + for (i = 0; i < 5; i++) { + printf("%d\n", foo(2500)); + } + + shutdownHaskell(); + + return 0; +} diff --git a/testsuite/tests/ffi/should_run/ffi003.hs b/testsuite/tests/ffi/should_run/ffi003.hs new file mode 100644 index 0000000000..bc291960ec --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi003.hs @@ -0,0 +1,8 @@ +-- !!! Test passing doubles to a ccall + +import Foreign.C + +foreign import ccall unsafe "math.h sin" + c_sin :: CDouble -> IO CDouble + +main = c_sin 1.0 >>= print diff --git a/testsuite/tests/ffi/should_run/ffi003.stdout b/testsuite/tests/ffi/should_run/ffi003.stdout new file mode 100644 index 0000000000..e83a344363 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi003.stdout @@ -0,0 +1 @@ +0.8414709848078965 diff --git a/testsuite/tests/ffi/should_run/ffi004.hs b/testsuite/tests/ffi/should_run/ffi004.hs new file mode 100644 index 0000000000..546cd15068 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi004.hs @@ -0,0 +1,22 @@ +-- !!! Test ccalls with large numbers of arguments + +-- In 0.19, we lost the ability to do ccalls with more than 6 arguments +-- on the Sparc. Just to make sure it never happens again... + +import Foreign.C + +main = + withCString "Testing %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d %d\n" $ \cstr -> + printf cstr + 0 1 2 3 4 5 6 7 8 9 + 10 11 12 13 14 15 16 17 18 19 + 20 21 22 23 24 25 26 27 28 29 + 30 31 32 33 34 35 36 37 38 39 + +foreign import ccall unsafe + printf :: CString + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> IO () diff --git a/testsuite/tests/ffi/should_run/ffi004.stdout b/testsuite/tests/ffi/should_run/ffi004.stdout new file mode 100644 index 0000000000..8cee3bfbb1 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi004.stdout @@ -0,0 +1 @@ +Testing 0 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 diff --git a/testsuite/tests/ffi/should_run/ffi005.hs b/testsuite/tests/ffi/should_run/ffi005.hs new file mode 100644 index 0000000000..63de9558f9 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi005.hs @@ -0,0 +1,111 @@ +-- !!! test for foreign import dynamic/wrapper, orignally by Alastair Reid, +-- with a few changes to get it to run on GHC by Simon Marlow. + +import Foreign hiding ( unsafePerformIO ) +import Foreign.C +import Control.Exception +import System.IO.Unsafe +import Prelude hiding (read) +import System.IO (hFlush, stdout) + +main = do + + putStrLn "\nTesting sin==mysin (should return lots of Trues)" + print (testSin sin mysin) + +-- disabled because errno is not necessarily a label these days + +-- putStrLn "\nTesting errno" +-- err <- peek errno +-- putStrLn $ "errno == " ++ show err + + putStrLn "\nTesting puts (and withString)" + withCString "Test successful" puts + + putStrLn "\nTesting peekArray0" + s <- withCString "Test successful" (peekArray0 (castCharToCChar '\0')) + putStr (map castCCharToChar s) + +-- disabled due to use of non-portable constants in arguments to open: + +-- putStrLn "\nTesting open, read and close" +-- s <- testRead "ffi005.hs" 200 +-- putStrLn (map castCCharToChar s) + +-- putStrLn "\nTesting open, write and close" +-- testWrite "/tmp/test_write" "Test successful" + + putStrLn "\nTesting sin==dynamic_sin (should return lots of Trues)" + print (testSin sin (dyn_sin sin_addr)) + + putStrLn "\nTesting sin==IO wrapped_sin (should return lots of Trues)" + sin_addr2 <- wrapIO (return . sin) + print (testSin sin (unsafePerformIO . (dyn_sinIO sin_addr2))) + freeHaskellFunPtr sin_addr2 + + putStrLn "\nTesting sin==Id wrapped_sin (should return lots of Trues)" + sin_addr3 <- wrapId sin + print (testSin sin (dyn_sin sin_addr3)) + freeHaskellFunPtr sin_addr3 + + putStrLn "\nTesting exit" + hFlush stdout + exit 3 + +testSin f g = [ (f x == g x) | x <- [0,0.01 .. 1] ] + +foreign import ccall "sin" mysin :: CDouble -> CDouble +foreign import ccall "dynamic" dyn_sin :: FunPtr (CDouble -> CDouble) -> (CDouble -> CDouble) +foreign import ccall "dynamic" dyn_sinIO :: FunPtr (CDouble -> IO CDouble) -> (CDouble -> IO CDouble) +foreign import ccall "&sin" sin_addr :: FunPtr (CDouble -> CDouble) +foreign import ccall "wrapper" wrapId :: (CDouble -> CDouble) -> IO (FunPtr (CDouble -> CDouble)) +foreign import ccall "wrapper" wrapIO :: (CDouble -> IO CDouble) -> IO (FunPtr (CDouble -> IO CDouble)) + +-- foreign import ccall safe "static stdlib.h &errno" errno :: Ptr CInt + +withBuffer sz m = do + b <- mallocArray sz + sz' <- m b + s <- peekArray sz' b + free b + return s + +foreign import ccall puts :: CString -> IO CInt + +-- foreign import ccall "open" open' :: CString -> CInt -> IO CInt +-- foreign import ccall "open" open2' :: CString -> CInt -> CInt -> IO CInt +-- foreign import ccall "creat" creat' :: CString -> CInt -> IO CInt +-- foreign import ccall close :: CInt -> IO CInt +-- foreign import ccall "read" read' :: CInt -> CString -> CInt -> IO CInt +-- foreign import ccall "write" write' :: CInt -> CString -> CInt -> IO CInt + +-- creat s m = withCString s $ \s' -> unix "creat" $ creat' s' m +-- open s m = withCString s $ \s' -> unix "open" $ open' s' m +-- open2 s m n = withCString s $ \s' -> unix "open2" $ open2' s' m n +-- write fd s = withCString s $ \s' -> unix "write" $ write' fd s' (fromIntegral (length s)) +-- read fd sz = withBuffer sz $ \s' -> unix "read" $ read' fd s' (fromIntegral sz) + +-- unix s m = do +-- x <- m +-- if x < 0 +-- then do +-- err <- peek errno +-- ioError $ userError $ s ++ ": " ++ show (x,err) +-- else return (fromIntegral x) + +-- testRead fn sz = bracket (open fn 0) close (flip read sz) +-- testWrite fn s = bracket (open2 fn (512+64+1) 511) close (flip write s) + +foreign import ccall exit :: Int -> IO () + +-- Various bits of rubbish. +-- foreign import ccall "static stdlib.h exit" (***) :: CString -> CString -> IO Int +-- +-- foreign import ccall safe "static stdlib.h printf" (+++) :: CString -> CString -> IO Int +-- foreign import ccall safe "static stdlib.h &errno" illegal_foo :: Ptr Int +-- +-- foreign import ccall safe "wrapper" illegal_bar :: Char -> IO (FunCString) +-- foreign import ccall safe "dynamic" illegal_baz :: FunCString -> Char + +-- foreign export ccall "id_charstar" id :: CString -> CString + diff --git a/testsuite/tests/ffi/should_run/ffi005.stdout b/testsuite/tests/ffi/should_run/ffi005.stdout new file mode 100644 index 0000000000..bc0a137514 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi005.stdout @@ -0,0 +1,19 @@ + +Testing sin==mysin (should return lots of Trues) +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] + +Testing puts (and withString) + +Testing peekArray0 +Test successful +Testing sin==dynamic_sin (should return lots of Trues) +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] + +Testing sin==IO wrapped_sin (should return lots of Trues) +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] + +Testing sin==Id wrapped_sin (should return lots of Trues) +[True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True,True] + +Testing exit +Test successful diff --git a/testsuite/tests/ffi/should_run/ffi006.hs b/testsuite/tests/ffi/should_run/ffi006.hs new file mode 100644 index 0000000000..20328e1e9f --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi006.hs @@ -0,0 +1,27 @@ +-- !!! Test that we can call a foreign import "wrapper" using foreign +-- import "dynamic", in both IO and non-IO flavours. + +import Foreign +import Foreign.C + +type IOF = Int -> IO Int +type F = Int -> Int + +foreign import ccall "wrapper" wrap_f :: F -> IO (FunPtr F) +foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) + +foreign import ccall "dynamic" f :: FunPtr F -> F +foreign import ccall "dynamic" f_io :: FunPtr IOF -> IOF + +double :: Int -> Int +double x = x * 2 + +double_io :: Int -> IO Int +double_io x = return (x * 2) + +main = do + double1 <- wrap_f double + print (f double1 42) + double2 <- wrap_f_io double_io + x <- f_io double2 42 + print x diff --git a/testsuite/tests/ffi/should_run/ffi006.stdout b/testsuite/tests/ffi/should_run/ffi006.stdout new file mode 100644 index 0000000000..fece85f608 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi006.stdout @@ -0,0 +1,2 @@ +84 +84 diff --git a/testsuite/tests/ffi/should_run/ffi007.hs b/testsuite/tests/ffi/should_run/ffi007.hs new file mode 100644 index 0000000000..506ec57cd3 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi007.hs @@ -0,0 +1,14 @@ +-- !!! Test System.Exit.exitWith called from a foreign import "wrapper" + +import Foreign +import Foreign.C + +import System.Exit + +type IOF = IO () +foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) +foreign import ccall "dynamic" call_io :: FunPtr IOF -> IOF + +exit = do putStrLn "exiting..."; exitWith ExitSuccess + +main = do f <- wrap_f_io exit; call_io f diff --git a/testsuite/tests/ffi/should_run/ffi007.stdout b/testsuite/tests/ffi/should_run/ffi007.stdout new file mode 100644 index 0000000000..1ca228cda4 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi007.stdout @@ -0,0 +1 @@ +exiting... diff --git a/testsuite/tests/ffi/should_run/ffi008.hs b/testsuite/tests/ffi/should_run/ffi008.hs new file mode 100644 index 0000000000..f065e49855 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi008.hs @@ -0,0 +1,14 @@ +-- !!! Test exceptions in a foreign import "wrapper" + +import Foreign +import Foreign.C + +import System.Exit + +type IOF = IO () +foreign import ccall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) +foreign import ccall "dynamic" call_io :: FunPtr IOF -> IOF + +mk_error = error "this is an error" + +main = do f <- wrap_f_io mk_error; call_io f diff --git a/testsuite/tests/ffi/should_run/ffi008.stderr b/testsuite/tests/ffi/should_run/ffi008.stderr new file mode 100644 index 0000000000..cc538ee68c --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi008.stderr @@ -0,0 +1 @@ +ffi008: this is an error diff --git a/testsuite/tests/ffi/should_run/ffi009.hs b/testsuite/tests/ffi/should_run/ffi009.hs new file mode 100644 index 0000000000..5e91843bb5 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi009.hs @@ -0,0 +1,552 @@ +import Foreign +import System.Random + +-------------------------------------------------------------------------------- + +type FunType5I = Int -> Int -> Int -> Int -> Int -> Int + +foreign import ccall "dynamic" callFun5I :: FunPtr FunType5I -> FunType5I +foreign import ccall "wrapper" mkFun5I :: FunType5I -> IO (FunPtr FunType5I) + +manyArgs5I :: FunType5I +manyArgs5I a1 a2 a3 a4 a5 = (((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5 + +test5I :: IO () +test5I = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + funAddr <- mkFun5I manyArgs5I + print (callFun5I funAddr a1 a2 a3 a4 a5 == + manyArgs5I a1 a2 a3 a4 a5) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunType11D = Double -> Double -> Double -> Double -> Double -> Double + -> Double -> Double -> Double -> Double -> Double -> Double + +foreign import ccall "dynamic" callFun11D :: FunPtr FunType11D -> FunType11D +foreign import ccall "wrapper" mkFun11D :: FunType11D -> IO (FunPtr FunType11D) + +manyArgs11D :: FunType11D +manyArgs11D a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = + ((((a1 * 31 + a2) * 31 + a3) * 31 + a4) * 31 + a5) * 31 + a6 + + a7 + a8 + a9 + a10 + a11 + +test11D :: IO () +test11D = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + funAddr <- mkFun11D manyArgs11D + let x = callFun11D funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 + y = manyArgs11D a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 + if x /= y then + print x >> print y + else + print True + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunType11M = Int -> Double -> Float -> Char -> Bool -> Int -> Float -> Int + -> Char -> Double -> Bool -> Double + +foreign import ccall "dynamic" callFun11M :: FunPtr FunType11M -> FunType11M +foreign import ccall "wrapper" mkFun11M :: FunType11M -> IO (FunPtr FunType11M) + +manyArgs11M :: FunType11M +manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 = + (((((((((fromIntegral a1 * 31 + a2) * 31 + + realToFrac a3) * 31 + fromIntegral (fromEnum a4)) * 31 + + fromIntegral (fromEnum a5)) * 31 + fromIntegral a6) * 31 + + realToFrac a7) * 31 + fromIntegral a8) * 31 + + fromIntegral (fromEnum a9)) * 31 + a10) * 31 + + fromIntegral (fromEnum a11) + +test11M :: IO () +test11M = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + funAddr <- mkFun11M manyArgs11M + print (callFun11M funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 == + manyArgs11M a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM1 = Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM1 :: FunPtr FunTypeM1 -> FunTypeM1 +foreign import ccall "wrapper" mkFunM1 :: FunTypeM1 -> IO (FunPtr FunTypeM1) + +manyArgsM1 :: FunTypeM1 +manyArgsM1 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + (((((((((( a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM1 :: IO () +testM1 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM1 manyArgsM1 + print (callFunM1 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM1 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM2 = Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM2 :: FunPtr FunTypeM2 -> FunTypeM2 +foreign import ccall "wrapper" mkFunM2 :: FunTypeM2 -> IO (FunPtr FunTypeM2) + +manyArgsM2 :: FunTypeM2 +manyArgsM2 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM2 :: IO () +testM2 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM2 manyArgsM2 + print (callFunM2 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM2 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM3 = Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM3 :: FunPtr FunTypeM3 -> FunTypeM3 +foreign import ccall "wrapper" mkFunM3 :: FunTypeM3 -> IO (FunPtr FunTypeM3) + +manyArgsM3 :: FunTypeM3 +manyArgsM3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM3 :: IO () +testM3 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM3 manyArgsM3 + print (callFunM3 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM3 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM4 = Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM4 :: FunPtr FunTypeM4 -> FunTypeM4 +foreign import ccall "wrapper" mkFunM4 :: FunTypeM4 -> IO (FunPtr FunTypeM4) + +manyArgsM4 :: FunTypeM4 +manyArgsM4 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM4 :: IO () +testM4 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM4 manyArgsM4 + print (callFunM4 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM4 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM5 = Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM5 :: FunPtr FunTypeM5 -> FunTypeM5 +foreign import ccall "wrapper" mkFunM5 :: FunTypeM5 -> IO (FunPtr FunTypeM5) + +manyArgsM5 :: FunTypeM5 +manyArgsM5 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM5 :: IO () +testM5 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM5 manyArgsM5 + print (callFunM5 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM5 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM6 = Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM6 :: FunPtr FunTypeM6 -> FunTypeM6 +foreign import ccall "wrapper" mkFunM6 :: FunTypeM6 -> IO (FunPtr FunTypeM6) + +manyArgsM6 :: FunTypeM6 +manyArgsM6 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM6 :: IO () +testM6 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM6 manyArgsM6 + print (callFunM6 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM6 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM7 = Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM7 :: FunPtr FunTypeM7 -> FunTypeM7 +foreign import ccall "wrapper" mkFunM7 :: FunTypeM7 -> IO (FunPtr FunTypeM7) + +manyArgsM7 :: FunTypeM7 +manyArgsM7 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM7 :: IO () +testM7 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM7 manyArgsM7 + print (callFunM7 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM7 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM8 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double -> Int + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM8 :: FunPtr FunTypeM8 -> FunTypeM8 +foreign import ccall "wrapper" mkFunM8 :: FunTypeM8 -> IO (FunPtr FunTypeM8) + +manyArgsM8 :: FunTypeM8 +manyArgsM8 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM8 :: IO () +testM8 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM8 manyArgsM8 + print (callFunM8 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM8 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM9 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Double + -> Int -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM9 :: FunPtr FunTypeM9 -> FunTypeM9 +foreign import ccall "wrapper" mkFunM9 :: FunTypeM9 -> IO (FunPtr FunTypeM9) + +manyArgsM9 :: FunTypeM9 +manyArgsM9 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM9 :: IO () +testM9 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM9 manyArgsM9 + print (callFunM9 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM9 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM10 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Double -> Int -> Int -> Double + +foreign import ccall "dynamic" callFunM10 :: FunPtr FunTypeM10 -> FunTypeM10 +foreign import ccall "wrapper" mkFunM10 :: FunTypeM10 -> IO (FunPtr FunTypeM10) + +manyArgsM10 :: FunTypeM10 +manyArgsM10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + a10) * 31 + + fromIntegral a11) * 31 + fromIntegral a12 + +testM10 :: IO () +testM10 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM10 manyArgsM10 + print (callFunM10 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM10 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM11 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Double -> Int -> Double + +foreign import ccall "dynamic" callFunM11 :: FunPtr FunTypeM11 -> FunTypeM11 +foreign import ccall "wrapper" mkFunM11 :: FunTypeM11 -> IO (FunPtr FunTypeM11) + +manyArgsM11 :: FunTypeM11 +manyArgsM11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + a11) * 31 + fromIntegral a12 + +testM11 :: IO () +testM11 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM11 manyArgsM11 + print (callFunM11 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM11 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +type FunTypeM12 = Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int -> Int + -> Int -> Int -> Double -> Double + +foreign import ccall "dynamic" callFunM12 :: FunPtr FunTypeM12 -> FunTypeM12 +foreign import ccall "wrapper" mkFunM12 :: FunTypeM12 -> IO (FunPtr FunTypeM12) + +manyArgsM12 :: FunTypeM12 +manyArgsM12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 = + ((((((((((fromIntegral a1 * 31 + fromIntegral a2) * 31 + + fromIntegral a3) * 31 + fromIntegral a4) * 31 + + fromIntegral a5) * 31 + fromIntegral a6) * 31 + + fromIntegral a7) * 31 + fromIntegral a8) * 31 + + fromIntegral a9) * 31 + fromIntegral a10) * 31 + + fromIntegral a11) * 31 + a12 + +testM12 :: IO () +testM12 = do + a1 <- randomIO + a2 <- randomIO + a3 <- randomIO + a4 <- randomIO + a5 <- randomIO + a6 <- randomIO + a7 <- randomIO + a8 <- randomIO + a9 <- randomIO + a10 <- randomIO + a11 <- randomIO + a12 <- randomIO + funAddr <- mkFunM12 manyArgsM12 + print (callFunM12 funAddr a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12 == + manyArgsM12 a1 a2 a3 a4 a5 a6 a7 a8 a9 a10 a11 a12) + freeHaskellFunPtr funAddr + +-------------------------------------------------------------------------------- + +rep :: String -> IO () -> IO () +rep msg tst = do + putStrLn ("Testing " ++ msg ++ "...") + sequence_ (replicate 10 tst) + +main :: IO () +main = do + setStdGen (mkStdGen 4711) + rep "5 Int arguments" test5I + rep "11 Double arguments" test11D + rep "11 mixed arguments" test11M + rep "Double as 1st argument, rest Int" testM1 + rep "Double as 2nd argument, rest Int" testM2 + rep "Double as 3rd argument, rest Int" testM3 + rep "Double as 4th argument, rest Int" testM4 + rep "Double as 5th argument, rest Int" testM5 + rep "Double as 6th argument, rest Int" testM6 + rep "Double as 7th argument, rest Int" testM7 + rep "Double as 8th argument, rest Int" testM8 + rep "Double as 9th argument, rest Int" testM9 + rep "Double as 10th argument, rest Int" testM10 + rep "Double as 11th argument, rest Int" testM11 + rep "Double as 12th argument, rest Int" testM12 diff --git a/testsuite/tests/ffi/should_run/ffi009.stdout b/testsuite/tests/ffi/should_run/ffi009.stdout new file mode 100644 index 0000000000..2701fdd909 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi009.stdout @@ -0,0 +1,165 @@ +Testing 5 Int arguments... +True +True +True +True +True +True +True +True +True +True +Testing 11 Double arguments... +True +True +True +True +True +True +True +True +True +True +Testing 11 mixed arguments... +True +True +True +True +True +True +True +True +True +True +Testing Double as 1st argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 2nd argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 3rd argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 4th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 5th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 6th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 7th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 8th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 9th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 10th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 11th argument, rest Int... +True +True +True +True +True +True +True +True +True +True +Testing Double as 12th argument, rest Int... +True +True +True +True +True +True +True +True +True +True diff --git a/testsuite/tests/ffi/should_run/ffi010.hs b/testsuite/tests/ffi/should_run/ffi010.hs new file mode 100644 index 0000000000..b02522dd1f --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi010.hs @@ -0,0 +1,9 @@ +import Foreign + +-- !!! GHC 5.04.2 was missing rts_mkFunPtr, which meant that this example +-- !!! didn't link. + +foreign import ccall "wrapper" + makeHaskellFun :: (FunPtr a -> IO ()) -> IO (FunPtr (FunPtr a -> IO ())) + +main = makeHaskellFun (const (return ())) diff --git a/testsuite/tests/ffi/should_run/ffi011.hs b/testsuite/tests/ffi/should_run/ffi011.hs new file mode 100644 index 0000000000..cfb0ae62a9 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi011.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +-- !!! returning a Bool from a foreign export confused GHCi 6.0.1. + +import Foreign + +foreign import ccall "wrapper" + mkFoo :: (Int -> IO Bool) -> IO (FunPtr (Int -> IO Bool)) + +foo :: Int -> IO Bool +foo x = return (x == 42) + +foreign import ccall "dynamic" + call_foo :: FunPtr (Int -> IO Bool) -> Int -> IO Bool + +main = do + foo_fun <- mkFoo foo + call_foo foo_fun 3 >>= print + call_foo foo_fun 42 >>= print diff --git a/testsuite/tests/ffi/should_run/ffi011.stdout b/testsuite/tests/ffi/should_run/ffi011.stdout new file mode 100644 index 0000000000..91d6f80f27 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi011.stdout @@ -0,0 +1,2 @@ +False +True diff --git a/testsuite/tests/ffi/should_run/ffi012.hs b/testsuite/tests/ffi/should_run/ffi012.hs new file mode 100644 index 0000000000..de101ea769 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi012.hs @@ -0,0 +1,53 @@ +-- !!! Same as ffi006, but using the stdcall calling convention. + +import Foreign +import Foreign.C + +-- With Ints: --------------------------------- + +type IOF = Int -> IO Int +type F = Int -> Int + +foreign import stdcall "wrapper" wrap_f :: F -> IO (FunPtr F) +foreign import stdcall "wrapper" wrap_f_io :: IOF -> IO (FunPtr IOF) + +foreign import stdcall "dynamic" f :: FunPtr F -> F +foreign import stdcall "dynamic" f_io :: FunPtr IOF -> IOF + +fn_int :: Int -> Int +fn_int x = x * 2 + +fn_int_io :: Int -> IO Int +fn_int_io x = return (x * 2) + +-- With Doubles: --------------------------------- + +type IOD = Double -> IO Double +type D = Double -> Double + +foreign import stdcall "wrapper" wrap_d :: D -> IO (FunPtr D) +foreign import stdcall "wrapper" wrap_d_io :: IOD -> IO (FunPtr IOD) + +foreign import stdcall "dynamic" d :: FunPtr D -> D +foreign import stdcall "dynamic" d_io :: FunPtr IOD -> IOD + +fn_double :: Double -> Double +fn_double x = x * 2 + +fn_double_io :: Double -> IO Double +fn_double_io x = return (x * 2) + +-------------------------------------------------- + +main = do + wrapped_fn_int <- wrap_f fn_int + print (f wrapped_fn_int 42) + wrapped_fn_int_io <- wrap_f_io fn_int_io + x <- f_io wrapped_fn_int_io 42 + print x + + wrapped_fn_double <- wrap_d fn_double + print (d wrapped_fn_double 42) + wrapped_fn_double_io <- wrap_d_io fn_double_io + x <- d_io wrapped_fn_double_io 42 + print x diff --git a/testsuite/tests/ffi/should_run/ffi012.stdout b/testsuite/tests/ffi/should_run/ffi012.stdout new file mode 100644 index 0000000000..b384fe2adf --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi012.stdout @@ -0,0 +1,4 @@ +84
+84
+84.0
+84.0
diff --git a/testsuite/tests/ffi/should_run/ffi013.hs b/testsuite/tests/ffi/should_run/ffi013.hs new file mode 100644 index 0000000000..ae38c71b10 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi013.hs @@ -0,0 +1,26 @@ +import Foreign +import Foreign.C.Types + +foreign import ccall "wrapper" + mkComparator :: (Ptr Int -> Ptr Int -> IO CInt) + -> IO (FunPtr (Ptr Int -> Ptr Int -> IO CInt)) + +foreign import ccall + qsort :: Ptr Int -> CSize -> CSize -> FunPtr (Ptr Int -> Ptr Int -> IO CInt) + -> IO () + +compareInts :: Ptr Int -> Ptr Int -> IO CInt +compareInts a1 a2 = do + i1 <- peek a1 + i2 <- peek a2 + return (fromIntegral (i1 - i2 :: Int)) + +main :: IO () +main = do + c <- mkComparator compareInts + let values = [ 12, 56, 90, 34, 78 ] :: [Int] + n = length values + withArray values $ \ buf -> do + qsort buf (fromIntegral n) (fromIntegral (sizeOf (head values))) c + values' <- peekArray n buf + print values' diff --git a/testsuite/tests/ffi/should_run/ffi013.stdout b/testsuite/tests/ffi/should_run/ffi013.stdout new file mode 100644 index 0000000000..fb5139007e --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi013.stdout @@ -0,0 +1 @@ +[12,34,56,78,90] diff --git a/testsuite/tests/ffi/should_run/ffi014.hs b/testsuite/tests/ffi/should_run/ffi014.hs new file mode 100644 index 0000000000..4434bef21a --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi014.hs @@ -0,0 +1,29 @@ +-- exposed a bug in GHC 6.4 threaded RTS, fixed in Schedule.c rev. 1.232
+
+module Main where
+
+import Control.Concurrent
+import Control.Monad
+import Foreign.Ptr
+import Data.IORef
+
+main = do
+ ms <- replicateM 100 $ do putStrLn "."
+ m <- newEmptyMVar
+ forkOS (thread >> putMVar m ())
+ thread
+ return m
+ mapM takeMVar ms
+
+thread = do var <- newIORef 0
+ let f = modifyIORef var (1+)
+ callC =<< mkFunc f
+
+type FUNC = IO ()
+
+foreign import ccall unsafe "wrapper"
+ mkFunc :: FUNC -> IO (FunPtr FUNC)
+
+foreign import ccall safe "ffi014_cbits.h callC"
+ callC:: FunPtr FUNC -> IO ()
+
diff --git a/testsuite/tests/ffi/should_run/ffi014.stdout b/testsuite/tests/ffi/should_run/ffi014.stdout new file mode 100644 index 0000000000..e53a095ac8 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi014.stdout @@ -0,0 +1,100 @@ +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. +. diff --git a/testsuite/tests/ffi/should_run/ffi014_cbits.c b/testsuite/tests/ffi/should_run/ffi014_cbits.c new file mode 100644 index 0000000000..0cf96d5dc6 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi014_cbits.c @@ -0,0 +1,6 @@ +#include "ffi014_cbits.h"
+
+void callC( FUNC* f) {
+ int i;
+ for(i=0;i<1000;i++) f();
+}
diff --git a/testsuite/tests/ffi/should_run/ffi014_cbits.h b/testsuite/tests/ffi/should_run/ffi014_cbits.h new file mode 100644 index 0000000000..d0d8517ca5 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi014_cbits.h @@ -0,0 +1,3 @@ +typedef void FUNC();
+
+void callC( FUNC* f);
diff --git a/testsuite/tests/ffi/should_run/ffi015.hs b/testsuite/tests/ffi/should_run/ffi015.hs new file mode 100644 index 0000000000..c70220fa4a --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi015.hs @@ -0,0 +1,12 @@ +{-# OPTIONS_GHC -#include "ffi015_cbits.h" #-} +{-# LANGUAGE ForeignFunctionInterface #-} + +import Foreign +import Foreign.C + +foreign import ccall "&var" var :: Ptr CInt + +main = do + x <- peek var + print x + diff --git a/testsuite/tests/ffi/should_run/ffi015.stdout b/testsuite/tests/ffi/should_run/ffi015.stdout new file mode 100644 index 0000000000..d81cc0710e --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi015.stdout @@ -0,0 +1 @@ +42 diff --git a/testsuite/tests/ffi/should_run/ffi015_cbits.c b/testsuite/tests/ffi/should_run/ffi015_cbits.c new file mode 100644 index 0000000000..f71b82d569 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi015_cbits.c @@ -0,0 +1 @@ +int var = 42; diff --git a/testsuite/tests/ffi/should_run/ffi015_cbits.h b/testsuite/tests/ffi/should_run/ffi015_cbits.h new file mode 100644 index 0000000000..bc4ad6becd --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi015_cbits.h @@ -0,0 +1 @@ +extern int var; diff --git a/testsuite/tests/ffi/should_run/ffi016.hs b/testsuite/tests/ffi/should_run/ffi016.hs new file mode 100644 index 0000000000..0be6f31d7a --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi016.hs @@ -0,0 +1,28 @@ +-- Tests Foreign.Concurrent finalizers + +import Text.Printf +import Foreign.Concurrent as Conc +import Foreign +import GHC.TopHandler +import Control.Concurrent +import Data.List +import System.Mem + +-- This finalizer calls back into Haskell, so we can't use +-- the ordinary newForeignPtr. +foreign export ccall fin :: Ptr Int -> Ptr Int -> IO () +foreign import ccall "fin" finptr :: Ptr Int -> Ptr Int -> IO () + +fin :: Ptr Int -> Ptr Int -> IO () +fin envp ap = runIO $ do + env <- peek envp + a <- peek ap + printf "%d %d\n" env a + return () + +main = do + a <- new (55 :: Int) + env <- new (66 :: Int) + fp <- Conc.newForeignPtr a (finptr env a) + performGC + threadDelay 100000 diff --git a/testsuite/tests/ffi/should_run/ffi016.stdout b/testsuite/tests/ffi/should_run/ffi016.stdout new file mode 100644 index 0000000000..74b7c6f766 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi016.stdout @@ -0,0 +1 @@ +66 55 diff --git a/testsuite/tests/ffi/should_run/ffi017.hs b/testsuite/tests/ffi/should_run/ffi017.hs new file mode 100644 index 0000000000..de9a1c4295 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi017.hs @@ -0,0 +1,13 @@ + +-- Test for trac #953 + +module Main where + +import System.Posix.Types +import Foreign.C + +foreign import ccall safe "unistd.h lseek" foo :: CInt -> COff -> CInt -> IO COff + +main :: IO () +main = return () + diff --git a/testsuite/tests/ffi/should_run/ffi018.h b/testsuite/tests/ffi/should_run/ffi018.h new file mode 100644 index 0000000000..88f67c518d --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018.h @@ -0,0 +1,4 @@ +#include "HsFFI.h" + +HsInt64 f(void); + diff --git a/testsuite/tests/ffi/should_run/ffi018.hs b/testsuite/tests/ffi/should_run/ffi018.hs new file mode 100644 index 0000000000..c529ea87e6 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018.hs @@ -0,0 +1,10 @@ + +import Data.Int + +main :: IO () +main = do x <- f + print (x == 0x123456789ABCDEF0) + +foreign import ccall "ffi018.h f" + f :: IO Int64 + diff --git a/testsuite/tests/ffi/should_run/ffi018.stdout b/testsuite/tests/ffi/should_run/ffi018.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/ffi/should_run/ffi018_c.c b/testsuite/tests/ffi/should_run/ffi018_c.c new file mode 100644 index 0000000000..0d918184d5 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018_c.c @@ -0,0 +1,7 @@ + +#include "ffi018.h" + +HsInt64 f(void) { + return 0x123456789ABCDEF0LL; +} + diff --git a/testsuite/tests/ffi/should_run/ffi018_ghci.h b/testsuite/tests/ffi/should_run/ffi018_ghci.h new file mode 100644 index 0000000000..88f67c518d --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018_ghci.h @@ -0,0 +1,4 @@ +#include "HsFFI.h" + +HsInt64 f(void); + diff --git a/testsuite/tests/ffi/should_run/ffi018_ghci.hs b/testsuite/tests/ffi/should_run/ffi018_ghci.hs new file mode 100644 index 0000000000..c529ea87e6 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018_ghci.hs @@ -0,0 +1,10 @@ + +import Data.Int + +main :: IO () +main = do x <- f + print (x == 0x123456789ABCDEF0) + +foreign import ccall "ffi018.h f" + f :: IO Int64 + diff --git a/testsuite/tests/ffi/should_run/ffi018_ghci.stdout b/testsuite/tests/ffi/should_run/ffi018_ghci.stdout new file mode 100644 index 0000000000..0ca95142bb --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018_ghci.stdout @@ -0,0 +1 @@ +True diff --git a/testsuite/tests/ffi/should_run/ffi018_ghci_c.c b/testsuite/tests/ffi/should_run/ffi018_ghci_c.c new file mode 100644 index 0000000000..0d918184d5 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi018_ghci_c.c @@ -0,0 +1,7 @@ + +#include "ffi018.h" + +HsInt64 f(void) { + return 0x123456789ABCDEF0LL; +} + diff --git a/testsuite/tests/ffi/should_run/ffi019.hs b/testsuite/tests/ffi/should_run/ffi019.hs new file mode 100644 index 0000000000..2b317d8e09 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi019.hs @@ -0,0 +1,28 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +module Main where + +-- Test for #1648 + +import Foreign +import Data.Int +import Data.Word + +f :: Int64 -> IO Int64 +f x = return $ x + 1 + +g :: Word64 -> IO Word64 +g x = return $ x + 2 + +type WCall = Word64 -> IO Word64 +foreign import ccall "wrapper" mkWCall :: WCall -> IO (FunPtr WCall) +foreign import ccall "dynamic" call_w :: FunPtr WCall -> WCall + +type ICall = Int64 -> IO Int64 +foreign import ccall "wrapper" mkICall :: ICall -> IO (FunPtr ICall) +foreign import ccall "dynamic" call_i :: FunPtr ICall -> ICall + +main = do + fp <- mkICall f + call_i fp 3 >>= print + fp <- mkWCall g + call_w fp 4 >>= print diff --git a/testsuite/tests/ffi/should_run/ffi019.stdout b/testsuite/tests/ffi/should_run/ffi019.stdout new file mode 100644 index 0000000000..cfbeb15fac --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi019.stdout @@ -0,0 +1,2 @@ +4 +6 diff --git a/testsuite/tests/ffi/should_run/ffi020.hs b/testsuite/tests/ffi/should_run/ffi020.hs new file mode 100644 index 0000000000..d2236f5791 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi020.hs @@ -0,0 +1,25 @@ +import Foreign +import Data.Word +import Control.Monad +import System.Mem + +main = do + let finalize p = do + putStrLn ("finalize: " ++ show p) + free p + allocToForeignPtr finalize (mallocBytes 4096) + forever performGC + +allocToForeignPtr :: (Ptr a -> IO ()) -- finalizer + -> IO (Ptr a) -- allocate + -> IO (ForeignPtr a) +allocToForeignPtr fin alloc = do + done <- asFinalizer fin + newForeignPtr done =<< alloc + +asFinalizer :: (Ptr a -> IO ()) -> IO (FinalizerPtr a) +asFinalizer = mkFinalizer +foreign import ccall "wrapper" + mkFinalizer :: (Ptr a -> IO ()) + -> IO (FinalizerPtr a) + diff --git a/testsuite/tests/ffi/should_run/ffi020.stderr b/testsuite/tests/ffi/should_run/ffi020.stderr new file mode 100644 index 0000000000..614dd72f8b --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi020.stderr @@ -0,0 +1,4 @@ +ffi020: error: a C finalizer called back into Haskell. + This was previously allowed, but is disallowed in GHC 6.10.2 and later. + To create finalizers that may call back into Haskell, use + Foreign.Concurrent.newForeignPtr instead of Foreign.newForeignPtr. diff --git a/testsuite/tests/ffi/should_run/ffi021.hs b/testsuite/tests/ffi/should_run/ffi021.hs new file mode 100644 index 0000000000..8f6ce1bf92 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi021.hs @@ -0,0 +1,22 @@ +{-# LANGUAGE ForeignFunctionInterface #-} +import Foreign +import Foreign.C + +-- test for calling functions by importing them by address and then +-- using dynamic calls. In 6.10 and earlier, GHCi rejected the +-- foreign import '&foo' declarations, for no apparently good reason. + +type Malloc = CSize -> IO (Ptr ()) +type Write = CInt -> Ptr CChar -> CSize -> IO CSize + +foreign import ccall unsafe "&malloc" pmalloc:: FunPtr Malloc +foreign import ccall unsafe "dynamic" callMalloc :: FunPtr Malloc -> Malloc + +foreign import ccall unsafe "&write" pwrite:: FunPtr Write +foreign import ccall unsafe "dynamic" callWrite :: FunPtr Write -> Write + +main = do + p <- callMalloc pmalloc 32 + free p + withCStringLen "hello\n" $ \(p,len) -> callWrite pwrite 1 p (fromIntegral len) + return () diff --git a/testsuite/tests/ffi/should_run/ffi021.stdout b/testsuite/tests/ffi/should_run/ffi021.stdout new file mode 100644 index 0000000000..ce01362503 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi021.stdout @@ -0,0 +1 @@ +hello diff --git a/testsuite/tests/ffi/should_run/ffi022.hs b/testsuite/tests/ffi/should_run/ffi022.hs new file mode 100644 index 0000000000..5313f7183e --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi022.hs @@ -0,0 +1,36 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +import Foreign.C +import Foreign + +getProgName :: IO String +getProgName = + alloca $ \ p_argc -> + alloca $ \ p_argv -> do + getProgArgv p_argc p_argv + argv <- peek p_argv + unpackProgName argv + +unpackProgName :: Ptr (Ptr CChar) -> IO String -- argv[0] +unpackProgName argv = do + s <- peekElemOff argv 0 >>= peekCString + return (basename s) + where + basename :: String -> String + basename f = go f f + where + go acc [] = acc + go acc (x:xs) + | isPathSeparator x = go xs xs + | otherwise = go acc xs + + isPathSeparator :: Char -> Bool + isPathSeparator '/' = True + isPathSeparator '\\' = True + isPathSeparator _ = False + +foreign import ccall unsafe "getProgArgv" + getProgArgv :: Ptr CInt -> Ptr (Ptr CString) -> IO () + +main :: IO () +main = print =<< getProgName diff --git a/testsuite/tests/ffi/should_run/ffi022.stdout b/testsuite/tests/ffi/should_run/ffi022.stdout new file mode 100644 index 0000000000..fa5f27d449 --- /dev/null +++ b/testsuite/tests/ffi/should_run/ffi022.stdout @@ -0,0 +1 @@ +"ffi022" diff --git a/testsuite/tests/ffi/should_run/fptr01.h b/testsuite/tests/ffi/should_run/fptr01.h new file mode 100644 index 0000000000..b50cc41776 --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptr01.h @@ -0,0 +1,10 @@ +#ifndef FPTR01_H_INCLUDED +#define FPTR01_H_INCLUDED + +void f( HsInt * ); +void g( HsInt * ); +void h( HsInt * ); + +void f_env( HsInt *, HsInt * ); + +#endif // FPTR01_H_INCLUDED diff --git a/testsuite/tests/ffi/should_run/fptr01.hs b/testsuite/tests/ffi/should_run/fptr01.hs new file mode 100644 index 0000000000..1d20a48e14 --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptr01.hs @@ -0,0 +1,40 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign + +{-# INCLUDE "fptr01.h" #-} + +foreign import ccall "&f" fptr :: FunPtr (Ptr Int -> IO ()) +foreign import ccall "&g" gptr :: FunPtr (Ptr Int -> IO ()) +foreign import ccall "&h" hptr :: FunPtr (Ptr Int -> IO ()) + +foreign import ccall "&f_env" fenvptr :: FunPtr (Ptr Int -> Ptr Int -> IO ()) + +main :: IO () +main = do + with (33 :: Int) ((>>= finalizeForeignPtr) . test) + with (34 :: Int) ((>> return ()) . test) + with (35 :: Int) ((>>= finalizeForeignPtr) . test_env) + with (36 :: Int) ((>> return ()) . test_env) + -- finalizers must all be run at program exit. + where + -- the finalizers must be run in the correct order, starting with + -- the most recently-added. + test p = do + f <- newForeignPtr_ p + addForeignPtrFinalizer fptr f + addForeignPtrFinalizer gptr f + addForeignPtrFinalizer hptr f + return f + + test_env p = do + f <- newForeignPtr_ p + envp1 <- new 1 + envp2 <- new 2 + envp3 <- new 3 + addForeignPtrFinalizerEnv fenvptr envp1 f + addForeignPtrFinalizerEnv fenvptr envp2 f + addForeignPtrFinalizerEnv fenvptr envp3 f + return f diff --git a/testsuite/tests/ffi/should_run/fptr01.stdout b/testsuite/tests/ffi/should_run/fptr01.stdout new file mode 100644 index 0000000000..71ba93cc9f --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptr01.stdout @@ -0,0 +1,12 @@ +h33 +g33 +f33 +f_env 3 35 +f_env 2 35 +f_env 1 35 +f_env 3 36 +f_env 2 36 +f_env 1 36 +h34 +g34 +f34 diff --git a/testsuite/tests/ffi/should_run/fptr01_c.c b/testsuite/tests/ffi/should_run/fptr01_c.c new file mode 100644 index 0000000000..0a0e1efe1c --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptr01_c.c @@ -0,0 +1,29 @@ +#include <stdio.h> + +#include "HsFFI.h" + +#include "fptr01.h" + +void f( HsInt *i ) +{ + printf( "f%d\n", (int)*i ); + fflush( stdout ); +} + +void g( HsInt *i ) +{ + printf( "g%d\n", (int)*i ); + fflush( stdout ); +} + +void h( HsInt *i ) +{ + printf( "h%d\n", (int)*i ); + fflush( stdout ); +} + +void f_env( HsInt *env, HsInt *i ) +{ + printf( "f_env %d %d\n", *env, (int)*i ); + fflush( stdout ); +} diff --git a/testsuite/tests/ffi/should_run/fptr02.hs b/testsuite/tests/ffi/should_run/fptr02.hs new file mode 100644 index 0000000000..4691427c3e --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptr02.hs @@ -0,0 +1,10 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign +import Control.Monad + +foreign import ccall "&free" pfree :: FunPtr (Ptr a -> IO ()) + +main = replicateM_ 1000000 $ newForeignPtr pfree nullPtr diff --git a/testsuite/tests/ffi/should_run/fptrfail01.h b/testsuite/tests/ffi/should_run/fptrfail01.h new file mode 100644 index 0000000000..3e10d8bd7a --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptrfail01.h @@ -0,0 +1,6 @@ +#ifndef FPTRFAIL01_H_INCLUDED +#define FPTRFAIL01_H_INCLUDED + +void f( HsInt * ); + +#endif // FPTRFAIL01_H_INCLUDED diff --git a/testsuite/tests/ffi/should_run/fptrfail01.hs b/testsuite/tests/ffi/should_run/fptrfail01.hs new file mode 100644 index 0000000000..97b331e96b --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptrfail01.hs @@ -0,0 +1,19 @@ +{-# LANGUAGE ForeignFunctionInterface #-} + +module Main where + +import Foreign +import GHC.ForeignPtr + +{-# INCLUDE "fptrfail01.h" #-} + +foreign import ccall "&f" fptr :: FunPtr (Ptr Int -> IO ()) + +main :: IO () +main = do + with (33 :: Int) test + where + test p = do + f <- newForeignPtr_ p + addForeignPtrFinalizer fptr f + addForeignPtrConcFinalizer f (putStrLn "Haskell finalizer") diff --git a/testsuite/tests/ffi/should_run/fptrfail01.stderr b/testsuite/tests/ffi/should_run/fptrfail01.stderr new file mode 100644 index 0000000000..db50b2e01b --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptrfail01.stderr @@ -0,0 +1 @@ +fptrfail01: GHC.ForeignPtr: attempt to mix Haskell and C finalizers in the same ForeignPtr diff --git a/testsuite/tests/ffi/should_run/fptrfail01.stdout b/testsuite/tests/ffi/should_run/fptrfail01.stdout new file mode 100644 index 0000000000..e396748a4e --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptrfail01.stdout @@ -0,0 +1 @@ +f33 diff --git a/testsuite/tests/ffi/should_run/fptrfail01_c.c b/testsuite/tests/ffi/should_run/fptrfail01_c.c new file mode 100644 index 0000000000..070a786e57 --- /dev/null +++ b/testsuite/tests/ffi/should_run/fptrfail01_c.c @@ -0,0 +1,11 @@ +#include <stdio.h> + +#include "HsFFI.h" + +#include "fptrfail01.h" + +void f( HsInt *i ) +{ + printf( "f%d\n", (int)*i ); + fflush( stdout ); +} |