diff options
author | Simon Marlow <marlowsd@gmail.com> | 2010-07-09 13:04:26 +0000 |
---|---|---|
committer | Simon Marlow <marlowsd@gmail.com> | 2010-07-09 13:04:26 +0000 |
commit | e488e6b7cec7ad6846e29f8bbf051f3762863f3c (patch) | |
tree | cdd195c40a930ebeb719b99d2b0980415e197de2 /testsuite/tests/ghc-regress/concurrent | |
parent | 4f6d4e7b36af73463074260a8f0fe536562832d8 (diff) | |
download | haskell-e488e6b7cec7ad6846e29f8bbf051f3762863f3c.tar.gz |
add/modify tests for new async exceptions API
Diffstat (limited to 'testsuite/tests/ghc-regress/concurrent')
14 files changed, 267 insertions, 0 deletions
diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/2910a.hs b/testsuite/tests/ghc-regress/concurrent/should_run/2910a.hs new file mode 100644 index 0000000000..380c15467d --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/2910a.hs @@ -0,0 +1,9 @@ +import Control.Exception +import GHC.Conc + +main = do + t1 <- mask_ $ forkIO yield + t2 <- forkIO $ killThread t1 + threadDelay 100000 + threadStatus t1 >>= print + threadStatus t2 >>= print diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/2910a.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/2910a.stdout new file mode 100644 index 0000000000..145fced527 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/2910a.stdout @@ -0,0 +1,2 @@ +ThreadFinished +ThreadFinished diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/all.T b/testsuite/tests/ghc-regress/concurrent/should_run/all.T index 1596042f99..deefcd487b 100644 --- a/testsuite/tests/ghc-regress/concurrent/should_run/all.T +++ b/testsuite/tests/ghc-regress/concurrent/should_run/all.T @@ -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, ['']) + diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/async001.hs b/testsuite/tests/ghc-regress/concurrent/should_run/async001.hs new file mode 100644 index 0000000000..7d765e26f9 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/async001.hs @@ -0,0 +1,19 @@ +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)) diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/async001.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/async001.stdout new file mode 100644 index 0000000000..241be4a895 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/async001.stdout @@ -0,0 +1 @@ +main caught: thread killed diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.hs b/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.hs new file mode 100644 index 0000000000..3e97f74434 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.hs @@ -0,0 +1,47 @@ +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 diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.stdout new file mode 100644 index 0000000000..19b98e9b60 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc015a.stdout @@ -0,0 +1,5 @@ +Unmasked +MaskedInterruptible +caught1: foo +MaskedUninterruptible +caught2: bar diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.hs b/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.hs new file mode 100644 index 0000000000..ad015f7413 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.hs @@ -0,0 +1,44 @@ +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 diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.stdout new file mode 100644 index 0000000000..7fca279f26 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc017a.stdout @@ -0,0 +1,2 @@ +caught1: foo +caught3: bar diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.hs b/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.hs new file mode 100644 index 0000000000..5bf619bec1 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.hs @@ -0,0 +1,19 @@ +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) diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.stdout new file mode 100644 index 0000000000..0883f133dc --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/conc069a.stdout @@ -0,0 +1,4 @@ +(False,Unmasked) +(False,MaskedInterruptible) +(True,Unmasked) +(True,MaskedInterruptible) diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/mask001.hs b/testsuite/tests/ghc-regress/concurrent/should_run/mask001.hs new file mode 100644 index 0000000000..96bbf53c73 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/mask001.hs @@ -0,0 +1,70 @@ +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 () diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/mask002.hs b/testsuite/tests/ghc-regress/concurrent/should_run/mask002.hs new file mode 100644 index 0000000000..15b2e64a00 --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/mask002.hs @@ -0,0 +1,32 @@ +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 () + diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/mask002.stdout b/testsuite/tests/ghc-regress/concurrent/should_run/mask002.stdout new file mode 100644 index 0000000000..baa1975a5a --- /dev/null +++ b/testsuite/tests/ghc-regress/concurrent/should_run/mask002.stdout @@ -0,0 +1,2 @@ +thread killed +thread blocked indefinitely in an MVar operation |