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              raiseInThread main_thread (ErrorCall "foo")
  15              takeMVar m2
  16              raiseInThread main_thread (ErrorCall "bar")
  17              putMVar m3 ()
  18          )
  19   (do
  20     blockAsyncExceptions (do
  21         (do putMVar m1 ()
  22             unblockAsyncExceptions (
  23                 -- unblocked, "foo" delivered to "caught1"
  24                threadDelay 100000
  25              )
  26          ) `catchAllIO` (\e -> putStrLn ("caught1: " ++ show e))
  27         putMVar m2 ()
  28         -- blocked here, "bar" can't be delivered
  29         (threadDelay 100000)
  30           `catchAllIO` (\e -> putStrLn ("caught2: " ++ show e))
  31      )
  32     -- unblocked here, "bar" delivered to "caught3"
  33     takeMVar m3
  34    )
  35    `catchAllIO` (\e -> putStrLn ("caught3: " ++ show e))