Add some tortuous throwTo tests

4 files changed, 85 insertions, 0 deletions

diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/all.T b/testsuite/tests/ghc-regress/concurrent/should_run/all.T
index a90b2260c3..122fb385a4 100644
--- a/testsuite/tests/ghc-regress/concurrent/should_run/all.T
+++ b/testsuite/tests/ghc-regress/concurrent/should_run/all.T
@@ -151,3 +151,8 @@ 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, [''])
+
+# each of these runs for about a second
+test('throwto001', extra_run_opts('1000 2000'), compile_and_run, [''])
+test('throwto002', ignore_output, compile_and_run, [''])
+test('throwto003', normal, compile_and_run, [''])
diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/throwto001.hs b/testsuite/tests/ghc-regress/concurrent/should_run/throwto001.hs
new file mode 100644
index 0000000000..999d3335d8
--- /dev/null
+++ b/testsuite/tests/ghc-regress/concurrent/should_run/throwto001.hs
@@ -0,0 +1,38 @@
+import Control.Concurrent
+import Control.Exception
+import Data.Array
+import System.Random
+import System.Environment
+import Control.Monad
+import GHC.Conc
+
+-- A fiendish throwTo test.  A bunch of threads take random MVars from
+-- a shared array; if the MVar has Nothing in it, replace it with Just
+-- of the current thread's ThreadId.  If the MVar has another ThreadId
+-- in it, then killThread that thread, and replace it with the current
+-- thread's ThreadId.  We keep going until only one thread is left
+-- standing.
+--
+-- On multiple CPUs this should give throwTo a good workout.
+--
+main = do
+  [m, t] <- fmap (fmap read) getArgs
+  ms <- replicateM m $ newMVar Nothing
+  let arr = listArray (1,m) ms
+  dead <- newTVarIO 0
+  ts <- replicateM t $ forkIO (thread m arr `onException` 
+                                      (atomically $ do d <- readTVar dead
+                                                       writeTVar dead $! d+1))
+  atomically $ do
+    d <- readTVar dead
+    when (d < t-1) $ retry
+
+thread m arr = do
+  x <- randomIO
+  id <- myThreadId
+  modifyMVar_ (arr ! ((x `mod` m) + 1)) $ \b ->
+    case b of
+      Nothing    -> return (Just id)
+      Just other -> do when (other /= id) $ killThread other
+                       return (Just id)
+  thread m arr
diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/throwto002.hs b/testsuite/tests/ghc-regress/concurrent/should_run/throwto002.hs
new file mode 100644
index 0000000000..c9857f1f1e
--- /dev/null
+++ b/testsuite/tests/ghc-regress/concurrent/should_run/throwto002.hs
@@ -0,0 +1,25 @@
+{-# LANGUAGE DoRec, ScopedTypeVariables #-}
+import Control.Concurrent
+import Control.Exception
+import Data.Array
+import System.Random
+import System.Environment
+import Control.Monad
+import GHC.Conc
+import Data.IORef
+import Prelude hiding (catch)
+
+main = do
+  r <- newIORef 0
+  rec
+    t1 <- block $ forkIO (thread r t2)
+    t2 <- block $ forkIO (thread r t1)
+  threadDelay 1000000
+  readIORef r >>= print
+
+thread r t = run
+  where 
+    run = (unblock $ forever $ do killThread t
+                                  i <- atomicModifyIORef r (\i -> (i + 1, i))
+                                  evaluate i)
+             `catch` \(e::SomeException) -> run
diff --git a/testsuite/tests/ghc-regress/concurrent/should_run/throwto003.hs b/testsuite/tests/ghc-regress/concurrent/should_run/throwto003.hs
new file mode 100644
index 0000000000..6369c62352
--- /dev/null
+++ b/testsuite/tests/ghc-regress/concurrent/should_run/throwto003.hs
@@ -0,0 +1,17 @@
+{-# LANGUAGE DoRec, ScopedTypeVariables #-}
+import Control.Concurrent
+import Control.Exception
+import Control.Monad
+import Prelude hiding (catch)
+
+main = do
+  m <- newMVar 1
+  t1 <- forkIO $ thread m
+  t2 <- forkIO $ forever $ killThread t1
+  threadDelay 1000000
+  takeMVar m
+
+thread m = run
+  where 
+    run = (unblock $ forever $ modifyMVar_ m $ \v -> if v `mod` 2 == 1 then return (v*2) else return (v-1))
+             `catch` \(e::SomeException) -> run