Commit e488e6b7 authored by Simon Marlow's avatar Simon Marlow
Browse files

add/modify tests for new async exceptions API

parent 4f6d4e7b
import Control.Exception
import GHC.Conc
main = do
t1 <- mask_ $ forkIO yield
t2 <- forkIO $ killThread t1
threadDelay 100000
threadStatus t1 >>= print
threadStatus t2 >>= print
......@@ -12,12 +12,14 @@ else:
only_threaded_ways = skip
test('conc069', only_threaded_ways, compile_and_run, [''])
test('conc069a', only_threaded_ways, compile_and_run, [''])
# this test gives slightly different results for non-threaded ways, so omit
# those for now.
test('conc070', only_threaded_ways, compile_and_run, [''])
test('1980', normal, compile_and_run, [''])
test('2910', normal, compile_and_run, [''])
test('2910a', normal, compile_and_run, [''])
test('3279', normal, compile_and_run, [''])
# This test takes a long time with the default context switch interval
......@@ -33,6 +35,12 @@ test('throwto001', extra_run_opts('1000 2000'), compile_and_run, [''])
test('throwto002', ignore_output, compile_and_run, [''])
test('throwto003', normal, compile_and_run, [''])
test('mask001', normal, compile_and_run, [''])
# ghci does not generate the BlockedIndefinitely exceptions, so omit:
test('mask002', omit_ways(['ghci']), compile_and_run, [''])
test('async001', normal, compile_and_run, [''])
# -----------------------------------------------------------------------------
# These tests we only do for a full run
......@@ -63,8 +71,10 @@ test('conc013', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc014', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc015', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc015a', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc016', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc017', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc017a', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc018', only_compiler_types(['ghc']), compile_and_run, [''])
test('conc019', compose(only_compiler_types(['ghc']),
extra_run_opts('+RTS -K16m -RTS')),
......@@ -162,3 +172,4 @@ test('conc065', ignore_output, compile_and_run, [''])
test('conc066', ignore_output, compile_and_run, [''])
test('conc067', ignore_output, compile_and_run, [''])
test('conc068', exit_code(1), compile_and_run, [''])
import Control.Exception as E
import Control.Concurrent
import System.IO.Unsafe
-- x is killed during evaluation with an asynchronous exception, but
-- nevertheless gets overwritten with 'throw ThreadKilled' because the
-- async exception is re-thrown as a synchrnonous exception by
-- 'onException'.
main = do
let x = unsafePerformIO $
(do threadDelay 1000000; return 42)
`onException` return ()
t <- forkIO $ do evaluate x; return ()
threadDelay 1000
killThread t
print x `E.catch` \e -> putStrLn ("main caught: " ++ show (e::SomeException))
import Control.Concurrent
import Control.Exception
-- version of conc015 using mask in place of the old deprecated
-- block/unblock.
-- test blocking & unblocking of async exceptions.
-- the first exception "foo" should be caught by the "caught1" handler,
-- since async exceptions are blocked outside this handler.
-- the second exception "bar" should be caught by the outer "caught2" handler,
-- (i.e. this tests that async exceptions are properly unblocked after
-- being blocked).
main = do
main_thread <- myThreadId
print =<< getMaskingState
m <- newEmptyMVar
m2 <- newEmptyMVar
forkIO (do takeMVar m
throwTo main_thread (ErrorCall "foo")
throwTo main_thread (ErrorCall "bar")
putMVar m2 ()
)
( do
mask $ \restore -> do
putMVar m ()
print =<< getMaskingState
sum [1..100000] `seq` -- give 'foo' a chance to be raised
(restore (do print =<< getMaskingState; myDelay 500000))
`Control.Exception.catch`
\e -> putStrLn ("caught1: " ++ show (e::SomeException))
threadDelay 10000
takeMVar m2
)
`Control.Exception.catch`
\e -> do print =<< getMaskingState
putStrLn ("caught2: " ++ show (e::SomeException))
-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
m <- newEmptyMVar
forkIO $ do threadDelay usec; putMVar m ()
takeMVar m
Unmasked
MaskedInterruptible
caught1: foo
MaskedUninterruptible
caught2: bar
import Control.Concurrent
import Control.Exception
-- check that async exceptions are restored to their previous
-- state after an exception is raised and handled.
main = do
main_thread <- myThreadId
m1 <- newEmptyMVar
m2 <- newEmptyMVar
m3 <- newEmptyMVar
forkIO (do
takeMVar m1
throwTo main_thread (ErrorCall "foo")
takeMVar m2
throwTo main_thread (ErrorCall "bar")
putMVar m3 ()
)
(do
mask $ \restore -> do
(do putMVar m1 ()
restore (
-- unblocked, "foo" delivered to "caught1"
myDelay 100000
)
) `Control.Exception.catch`
\e -> putStrLn ("caught1: " ++ show (e::SomeException))
putMVar m2 ()
-- blocked here, "bar" can't be delivered
(sum [1..10000] `seq` return ())
`Control.Exception.catch`
\e -> putStrLn ("caught2: " ++ show (e::SomeException))
-- unblocked here, "bar" delivered to "caught3"
takeMVar m3
)
`Control.Exception.catch`
\e -> putStrLn ("caught3: " ++ show (e::SomeException))
-- compensate for the fact that threadDelay is non-interruptible
-- on Windows with the threaded RTS in 6.6.
myDelay usec = do
m <- newEmptyMVar
forkIO $ do threadDelay usec; putMVar m ()
takeMVar m
import Control.Concurrent
import Control.Exception
main = do
-- stat -- main thread is not bound in GHCi
m <- newEmptyMVar
forkIO (do stat; putMVar m ())
takeMVar m
mask_ $ forkIO (do stat; putMVar m ())
takeMVar m
forkOS (do stat; putMVar m ())
takeMVar m
mask_ $ forkOS (do stat; putMVar m ())
takeMVar m
stat = do
x <- isCurrentThreadBound
y <- getMaskingState
print (x,y)
(False,Unmasked)
(False,MaskedInterruptible)
(True,Unmasked)
(True,MaskedInterruptible)
import Control.Exception
import Text.Printf
-- Test all the various combinations of nesting mask/uninterruptibleMask
main = do
stat 1 Unmasked
mask_ $ stat 2 MaskedInterruptible
mask $ \restore -> do
stat 3 MaskedInterruptible
restore $ stat 4 Unmasked
restore $ restore $ stat 5 Unmasked
stat 6 MaskedInterruptible
uninterruptibleMask $ \restore -> do
stat 7 MaskedUninterruptible
restore $ stat 8 MaskedInterruptible
restore $ restore $ stat 9 MaskedInterruptible
stat 10 MaskedUninterruptible
mask $ \restore -> do
stat 11 MaskedUninterruptible
restore $ stat 12 MaskedUninterruptible
restore $ restore $ stat 13 MaskedUninterruptible
stat 14 MaskedUninterruptible
stat 15 MaskedUninterruptible
stat 16 MaskedInterruptible
stat 17 Unmasked
uninterruptibleMask $ \restore -> do
stat 20 MaskedUninterruptible
restore $ stat 21 Unmasked
restore $ restore $ stat 22 Unmasked
stat 23 MaskedUninterruptible
mask $ \restore -> do
stat 24 MaskedUninterruptible
restore $ stat 25 MaskedUninterruptible
restore $ restore $ stat 26 MaskedUninterruptible
stat 27 MaskedUninterruptible
uninterruptibleMask $ \restore -> do
stat 28 MaskedUninterruptible
restore $ stat 29 MaskedUninterruptible
restore $ restore $ stat 30 MaskedUninterruptible
stat 31 MaskedUninterruptible
stat 32 MaskedUninterruptible
stat 33 MaskedUninterruptible
stat 34 Unmasked
-- it is possible to call a restore from a mask that is not the
-- innermost enclosing one, although this is not a recommended use
-- of the API.
mask $ \restore0 -> do
stat 41 MaskedInterruptible
-- it is possible to call a restore from a mask that is not the
uninterruptibleMask $ \restore1 -> do
stat 42 MaskedUninterruptible
restore0 $ stat 43 Unmasked
restore0 $ restore0 $ stat 44 Unmasked
restore1 $ stat 45 MaskedInterruptible
restore1 $ restore1 $ stat 46 MaskedInterruptible
restore0 $ restore1 $ stat 47 MaskedInterruptible
restore1 $ restore0 $ stat 48 Unmasked
stat 49 MaskedUninterruptible
stat 50 MaskedInterruptible
stat 51 Unmasked
stat :: Int -> MaskingState -> IO ()
stat n m = do
s <- getMaskingState
if (s /= m)
then error (printf "%2d: %s\n" n (show s))
else return ()
import Control.Exception
import Control.Concurrent
import Text.Printf
import Prelude hiding(catch)
-- Test combinations of nesting mask/uninterruptibleMask with
-- forkIO/forkIOUnmask
main = do
m <- newEmptyMVar
t1 <- mask_ $ forkIO $ do
takeMVar m `catch` \e -> do stat 1 MaskedInterruptible
print (e::SomeException)
throwIO e
killThread t1
t2 <- uninterruptibleMask_ $ forkIO $ do
takeMVar m `catch` \e -> do stat 2 MaskedUninterruptible
print (e::SomeException)
throwIO e
killThread t2
t3 <- mask_ $ forkIOUnmasked $ do stat 3 Unmasked; putMVar m ()
takeMVar m
t4 <- uninterruptibleMask_ $ forkIOUnmasked $ do stat 4 Unmasked; putMVar m ()
takeMVar m
stat :: Int -> MaskingState -> IO ()
stat n m = do
s <- getMaskingState
if (s /= m)
then error (printf "%2d: %s\n" n (show s))
else return ()
thread killed
thread blocked indefinitely in an MVar operation
Markdown is supported
0% or .
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment