add/modify tests for new async exceptions API

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