Commit eda8bc6f authored by Simon Marlow's avatar Simon Marlow

Add test program from #1589, with some measurements

parent e435fd4b
{-# OPTIONS_GHC -O2 #-}
-- Program from GHC ticket #1589, to test scaling of the RTS with many threads.
{-
On a 1.86GHz Intel Xeon:
GHC 6.8.3, with -threaded:
$ ./1589 100000 1
Creating pipeline with 100000 processes in it.
Pumping a single message through the pipeline.
Pumping a 1 messages through the pipeline.
n create pump1 pump2 create/n pump1/n pump2/n
s s s us us us
100000 5.951 0.520 0.462 59.51 5.20 4.62
GHC 6.10.1, without -threaded (NB. 10 times more threads):
$ ./1589 1000000 1
Creating pipeline with 1000000 processes in it.
Pumping a single message through the pipeline.
Pumping a 1 messages through the pipeline.
n create pump1 pump2 create/n pump1/n pump2/n
s s s us us us
1000000 4.029 0.915 0.911 4.03 0.91 0.91
GHC 6.10.1, with -threaded:
$ ./1589 1000000 1
Creating pipeline with 1000000 processes in it.
Pumping a single message through the pipeline.
Pumping a 1 messages through the pipeline.
n create pump1 pump2 create/n pump1/n pump2/n
s s s us us us
1000000 4.255 1.071 1.070 4.26 1.07 1.07
In fact these numbers bounce around quite a bit, they aren't accurate
to more than 20\% or so.
-}
import IO
import System.Environment
import System.CPUTime
import Text.Printf
import Control.Monad
import Control.Concurrent
import Control.Concurrent.MVar
type Msg = (Int, String)
nthreadsDefault :: Int
nthreadsDefault = 10000
npumpDefault :: Int
npumpDefault = 100
main :: IO ()
main = do
hSetBuffering stdout NoBuffering
args <- getArgs
let (nthreads, npump) =
case args of
[] -> (nthreadsDefault, npumpDefault)
[arg] -> (read arg, npumpDefault)
[arg1,arg2] -> (read arg1, read arg2)
_ -> error "Use 0, 1, or 2 arguments\n"
printf "Creating pipeline with %d processes in it.\n" nthreads
t1s <- getCPUTimeDouble
s <- newEmptyMVar
e <- createMany nthreads s
t1e <- getCPUTimeDouble
printf "Pumping a single message through the pipeline.\n"
t2s <- getCPUTimeDouble
pump 1 s e "Hello, World!"
t2e <- getCPUTimeDouble
printf "Pumping a %d messages through the pipeline.\n" npump
t3s <- getCPUTimeDouble
pump npump s e "x"
t3e <- getCPUTimeDouble
let ct = t1e - t1s
p1 = t2e - t2s
p2 = t3e - t3s
n = fromIntegral nthreads * 1e-6
p = fromIntegral npump
printf " n create pump1 pump2 create/n pump1/n pump2/n\n"
printf " s s s us us us\n"
printf "%8d %8.3f %8.3f %8.3f %8.2f %8.2f %8.2f\n" nthreads ct p1 p2 (ct/n) (p1/n) (p2/n/p)
pump :: Int -> MVar Msg -> MVar Msg -> String -> IO ()
pump n s e t = do
forkIO $ replicateM_ n $ putMVar s (0, t)
replicateM_ n $ do
msg <- takeMVar e
when (t /= snd msg) $
error "Distorted message"
createMany :: Int -> MVar Msg -> IO (MVar Msg)
createMany 0 v = return v
createMany n v = do
o <- newEmptyMVar
forkIO $ copy v o
createMany (n-1) o
copy :: MVar Msg -> MVar Msg -> IO ()
copy i o = do
(n, v) <- takeMVar i
let n' = n+1
seq n' (putMVar o (n', v))
copy i o
getCPUTimeDouble :: IO Double
getCPUTimeDouble = do
t <- getCPUTime
return $ fromInteger t * 1e-12
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment