View source for 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.

<haskell>
-- 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
</haskell>