Repository : ssh://darcs.haskell.org//srv/darcs/testsuite On branch : master
http://hackage.haskell.org/trac/ghc/changeset/d57e7bb3ef69be6cf5ee5a665accfb8a1d3cd88e >--------------------------------------------------------------- commit d57e7bb3ef69be6cf5ee5a665accfb8a1d3cd88e Author: Simon Marlow <[email protected]> Date: Mon Nov 21 12:23:41 2011 +0000 add test for #5644 >--------------------------------------------------------------- tests/rts/5644/5644.stderr | 3 + tests/rts/5644/Conf.hs | 7 ++ .../should_compile => rts/5644}/Makefile | 0 tests/rts/5644/ManyQueue.hs | 82 ++++++++++++++++++++ tests/rts/5644/Util.hs | 29 +++++++ tests/rts/5644/all.T | 7 ++ tests/rts/5644/heap-overflow.hs | 8 ++ 7 files changed, 136 insertions(+), 0 deletions(-) diff --git a/tests/rts/5644/5644.stderr b/tests/rts/5644/5644.stderr new file mode 100644 index 0000000..d4f6845 --- /dev/null +++ b/tests/rts/5644/5644.stderr @@ -0,0 +1,3 @@ +Heap exhausted; +Current maximum heap size is 20971520 bytes (20 MB); +use `+RTS -M<size>' to increase it. diff --git a/tests/rts/5644/Conf.hs b/tests/rts/5644/Conf.hs new file mode 100644 index 0000000..595f7b5 --- /dev/null +++ b/tests/rts/5644/Conf.hs @@ -0,0 +1,7 @@ +module Conf where + +iTERATIONS :: Int +iTERATIONS = 1000 * 1000 * 100 + +bufferSize :: (Num a) => a +bufferSize = 1024 diff --git a/tests/annotations/should_compile/Makefile b/tests/rts/5644/Makefile similarity index 100% copy from tests/annotations/should_compile/Makefile copy to tests/rts/5644/Makefile diff --git a/tests/rts/5644/ManyQueue.hs b/tests/rts/5644/ManyQueue.hs new file mode 100644 index 0000000..d2a6882 --- /dev/null +++ b/tests/rts/5644/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/tests/rts/5644/Util.hs b/tests/rts/5644/Util.hs new file mode 100644 index 0000000..b97e55c --- /dev/null +++ b/tests/rts/5644/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/tests/rts/5644/all.T b/tests/rts/5644/all.T new file mode 100644 index 0000000..bd820d5 --- /dev/null +++ b/tests/rts/5644/all.T @@ -0,0 +1,7 @@ +test('5644', [ + 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/tests/rts/5644/heap-overflow.hs b/tests/rts/5644/heap-overflow.hs new file mode 100644 index 0000000..1dedc72 --- /dev/null +++ b/tests/rts/5644/heap-overflow.hs @@ -0,0 +1,8 @@ +module Main where + +import Util +import ManyQueue + +main = do + runTest testManyQueue'1P3C + runTest testManyQueue'1P1C _______________________________________________ Cvs-ghc mailing list [email protected] http://www.haskell.org/mailman/listinfo/cvs-ghc
