[Shootout-list] ring of processes

[Aaron Denney]

--LQksG6bCIzRHxTLp
Content-Type: text/plain; charset=us-ascii
Content-Disposition: inline

I have a first draft of this in Haskell.  It wasn't clear from the
description exactly what the master process is supposed to after sending
the first two messages off, and I don't fully understand what the erlang
versions do, so I've had it replicate what the slave processes do:
relay 10 high-priority messages, then 1 low priority messages, 10 times.

Could someone verify this is what it should be doing?  Any other
comments?

-- 
Aaron Denney
-><-

--LQksG6bCIzRHxTLp
Content-Type: text/plain; charset=us-ascii
Content-Description: ringmsg.hs
Content-Disposition: attachment; filename="ringmsg.hs"

{-
 - ringmsg.hs  
 - http://shootout.alioth.debian.org/bench/ringmsg/
 - 
 - There is no generalized message sending between Haskell threads, each
 - bit of data has to have someplace to go.  This is implemented by
 - hooking up "channels" (Chan a) between all of the processes, telling
 - each where to send, and where to receive.  In this light, the "check
 - sender" is a bit silly.  MVars could also work for this case.  They
 - might be lighter weight.  This is currently taking 2.5 seconds per
 - iteration on my machine, so it bears investigation.
 -
 - A closer match to what Erlang does would be to only have one channel,
 - but stick a priority queue type thing (plus filtered access & removal)
 - on it.
 -
 - The Erlang implementation only checks for the low priority messages
 - every 10 high priority messages, it looks like the "after 0" clause
 - means it doesn't block for it.  We do.  This may change somethings.
 -}
module Main(main) where
import Control.Concurrent
import System(getArgs)
import List(zipWith4)

-- Constants
hiloratio = 10   -- how many high priority messages to send per low priority.
processes = 8192 -- how many processes to put in a ring.
fork = forkIO    -- forkOS would be the other choice.

forever :: IO () -> IO ()
forever x = sequence_ $ repeat x

for :: Int -> IO () -> IO ()
for count x = sequence_ $ replicate count x

type ID = Int
data Message a = M ID a

assert :: Bool -> IO ()
assert False = error "assert failed"
assert True  = return ()

slavestep (sendid, loin, hiin) (myid, loout, hiout) = do
        for hiloratio $ sendhis sendid myid hiin hiout
        sendlos sendid myid loin loout

slaveproc a b = forever $ slavestep a b

masterproc runs a@(lastid, loin, hiin) b@(myid, loout, hiout) = do
        starthis myid hiout
        startlos myid loout
        for runs $ slavestep a b

sendhis sendid myid hiin hiout = do 
        M s d <- readChan hiin
        assert $ sendid == s 
        writeChan hiout (M myid d)

sendlos = sendhis

starthis myid hiout = do
        writeChan hiout (M myid ())

startlos = starthis

main = do ~[runs] <- getArgs
          doit $ read runs

doit :: Int -> IO ()
doit runs = do
        let ids = [1..processes]
        hichans <- sequence $ replicate processes newChan
        lochans <- sequence $ replicate processes newChan
        let args = zip3 ids hichans lochans
        let slaveprocs = zipWith slaveproc args (tail args)
        mapM fork slaveprocs
        masterproc runs (last args) (head args)

--LQksG6bCIzRHxTLp--