Thanks to Don Stewart! (yet another concurrency test)

gistfile1.hs

{-# LANGUAGE BangPatterns #-}
import Control.Concurrent
import Control.Monad
import System.Environment(getArgs)
import Data.Int
import Control.Concurrent.STM

addMany' :: [TVar Int64] -> Int64 -> Int64 -> IO ()
addMany' !a !n !i =
  forM_ [1..i] (\_ ->
    forM_ a (shW n))

addMany :: TVar Int64 -> [TVar Int64] -> Int64 -> Int64 -> IO ()
addMany !c !a !n !i = addMany' a n i >> shW 1 c

waitTo !c !nth = do
  threadDelay (100*1000)
  w' <- shR c
  if w' == nth
    then return ()
    else waitTo c nth

shR = atomically . readTVar
shW !k !r = atomically $
  do x' <- readTVar r
     writeTVar r $! (x' + k)

main = do
  args <- getArgs
  let (niters, nvars, nthreads) = (read x, read y, read z)
      (x:y:z:_) = args
  c <- atomically $ newTVar 0
  a <- mapM (\_ -> atomically $ newTVar 0) [1..nvars]
  mapM_ (\k -> forkIO $ addMany c a k niters) [1..nthreads]
  waitTo c nthreads
  z <- mapM shR a
  putStrLn $ show $ sum z