Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Newer
Older
100644 70 lines (58 sloc) 1.957 kb
6d591e24 »
2010-01-21 Added a new benchmark for threadDelay
1 {-# LANGUAGE CPP #-}
2
3 -- Benchmark 'threadDelay' by forking N threads which sleep for a
4 -- number of milliseconds and wait for them all to finish.
5
ef6ec773 »
2010-01-21 Take the number of threads from the command line
6 import Args (ljust, parseArgs, positive, theLast)
6d591e24 »
2010-01-21 Added a new benchmark for threadDelay
7 import Control.Concurrent (forkIO)
8 import Control.Concurrent.MVar (newEmptyMVar, putMVar, takeMVar)
9 import Control.Monad (when)
ef6ec773 »
2010-01-21 Take the number of threads from the command line
10 import Data.Function (on)
11 import Data.Monoid (Monoid(..), Last(..))
6d591e24 »
2010-01-21 Added a new benchmark for threadDelay
12 import Data.IORef (atomicModifyIORef, newIORef)
ef6ec773 »
2010-01-21 Take the number of threads from the command line
13 import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
14 import System.Environment (getArgs)
6d591e24 »
2010-01-21 Added a new benchmark for threadDelay
15 import System.Event.Thread (ensureIOManagerIsRunning)
16
17 #if 1
18 import System.Event.Thread (threadDelay)
19 #else
20 import Control.Concurrent (threadDelay)
21 #endif
22
23 main = do
ef6ec773 »
2010-01-21 Take the number of threads from the command line
24 (cfg, _) <- parseArgs defaultConfig defaultOptions =<< getArgs
25 let numThreads = theLast cfgNumThreads cfg
26
6d591e24 »
2010-01-21 Added a new benchmark for threadDelay
27 ensureIOManagerIsRunning
28 done <- newEmptyMVar
29 ref <- newIORef 0
30 let loop :: Int -> IO ()
31 loop i = do
32 when (i < numThreads) $ do
33 forkIO $ do threadDelay 1
34 a <- atomicModifyIORef ref $ \a ->
35 let !b = a+1 in (b,b)
36 when (a == numThreads) $ putMVar done ()
37 loop (i + 1)
38 loop 0
39 takeMVar done
ef6ec773 »
2010-01-21 Take the number of threads from the command line
40
41 ------------------------------------------------------------------------
42 -- Configuration
43
44 data Config = Config {
45 cfgNumThreads :: Last Int
46 }
47
48 defaultConfig :: Config
49 defaultConfig = Config
50 { cfgNumThreads = ljust 1000
51 }
52
53 instance Monoid Config where
54 mempty = Config
55 { cfgNumThreads = mempty
56 }
57
58 mappend a b = Config
59 { cfgNumThreads = app cfgNumThreads a b
60 }
61 where app = on mappend
62
63 defaultOptions :: [OptDescr (IO Config)]
64 defaultOptions = [
65 Option ['n'] ["threads"]
66 (ReqArg (positive "number of threads" $ \n ->
67 mempty { cfgNumThreads = n }) "N")
68 "number of threads"
69 ]
Something went wrong with that request. Please try again.