Ticket #2554: Test2.hs

File Test2.hs, 961 bytes (added by judah, 6 years ago)

Alternate file to reproduce the error

Line 
1{-# LANGUAGE ForeignFunctionInterface #-}
2module Main where
3
4import Control.Concurrent
5import Control.Concurrent.MVar
6import Control.Monad
7
8import System.Posix.IO
9import System.Posix.Signals
10
11import Foreign.C
12import Foreign.Ptr
13
14main = do
15    put <- mkCallback testFunc
16    callFunc put
17    forkAndKill
18    callFunc put
19    freeHaskellFunPtr put
20
21-- fork a thread, and kill it before it's finished
22forkAndKill :: IO ()
23forkAndKill = do
24    mv <- newEmptyMVar
25    let handler = putMVar mv Nothing
26    installHandler sigINT (CatchOnce handler) Nothing
27    tid <- forkIO $ getChar >>= putMVar mv . Just
28    putStrLn "Enter a character, or press ctrl-c."
29    c <- takeMVar mv
30    when (c == Nothing) $ killThread tid
31    putStrLn $ "Result:" ++ show c
32
33testFunc :: FuncCall
34testFunc = return ()
35       
36type FuncCall = IO ()
37
38foreign import ccall "wrapper" mkCallback :: FuncCall -> IO (FunPtr FuncCall)
39
40foreign import ccall callFunc :: FunPtr FuncCall -> IO ()
41