Concurrency Test

conctest.hs

import Control.Concurrent
import Control.Monad
import Data.Time.Clock.POSIX
import System.Environment

main :: IO ()
main = do
    -- setup
    n <- getArgs >>= return . read . head
    start <- newEmptyMVar
    done <- newEmptyMVar
    ch <- newChan

    -- start the threads and wait
    forkIO $ writer start ch n
    forkIO $ reader done ch n
    threadDelay 1000000

    -- run the test
    t1 <- getPOSIXTime
    putMVar start ()
    i <- takeMVar done
    t2 <- getPOSIXTime

    -- print the result
    putStrLn $ show i
    putStrLn . show $ t2 - t1

writer :: MVar () -> Chan Int -> Int -> IO ()
writer start ch n = takeMVar start
                 >> replicateM_ n (writeChan ch 1)

reader :: MVar Int -> Chan Int -> Int -> IO ()
reader done ch n = go 0
  where
    go m | m >= n = putMVar done m
    go m = readChan ch >>= (go $!) . (m +)