ghc/tests/concurrent/should_run/conc007.hs

   1 {-# OPTIONS -fglasgow-exts #-}
   2
   3 module Main where
   4
   5 import Concurrent
   6 import Exception
   7 import IOExts
   8
   9 choose :: a -> a -> IO a
  10 choose a b = do
  11    ready <- newMVar ()
  12    answer <- newEmptyMVar
  13    a_id <- myForkIO (a `seq` takeMVar ready >> putMVar answer a)
  14    b_id <- myForkIO (b `seq` takeMVar ready >> putMVar answer b)
  15    it <- takeMVar answer
  16    killThread a_id
  17    killThread b_id
  18    return it
  19
  20 -- We need to catch the exception raised by killThread and ignore it.
  21 -- Otherwise the default handler will exit the program when this
  22 -- exception is raised in any thread.
  23
  24 myForkIO :: IO () -> IO ThreadId
  25 myForkIO io = forkIO (Exception.catch io (\e -> return ()))
  26
  27 main = do
  28    let big = sum [1..]
  29        small = sum [1..42]
  30    test1 <- choose big small
  31    test2 <- choose small big
  32    print (test1,test2)