Fix this test to work properly with -threaded
[ghc.git] / testsuite / tests / ghc-regress / concurrent / should_run / conc040.hs
1 {-# OPTIONS -fffi #-}
2
3 import Foreign
4 import Data.IORef
5 import Control.Concurrent
6 import Control.Exception
7
8 foreign import ccall "wrapper"
9 wrap :: IO () -> IO (FunPtr (IO ()))
10
11 foreign import ccall "dynamic"
12 invoke :: FunPtr (IO ()) -> IO ()
13
14 {-# NOINLINE m #-}
15 m :: IORef ThreadId
16 m = unsafePerformIO (newIORef (error "m"))
17
18 main = do
19 id <- myThreadId
20 writeIORef m id
21 raise' <- wrap raise
22 invoke raise'
23
24 raise = do
25 id <- readIORef m
26 me <- myThreadId
27 forkIO $ do threadDelay 10000; throwTo me (ErrorCall "timeout")
28 throwTo id (ErrorCall "kapow!")