ghc/tests/concurrent/should_run/conc017.hs

   1 import Concurrent
   2 import Exception
   3
   4 -- check that async exceptions are restored to their previous
   5 -- state after an exception is raised and handled.
   6
   7 main = do
   8   main_thread <- myThreadId
   9   m1 <- newEmptyMVar
  10   m2 <- newEmptyMVar
  11   m3 <- newEmptyMVar
  12   forkIO (do
  13              takeMVar m1
  14              throwTo main_thread (ErrorCall "foo")
  15              takeMVar m2
  16              throwTo main_thread (ErrorCall "bar")
  17              putMVar m3 ()
  18          )
  19   (do
  20     block (do
  21         (do putMVar m1 ()
  22             unblock (
  23                 -- unblocked, "foo" delivered to "caught1"
  24                threadDelay 100000
  25              )
  26          ) `Exception.catch` (\e -> putStrLn ("caught1: " ++ show e))
  27         putMVar m2 ()
  28         -- blocked here, "bar" can't be delivered
  29         (sum [1..10000] `seq` return ())
  30           `Exception.catch` (\e -> putStrLn ("caught2: " ++ show e))
  31      )
  32     -- unblocked here, "bar" delivered to "caught3"
  33     takeMVar m3
  34    )
  35    `Exception.catch` (\e -> putStrLn ("caught3: " ++ show e))