Shootout/Thread ring

Thread-ring:

http://shootout.alioth.debian.org/gp4/benchmark.php?test=threadring&lang=all

Each program should create and keep alive 503 threads, explicity or implicitly linked in a ring, and pass a token between one thread and the next thread at least N times. Programs may use kernel threads, lightweight threads? cooperative threads? and other programs with custom schedulers will be listed as interesting alternative implementations. Briefly say what concurrency technique is used in the program header comment.

Each program should

• create 503 linked threads (named 1 to 503)
• thread 503 should be linked to thread 1, forming an unbroken ring
• pass a token to thread 1
• pass the token from thread to thread N times
• print the name of the last thread (1 to 503) to take the token

Similar benchmarks are described in Performance Measurements of Threads in Java and Processes in Erlang, 1998; and A Benchmark Test for BCPL Style Coroutines, 2004. For some language implementations increasing the number of threads quickly results in Death by Concurrency.

Proposed entry

Should be easily the fastest entry.

-- The Great Computer Language Shootout
-- http://shootout.alioth.debian.org/
-- Contributed by Jed Brown with improvements by Spencer Janssen and Don Stewart
--
-- 503 threads are created with forkIO, with each thread
-- creating one synchronised mutable variable (MVar) shared with the
-- next thread in the ring. The last thread created returns an MVar to
-- share with the first thread. Each thread reads from the MVar to its
-- left, and writes to the MVar to its right.
--
-- Each thread then waits on a token to be passed from its neighbour.
-- Tokens are then passed around the threads via the MVar chain N times, 
-- and the thread id of the final thread to receive a token is printed.
--
-- More information on Haskell concurrency and parallelism:
--   http://www.haskell.org/ghc/dist/current/docs/users_guide/lang-parallel.html
--

import Control.Monad
import Control.Concurrent
import System.Environment

ring = 503

new l i = do
  r <- newEmptyMVar
  forkIO (thread i l r)
  return r

thread :: Int -> MVar Int -> MVar Int -> IO ()
thread i l r = go
  where go = do
          m <- takeMVar l
          when (m == 1) (print i)
          putMVar r $! m - 1
          when (m > 0) go

main = do
  a <- newMVar . read . head =<< getArgs
  z <- foldM new a [2..ring]
  thread 1 z a