[project @ 1999-03-16 13:20:07 by simonm]

[ghc-hetmet.git] / ghc / tests / concurrent / should_run / conc010.hs

diff --git a/ghc/tests/concurrent/should_run/conc010.hs b/ghc/tests/concurrent/should_run/conc010.hs
new file mode 100644 (file)
index 0000000..661b076
--- /dev/null
+++ b/ghc/tests/concurrent/should_run/conc010.hs
@@ -0,0 +1,29 @@
+{-# OPTIONS -fglasgow-exts #-}
+
+module Main where
+
+import Concurrent
+import Exception
+
+-- Raise an exception in another thread.  We need a lot of synchronisation here:
+
+--   - an MVar for the second thread to block on which it waits for the
+--     signal (block)
+
+--   - an MVar to signal the main thread that the second thread is ready to
+--     accept the signal (ready)
+
+--   - an MVar to signal the main thread that the second thread has received
+--     the signal (ready2).  If we don't have this MVar, then the main
+--     thread could exit before the second thread has time to print
+--     the result.
+
+main = do 
+  block  <- newEmptyMVar
+  ready  <- newEmptyMVar
+  ready2 <- newEmptyMVar
+  id <- forkIO (catchAllIO (putMVar ready () >> takeMVar block) 
+               (\e -> putStr (show e) >> putMVar ready2 ()))
+  takeMVar ready
+  raiseInThread id (ErrorCall "hello")
+  takeMVar ready2