summaryrefslogtreecommitdiff
path: root/testsuite/tests/ffi/should_run/4221.hs
diff options
context:
space:
mode:
authorDavid Terei <davidterei@gmail.com>2011-07-20 11:09:03 -0700
committerDavid Terei <davidterei@gmail.com>2011-07-20 11:26:35 -0700
commit16514f272fb42af6e9c7674a9bd6c9dce369231f (patch)
treee4f332b45fe65e2a7a2451be5674f887b42bf199 /testsuite/tests/ffi/should_run/4221.hs
parentebd422aed41048476aa61dd4c520d43becd78682 (diff)
downloadhaskell-16514f272fb42af6e9c7674a9bd6c9dce369231f.tar.gz
Move tests from tests/ghc-regress/* to just tests/*
Diffstat (limited to 'testsuite/tests/ffi/should_run/4221.hs')
-rw-r--r--testsuite/tests/ffi/should_run/4221.hs42
1 files changed, 42 insertions, 0 deletions
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)