public
Created

Thanks to Don Stewart! (yet another concurrency test)

  • Download Gist
gistfile1.hs
Haskell
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
{-# 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

Please sign in to comment on this gist.

Something went wrong with that request. Please try again.