/
ThreadDelay.hs
74 lines (63 loc) · 2.01 KB
/
ThreadDelay.hs
1
2
3
4
5
6
7
8
9
10
11
12
13
14
15
16
17
18
19
20
21
22
23
24
25
26
27
28
29
30
31
32
33
34
35
36
37
38
39
40
41
42
43
44
45
46
47
48
49
50
51
52
53
54
55
56
57
58
59
60
61
62
63
64
65
66
67
68
69
70
71
72
73
74
{-# LANGUAGE CPP #-}
-- Benchmark 'threadDelay' by forking N threads which sleep for a
-- number of milliseconds and wait for them all to finish.
import Args (ljust, parseArgs, positive, theLast)
import Control.Concurrent (forkIO, runInUnboundThread)
import Control.Monad (when)
import Data.Function (on)
import Data.Monoid (Monoid(..), Last(..))
import System.Console.GetOpt (ArgDescr(ReqArg), OptDescr(..))
import System.Environment (getArgs)
import System.Event.Thread (ensureIOManagerIsRunning)
import Control.Concurrent.STM
#ifdef USE_GHC_IO_MANAGER
import Control.Concurrent (threadDelay)
#else
import System.Event.Thread (threadDelay)
#endif
main = do
(cfg, _) <- parseArgs defaultConfig defaultOptions =<< getArgs
let numThreads = theLast cfgNumThreads cfg
ensureIOManagerIsRunning
done <- newTVarIO False
ref <- newTVarIO 0
let loop :: Int -> IO ()
loop i = do
when (i < numThreads) $ do
_ <- forkIO $ do
threadDelay 1000
atomically $ do
a <- readTVar ref
let !b = a+1
writeTVar ref b
when (b == numThreads) $ writeTVar done True
loop (i + 1)
runInUnboundThread $ do
loop 0
atomically $ do
b <- readTVar done
when (not b) retry
------------------------------------------------------------------------
-- Configuration
data Config = Config {
cfgNumThreads :: Last Int
}
defaultConfig :: Config
defaultConfig = Config
{ cfgNumThreads = ljust 1000
}
instance Monoid Config where
mempty = Config
{ cfgNumThreads = mempty
}
mappend a b = Config
{ cfgNumThreads = app cfgNumThreads a b
}
where app = on mappend
defaultOptions :: [OptDescr (IO Config)]
defaultOptions = [
Option ['n'] ["threads"]
(ReqArg (positive "number of threads" $ \n ->
mempty { cfgNumThreads = n }) "N")
"number of threads"
]