7 files changed, 139 insertions, 0 deletions
diff --git a/testsuite/tests/rts/T5644/Conf.hs b/testsuite/tests/rts/T5644/Conf.hs
new file mode 100644
index 0000000000..595f7b5abf
--- /dev/null
+++ b/testsuite/tests/rts/T5644/Conf.hs
@@ -0,0 +1,7 @@
+module Conf where
+
+iTERATIONS :: Int
+iTERATIONS = 1000 * 1000 * 100
+
+bufferSize :: (Num a) => a
+bufferSize = 1024
diff --git a/testsuite/tests/rts/T5644/Makefile b/testsuite/tests/rts/T5644/Makefile
new file mode 100644
index 0000000000..9101fbd40a
--- /dev/null
+++ b/testsuite/tests/rts/T5644/Makefile
@@ -0,0 +1,3 @@
+TOP=../../..
+include $(TOP)/mk/boilerplate.mk
+include $(TOP)/mk/test.mk
diff --git a/testsuite/tests/rts/T5644/ManyQueue.hs b/testsuite/tests/rts/T5644/ManyQueue.hs
new file mode 100644
index 0000000000..d2a6882d6c
--- /dev/null
+++ b/testsuite/tests/rts/T5644/ManyQueue.hs
@@ -0,0 +1,82 @@
+{-# LANGUAGE BangPatterns #-}
+
+module ManyQueue where 
+
+import Control.Concurrent
+import Control.Monad
+
+import Conf
+
+newtype MQueue a = MQueue [MVar a]
+
+newMQueue size = do
+  lst <- replicateM size newEmptyMVar
+  return (MQueue (cycle lst))
+
+writeMQueue :: (MQueue a) -> a -> IO (MQueue a)
+writeMQueue (MQueue (x:xs)) el = do
+  putMVar x el
+  return (MQueue xs)
+
+readMQueue :: (MQueue a) -> IO (MQueue a, a)
+readMQueue (MQueue (x:xs)) = do
+  el <- takeMVar x
+  return ((MQueue xs), el)
+
+testManyQueue'1P1C = do
+  print "Test.ManyQueue.testManyQueue'1P1C"
+  finished <- newEmptyMVar
+
+  mq <- newMQueue bufferSize
+  
+  let 
+--      elements = [0] ++ [1 .. iTERATIONS] -- workaround
+      elements = [0 .. iTERATIONS] -- heap overflow
+      
+      writer _ 0 = putMVar finished ()
+      writer q x = do
+                  q' <- writeMQueue q x
+                  writer q' (x-1)
+
+      writer' _ [] = putMVar finished ()
+      writer' q (x:xs) = do
+                  q' <- writeMQueue q x
+                  writer' q' xs
+
+      reader _ !acc 0 = print acc >> putMVar finished ()
+      reader q !acc n = do
+                  (q', x) <- readMQueue q
+                  reader q' (acc+x) (n-1)
+  
+  --forkIO $ writer mq iTERATIONS
+  forkIO $ writer' mq elements
+  forkIO $ reader mq 0 iTERATIONS
+
+  takeMVar finished
+  takeMVar finished
+
+testManyQueue'1P3C = do
+  print "Test.ManyQueue.testManyQueue'1P3C"
+  let tCount = 3
+  finished <- newEmptyMVar
+
+  mqs <- replicateM tCount (newMQueue bufferSize)
+  
+  let elements = [0 .. iTERATIONS]
+      
+      writer _ [] = putMVar finished ()
+      writer qs (x:xs) = do
+                  qs' <- mapM (\q -> writeMQueue q x) qs
+                  writer qs' xs
+
+      reader _ !acc 0 = print acc >> putMVar finished ()
+      reader q !acc n = do
+                  (q', x) <- readMQueue q
+                  reader q' (acc+x) (n-1)
+  
+  forkIO $ writer mqs elements
+  mapM_ (\ mq -> forkIO $ reader mq 0 iTERATIONS) mqs
+
+  replicateM (tCount+1) (takeMVar finished)
+
+  return ()
+\ No newline at end of file
diff --git a/testsuite/tests/rts/T5644/T5644.stderr b/testsuite/tests/rts/T5644/T5644.stderr
new file mode 100644
index 0000000000..198dceb2bb
--- /dev/null
+++ b/testsuite/tests/rts/T5644/T5644.stderr
@@ -0,0 +1,3 @@
+T5644: Heap exhausted;
+Current maximum heap size is 20971520 bytes (20 MB);
+use `+RTS -M<size>' to increase it.
diff --git a/testsuite/tests/rts/T5644/Util.hs b/testsuite/tests/rts/T5644/Util.hs
new file mode 100644
index 0000000000..b97e55c255
--- /dev/null
+++ b/testsuite/tests/rts/T5644/Util.hs
@@ -0,0 +1,29 @@
+{-# LANGUAGE BangPatterns #-}
+
+module Util where
+
+import Data.Time
+-- import Data.List.Split (splitEvery)
+
+import Conf
+
+timed act = do
+  putStrLn ""
+  t0 <- getCurrentTime
+  !v <- act
+  t1 <- getCurrentTime
+  let td = diffUTCTime t1 t0
+  putStrLn $ "Action time: " ++ show td
+  return (v,td)
+
+splitEvery _ [] = []
+splitEvery n xs = let (lxs,rxs) = splitAt n xs in lxs : splitEvery n rxs
+
+runTest :: (IO ()) -> IO ()
+runTest test = do
+  (_, t) <- timed test
+  let format x = unwords . reverse . map reverse . splitEvery 3 . reverse . show $ x
+      val = format (round (fromIntegral iTERATIONS / realToFrac t :: Double) :: Integer)
+
+  putStr "OpsPerSecond: " 
+  putStrLn val
+\ No newline at end of file
diff --git a/testsuite/tests/rts/T5644/all.T b/testsuite/tests/rts/T5644/all.T
new file mode 100644
index 0000000000..4b2332bbc6
--- /dev/null
+++ b/testsuite/tests/rts/T5644/all.T
@@ -0,0 +1,7 @@
+test('T5644', [
+                only_ways(['optasm','threaded1','threaded2']),
+                extra_run_opts('+RTS -M20m -RTS'),
+                exit_code(251) # RTS exit code for "out of memory"
+              ],
+              multimod_compile_and_run,
+              ['heap-overflow.hs','-O'])
diff --git a/testsuite/tests/rts/T5644/heap-overflow.hs b/testsuite/tests/rts/T5644/heap-overflow.hs
new file mode 100644
index 0000000000..1dedc72e2b
--- /dev/null
+++ b/testsuite/tests/rts/T5644/heap-overflow.hs
@@ -0,0 +1,8 @@
+module Main where
+
+import Util
+import ManyQueue
+
+main = do
+  runTest testManyQueue'1P3C 
+  runTest testManyQueue'1P1C