Add test for GHC bug #15136
authorSimon Marlow <marlowsd@gmail.com>
Fri, 13 Jul 2018 09:11:41 +0000 (10:11 +0100)
committerSimon Marlow <marlowsd@gmail.com>
Fri, 13 Jul 2018 09:28:19 +0000 (10:28 +0100)
tests/T15136.hs [new file with mode: 0644]
tests/T15136.stdout [new file with mode: 0644]
tests/all.T

diff --git a/tests/T15136.hs b/tests/T15136.hs
new file mode 100644 (file)
index 0000000..e32f14a
--- /dev/null
@@ -0,0 +1,37 @@
+import Control.Monad
+import Control.Concurrent
+import Control.Concurrent.STM
+import System.IO
+import System.Environment
+
+main :: IO ()
+main = do
+    let volume = 1000
+    hSetBuffering stdout NoBuffering
+    [n] <- fmap read <$> getArgs
+    forM_ [1..(n::Int)] $ \i -> do
+        putStr $ show i ++ " "
+
+        -- Spawn massive number of threads.
+        threads <- replicateM volume $ do
+            trigger <- newTVarIO False
+            tid <- forkIO $ void $ atomically $ do
+                t <- readTVar trigger
+                if t then pure t else retry
+            pure (trigger, tid)
+
+        -- Make sure all threads are spawned.
+        threadDelay 30000
+
+        -- Let threads start to exit normally.
+        forkIO $ forM_ threads $ \(trigger, _) -> threadDelay 1 *> atomically (writeTVar trigger True)
+
+        -- Concurrently kill threads in order to create race.
+        -- TMVar operation and asynchronous exception can hit same thread simultaneously.
+        -- Adjust threadDelay if you don't reproduce very well.
+        threadDelay 1000
+        forM_ threads $ \(_, tid) -> do
+            -- putChar 'A'
+            killThread tid      -- When the issue reproduced, this killThread doesn't return.
+            -- putChar '\b'
+
diff --git a/tests/T15136.stdout b/tests/T15136.stdout
new file mode 100644 (file)
index 0000000..d33e0c6
--- /dev/null
@@ -0,0 +1 @@
+1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 
\ No newline at end of file
index be105ff..c1138fa 100644 (file)
@@ -24,3 +24,5 @@ test('T2411', ignore_stdout, compile_and_run, ['-package stm'])
 test('stm064', normal, compile_and_run, ['-package stm'])
 test('stm065', normal, compile_and_run, ['-package stm'])
 test('cloneTChan001', normal, compile_and_run, ['-package stm'])
+
+test('T15136', extra_run_opts('20'), compile_and_run, ['-package stm'])