Move tests from tests/ghc-regress/* to just tests/*

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)