[Shootout-list] Re: ring of processes
Aaron Denney
wnoise@ofb.net
Sat, 2 Oct 2004 19:56:40 -0600
--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--