ghc/tests/concurrent/should_run/conc010.hs

   1 {-# OPTIONS -fglasgow-exts #-}
   2
   3 module Main where
   4
   5 import Concurrent
   6 import Exception
   7
   8 -- Raise an exception in another thread.  We need a lot of synchronisation here:
   9
  10 --   - an MVar for the second thread to block on which it waits for the
  11 --     signal (block)
  12
  13 --   - an MVar to signal the main thread that the second thread is ready to
  14 --     accept the signal (ready)
  15
  16 --   - an MVar to signal the main thread that the second thread has received
  17 --     the signal (ready2).  If we don't have this MVar, then the main
  18 --     thread could exit before the second thread has time to print
  19 --     the result.
  20
  21 main = do
  22   block  <- newEmptyMVar
  23   ready  <- newEmptyMVar
  24   ready2 <- newEmptyMVar
  25   id <- forkIO (Exception.catch (putMVar ready () >> takeMVar block)
  26                 (\e -> putStr (show e) >> putMVar ready2 ()))
  27   takeMVar ready
  28   throwTo id (ErrorCall "hello")
  29   takeMVar ready2