1 files changed, 31 insertions, 0 deletions
diff --git a/testsuite/tests/concurrent/should_run/allocLimit4.hs b/testsuite/tests/concurrent/should_run/allocLimit4.hs
new file mode 100644
index 0000000000..b589ffa4af
--- /dev/null
+++ b/testsuite/tests/concurrent/should_run/allocLimit4.hs
@@ -0,0 +1,31 @@
+module Main (main) where
+
+import GHC.Conc
+import Control.Concurrent
+import Control.Exception
+import System.Exit
+import Control.Monad
+
+-- check that +RTS -xq is doing the right thing: the test requires
+-- +RTS -xq300k
+
+main = do
+  m <- newEmptyMVar
+  let action = do
+         e <- try $ do
+          setAllocationCounter (10*1024)
+          enableAllocationLimit
+          print (length [1..])
+         case e of
+           Left AllocationLimitExceeded{} -> do
+             c <- getAllocationCounter
+             when (c < 250*1024 || c > 350*1024) $ fail "wrong limit grace"
+             print (length [2..])
+           Right _ ->
+             fail "didn't catch AllocationLimitExceeded"
+
+  forkFinally action (putMVar m)
+  r <- takeMVar m
+  case r of
+    Left e | Just AllocationLimitExceeded <- fromException e -> return ()
+    _ -> print r >> exitFailure