Skip to content
This repository

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
branch: master
Fetching contributors…

Octocat-spinner-32-eaf2f5

Cannot retrieve contributors at this time

file 75 lines (63 sloc) 2.058 kb
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"
    ]
Something went wrong with that request. Please try again.