Ticket #4221: WrapperTest2.hs

{-# LANGUAGE EmptyDataDecls, ForeignFunctionInterface #-}
{-# OPTIONS_GHC -main-is WrapperTest2 #-}
module WrapperTest2(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)