add test for #5611

4 files changed, 38 insertions, 0 deletions

diff --git a/testsuite/tests/concurrent/should_run/5611.hs b/testsuite/tests/concurrent/should_run/5611.hs
new file mode 100644
index 0000000000..e46859d27c
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/5611.hs
@@ -0,0 +1,34 @@
+{-# LANGUAGE CPP,ForeignFunctionInterface #-}
+
+import Control.Concurrent
+import Foreign.C
+import System.IO
+
+#ifdef mingw32_HOST_OS
+sleep n = sleepBlock (n*1000)
+foreign import stdcall unsafe "Sleep" sleepBlock :: Int -> IO ()
+#else
+sleep n = sleepBlock n
+foreign import ccall unsafe "sleep" sleepBlock :: Int -> IO ()
+#endif
+
+main :: IO ()
+main = do
+     hSetBuffering stdout LineBuffering
+
+     tid <- forkIO $ do
+         putStrLn "child: Sleeping"
+         _ <- sleep 1
+
+         -- The following lines should not happen after the killThread from the
+         -- parent thread completes.  However, they do...
+         -- putStrLn "child: Done sleeping"
+         threadDelay 100000
+         putStrLn "child: Done waiting"
+
+     threadDelay 100000
+     -- putStrLn $ "parent: Throwing exception to thread " ++ show tid
+     throwTo tid $ userError "Exception delivered successfully"
+     putStrLn "parent: Done throwing exception"
+
+     threadDelay 200000
diff --git a/testsuite/tests/concurrent/should_run/5611.stderr b/testsuite/tests/concurrent/should_run/5611.stderr
new file mode 100644
index 0000000000..7a7f2c7acc
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/5611.stderr
@@ -0,0 +1 @@
+5611: user error (Exception delivered successfully)
diff --git a/testsuite/tests/concurrent/should_run/5611.stdout b/testsuite/tests/concurrent/should_run/5611.stdout
new file mode 100644
index 0000000000..cf4f0d2827
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/5611.stdout
@@ -0,0 +1,2 @@
+child: Sleeping
+parent: Done throwing exception
diff --git a/testsuite/tests/concurrent/should_run/all.T b/testsuite/tests/concurrent/should_run/all.T
index 7c93439b18..ccef92de5c 100644
--- a/testsuite/tests/concurrent/should_run/all.T
+++ b/testsuite/tests/concurrent/should_run/all.T
@@ -66,6 +66,7 @@ test('5558',
      compile_and_run, [''])
 
 test('5421', normal, compile_and_run, [''])
+test('5611', normal, compile_and_run, [''])
 
 # -----------------------------------------------------------------------------
 # These tests we only do for a full run