blob: 6cd18388ed3d0afff9231e0184552e935a8fb46e (
plain)
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
|
{-# LANGUAGE CPP,ForeignFunctionInterface,InterruptibleFFI #-}
module Main where
import Control.Concurrent
import Control.Exception
import Foreign
import System.IO
#if defined(mingw32_HOST_OS)
sleep n = sleepBlock (n*1000)
foreign import stdcall interruptible "Sleep" sleepBlock :: Int -> IO ()
#else
sleep n = sleepBlock n
foreign import ccall interruptible "sleep" sleepBlock :: Int -> IO ()
#endif
main :: IO ()
main = do
newStablePtr stdout -- prevent stdout being finalized
th <- newEmptyMVar
tid <- forkIO $ do
putStrLn "newThread started"
(sleep 2 >> putStrLn "fail") `catch` (\ThreadKilled -> putStrLn "pass")
putMVar th "child"
-- if the killThread below gets blocked for more than a second, then
-- this thread will kill the main thread and the test will fail.
main <- myThreadId
forkIO $ do threadDelay 1000000; throwTo main (ErrorCall "still waiting")
yield
threadDelay 500000
killThread tid
x <- takeMVar th
putStrLn x
putStrLn "\nshutting down"
|
