[Shootout-list] Re: ring of processes

[Aaron Denney]

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

And here it is.  Surprisingly to me, -O2 yields a _significant_ speedup,
as did the switch to MVars.

It's now roughly one-third of a second per iteration, 

-- 
Aaron Denney
-><-

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

{-
 - ringmsg.hs  
 - http://shootout.alioth.debian.org/bench/ringmsg/
 - Contributed by Aaron Denney
 - 
 - There is no generalized message sending between Haskell threads, each
 - bit of data has to have someplace to go.  This is implemented by
 - giving each processes a rendezvous point (MVar a), telling
 - each where to send, and where to receive.  In this light, the "check
 - sender" is a bit silly, as the sender can only be the process that
 - also has a reference.
 -
 - 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 the behaviour.
 -
 - ghc ringmsg.hs -O2
 -}
module Main(main) where
import Control.Concurrent
import System(getArgs)

-- Constants
hiloratio = 10        -- how many high priority messages to send per low priority.
processes = 8192      -- how many processes to put in a ring.
message = "the_ring"  -- The high priority message to send around the ring
low_priority = "low"  -- Just a fake message to be the 'low priority' guy
fork = forkIO         -- forkOS would be the other choice.

-- Channels or MVars
receive = takeMVar     -- or readChan
write   = putMVar      -- or writeChan
newLink = newEmptyMVar -- or newChan

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 ()

-- Each slave repeats the basic step of reading and writing forever.
slaveproc a b = forever $ relay a b

-- Read hiloratio highs, relay them, then handle the low.
relay (sendid, loin, hiin) (myid, loout, hiout) = do
        for hiloratio $ sendhis sendid myid hiin hiout
        sendlos sendid myid loin loout

-- The master process (the beginning and end):
-- start one high, one lowpriority message, and wait for the low
-- to travel around runs times.
masterproc runs a@(lastid, loin, hiin) b@(myid, loout, hiout) = do
        startmsgs myid hiout loout
	let runsB = runs - 1 in
		for runsB $ relay a b
        lastrcv a >>= return

-- Sending a message involves waiting to get the message from the
-- upstream slave, verifying it's who you expect it should be from,
-- then passing the message on to the next one.
sendhis sendid myid hiin hiout = do 
        M s d <- receive hiin
        assert $ sendid == s 
        write hiout (M myid d)

sendlos = sendhis

startmsgs myid hiout loout = do 
        write hiout (M myid message)
	write loout (M myid low_priority)

lastrcv (sendid, loin, hiin)  = do
	M s d <- receive hiin
        assert $ sendid == s 
	return d

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

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

--W/nzBZO5zC0uMSeA--