Ticket #4221: WrapperTest2.hs

File WrapperTest2.hs, 1.3 KB (added by ravi_n, 4 years ago)
Line 
1{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}
2{-# OPTIONS_GHC -main-is WrapperTest2 #-}
3module WrapperTest2(main) where
4
5import Foreign.Ptr
6import Foreign.ForeignPtr
7import Foreign.C
8
9data FnBlob
10
11foreign import ccall "&free_fn_blob" free_fn_blob :: FunPtr (Ptr FnBlob -> IO ())
12
13foreign import ccall safe "call_fn_blob" call_fn_blob :: Ptr FnBlob -> CDouble -> CDouble
14
15type DoubleFn = CDouble -> CDouble
16
17foreign import ccall unsafe "create_fn_blob" create_fn_blob :: FunPtr DoubleFn -> FunPtr (FunPtr DoubleFn -> IO ()) -> IO (Ptr FnBlob)
18
19foreign import ccall unsafe "&freeHaskellFunctionPtr" free_fun_ptr :: FunPtr (FunPtr DoubleFn -> IO())
20
21foreign import ccall "wrapper" wrapDoubleFn :: DoubleFn -> IO (FunPtr DoubleFn)
22
23createFnBlob :: DoubleFn -> IO (ForeignPtr FnBlob)
24createFnBlob dfn = do
25  dfn_ptr <- wrapDoubleFn dfn
26  ptr_fnblob <- create_fn_blob dfn_ptr free_fun_ptr
27  newForeignPtr free_fn_blob ptr_fnblob
28
29callFnBlob :: ForeignPtr FnBlob -> CDouble -> IO (CDouble)
30callFnBlob fnblob d = withForeignPtr fnblob $ 
31                        \ptrblob -> return(call_fn_blob ptrblob d) 
32
33main = do
34  putStrLn "start"
35  step 0
36  putStrLn "done"
37
38step n | n > 1000 = return ()
39step n = do
40  fnBlob <- createFnBlob (+ n)
41  result <- callFnBlob fnBlob 0
42  putStrLn $ "step " ++ show n ++ ": " ++ show result
43  step (n + 1)