Difference between revisions of "Shootout/Chameneos"
< Shootout
Jump to navigation
Jump to search
DonStewart (talk | contribs) (port page) |
DonStewart (talk | contribs) m (category) |
||
| Line 1: | Line 1: | ||
| − | |||
For this problem, each program should |
For this problem, each program should |
||
* create four differently coloured (blue, red, yellow, blue) concurrent chameneos creatures |
* create four differently coloured (blue, red, yellow, blue) concurrent chameneos creatures |
||
| Line 872: | Line 871: | ||
print $ sum vals |
print $ sum vals |
||
</haskell> |
</haskell> |
||
| + | |||
| + | [[Category:Code]] |
||
Revision as of 01:00, 8 October 2006
For this problem, each program should
- create four differently coloured (blue, red, yellow, blue) concurrent chameneos creatures
- each creature will repeatedly go to the meeting place and meet, or wait to meet, another chameneos
- each creature will change colour to complement the colour of the chameneos that they met
- after N total meetings have taken place, any creature entering the meeting place will take on a faded colour, report the number of creatures it has met, and end
- write the sum of reported creatures met
Correct output N = 100 is: 200
Compile with "ghc -O2" for better performance. Run with command line parameter of "1000000" (one million).
As of Jan 11 06 they do not accept the meeting thread submissions, as they are not symmetrical. Alternatives will have to be submitted
Current version
Todo
Proposed version
25% shorter. Also, using -optc-O3 gives a big speedup.
This entry was rejected as "Not a symmetric" (even though it is semantically equivalent to the accepted entry) *sigh*
{-# OPTIONS_GHC -O2 -optc-O3 -funbox-strict-fields #-}
--
-- The Computer Language Shootout
-- http://shootout.alioth.debian.org/
--
-- contributed by Aaron Denney
-- modified by Chris Kuklewicz and Don Stewart
--
-- compile with "ghc --make -O2 -funbox-strict-fields chameneos.hs -o chameneos.ghc_run"
-- run with "./chameneos.ghc_run %A" where %A is the number of meetings
--
-- This is a symmetric solution that does not use a manager thread.
--
import Control.Concurrent
import Control.Monad
import System
data Color = C !Int deriving Eq
red = C 0; yellow = C 1; blue = C 2; faded = C 3
complement (C a) (C b) = if a == b then C a else C (3 - a - b)
data Meeting = M !(MVar Int) !(MVar (Color, MVar Color))
new_meeting maxMeetings = liftM2 M (newMVar maxMeetings) newEmptyMVar
wait_other (M meets waiting) color wake_up = do
remainingMeets <- takeMVar meets -- used as lock
let sleep_on = do putMVar waiting (color, wake_up)
putMVar meets remainingMeets
takeMVar wake_up
wake_waiter (other_c,other_wake_up) = do putMVar other_wake_up color
putMVar meets (remainingMeets - 1)
return other_c
case remainingMeets of
0 -> putMVar meets 0 >> return faded
_ -> tryTakeMVar waiting >>= maybe sleep_on wake_waiter
spawnCreature meeting_place startingColor = do
metVar <- newEmptyMVar
wake_up <- newEmptyMVar
let creature = putMVar metVar =<< inner_creature startingColor (0::Int)
where inner_creature color have_met = do
color `seq` have_met `seq` return ()
other <- wait_other meeting_place color wake_up
if other == faded
then return have_met
else inner_creature (complement color other) (have_met + 1)
forkIO $ creature -- One thread per creature
return metVar
main = do args <- getArgs
let meetings = if null args then (1000000::Int) else (read . head) args
meeting_place <- new_meeting meetings
metVars <- mapM (spawnCreature meeting_place) [blue, red, yellow, blue]
mapM takeMVar metVars >>= print . sum -- Main thread waits for completion
Current Fastest version, no meeting thread
I have taken Aaron Denney's excellent entry (see bottom of page) and tweaked it. -- ChrisKuklewicz
This entry was winning both debian and gentoo benchmarks on 13 Jan 2006.
{-# OPTIONS_GHC -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
contributed by Aaron Denney
modified by Chris Kuklewicz, 11 Jan 2006
compile with "ghc --make -O2 -funbox-strict-fields chameneos.hs -o chameneos.ghc_run"
run with "./chameneos.ghc_run %A"
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
data Color = C !Int deriving (Eq)
red = C 0; yellow = C 1; blue = C 2; faded = C 3
complement :: Color -> Color -> Color
complement (C a) (C b) | a == b = C a
| otherwise = C (3 - a - b)
data Meeting = M !(MVar Int) !(MVar (Color, MVar Color))
new_meeting maxMeetings = liftM2 M (newMVar maxMeetings) newEmptyMVar
wait_other (M meets waiting) color wake_up = do
remainingMeets <- takeMVar meets -- used as lock
let sleep_on = do putMVar waiting (color, wake_up)
putMVar meets remainingMeets
takeMVar wake_up
wake_waiter (other_c,other_wake_up) = do putMVar other_wake_up color
putMVar meets (remainingMeets - 1)
return other_c
case remainingMeets of
0 -> putMVar meets 0 >> return faded
_ -> tryTakeMVar waiting >>= maybe sleep_on wake_waiter
spawnCreature meeting_place startingColor = do
metVar <- newEmptyMVar
wake_up <- newEmptyMVar
let creature = putMVar metVar =<< inner_creature startingColor (0::Int)
where inner_creature color have_met = do
color `seq` have_met `seq` return ()
other <- wait_other meeting_place color wake_up
if other == faded
then return have_met
else inner_creature (complement color other) (have_met + 1)
forkIO $ creature
return metVar
main = do
args <- getArgs
let meetings = if null args then (1000000::Int) else (read . head) args
meeting_place <- new_meeting meetings
metVars <- mapM (spawnCreature meeting_place) [blue, red, yellow, blue]
vals <- mapM takeMVar metVars
print $ sum vals
Even faster version
This has been submitted to the shootout, but the rules no longer allow a meeting thread
Modification of tweaked version below by SimonMarlow to make use of -funbox-strict-fields, and to avoid using explicit unboxed Int# (it looks ugly, to me).
{-# OPTIONS -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005, 2 Jan 2006
modified by Einar Karttunen, 31 Dec 2005
further modified by Chris Kuklewicz to use Int# on 6 Jan 2006
further modified by Simon Marlow using -funbox-strict-fields, and
avoiding use of explicit unboxed Int#.
This entry uses a separate thread to manage the meetings.
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base
{- Ch : fast unordered channel implementation -}
data Ch a = Ch !(MVar [a]) !(MVar a)
newCh = do w <- newMVar []; r <- newEmptyMVar; return (Ch w r)
readCh (Ch w r) = do
lst <- takeMVar w
case lst of (x:xs) -> do putMVar w xs; return x
[] -> do putMVar w []; takeMVar r
writeCh (Ch w r) x = do
ok <- tryPutMVar r x -- opportunistic, helps for this problem
unless ok $ do
lst <- takeMVar w
ok <- tryPutMVar r x -- safe inside take/put
putMVar w $! if ok then lst else (x:lst)
data Element = E !Int !(MVar Int)
red = 0; yellow = 1; blue = 2; faded = 3
complement :: Int -> Int -> Int
complement a b | a == b = a
| otherwise = 3 - a - b
main = do
args <- getArgs
goMeet <- newCh
let meetings = if null args then (1000000::Int) else (read . head) args
meetingPlace = replicateM_ meetings match >> fade
where match = do E color1 pobox1 <- readCh goMeet
E color2 pobox2 <- readCh goMeet
putMVar pobox1 color2
putMVar pobox2 color1
fade = do E _ pobox <- readCh goMeet
putMVar pobox faded
fade
spawn :: Int -> IO (MVar Int)
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
let creature havemet color = do
havemet `seq` color `seq` return ()
writeCh goMeet (E color pobox)
other <- takeMVar pobox
if other == faded
then putMVar metVar havemet
else creature (havemet+1) (complement color other)
forkIO $ creature 0 startingColor
return metVar
forkIO meetingPlace
metVars <- sequence [spawn blue,spawn red,spawn yellow,spawn blue]
total <- liftM sum $ mapM takeMVar metVars
print total
Fastest version, in Shootout
As of 5 Jan 2006, this is the fastest entry on the shootout, beating "Forth GForth" by 10%.
Like the erlang entry, this uses a separate thread to match up two chameneos in the meeting room. It does not need to use STM, and runs in about 2.3 seconds of user time on my powerbook. The code is easy to follow. Einar Kartunen added a 2min tweak to use a more efficient Chan representation for the case, makes things 2x faster for now. Chris Kuklewicz got ten percent faster execution by further optimizing the Ch implementation.
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005, 2 Jan 2005
modified by Einar Karttunen, 31 Dec 2005
This entry uses a separate thread to manage the meetings.
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
data Color = Red | Yellow | Blue | Faded deriving (Eq)
complement a b | a==b = a
complement Red b = if b==Yellow then Blue else Yellow
complement Yellow b = if b==Blue then Red else Blue
complement Blue b = if b==Red then Yellow else Red
{- Ch : fast unordered channel implementation -}
newtype Ch a = Ch (MVar [a], MVar a)
newCh = liftM2 (,) (newMVar []) newEmptyMVar >>= return.Ch
readCh (Ch (w,r)) = takeMVar w >>= \lst ->
case lst of (x:xs) -> putMVar w xs >> return x
[] -> putMVar w [] >> takeMVar r
writeCh (Ch (w,r)) x = do
ok <- tryPutMVar r x -- opportunistic, helps for this problem
unless ok $ takeMVar w >>= \lst -> do
ok <- tryPutMVar r x -- safe inside take/put
putMVar w $ if ok then lst else (x:lst)
main = do
args <- getArgs
goMeet <- newCh
let meetings = if null args then (100::Int) else (read . head) args
meetingPlace = replicateM_ meetings match >> fade
where match = do (color1,pobox1) <- readCh goMeet
(color2,pobox2) <- readCh goMeet
putMVar pobox1 color2
putMVar pobox2 color1
fade = do (_,pobox) <- readCh goMeet
putMVar pobox Faded
fade
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
let creature havemet color = do
writeCh goMeet (color,pobox)
other <- takeMVar pobox
case other of
Faded -> let color = Faded in putMVar metVar havemet
_ -> (creature $! (havemet+1)) $! (complement color other)
forkIO $ creature 0 startingColor
return metVar
forkIO meetingPlace
metVars <- mapM spawn [Blue,Red,Yellow,Blue]
total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
print total
Unboxed Tweak of submitted version
I converted the data Color to Int# and this improved the speed of the submitted entry. This is the fastest version on my powerbook, but only by 6% margin.
I am learning that (if boxed==boxed) is slow, (case boxed) is better, (case unboxed) is better still, (if unboxed ==# unboxed) is best.
{-# OPTIONS -O2 #-}
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005, 2 Jan 2006
modified by Einar Karttunen, 31 Dec 2005
further modified by Chris Kuklewicz to use Int# on 6 Jan 2006
This entry uses a separate thread to manage the meetings.
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base
{- Ch : fast unordered channel implementation -}
newtype Ch a = Ch (MVar [a], MVar a)
newCh = liftM2 (,) (newMVar []) newEmptyMVar >>= return.Ch
readCh (Ch (w,r)) = takeMVar w >>= \lst ->
case lst of (x:xs) -> putMVar w xs >> return x
[] -> putMVar w [] >> takeMVar r
writeCh (Ch (w,r)) x = do
ok <- tryPutMVar r x -- opportunistic, helps for this problem
unless ok $ takeMVar w >>= \lst -> do
ok <- tryPutMVar r x -- safe inside take/put
putMVar w $ if ok then lst else (x:lst)
main = do
let red = 0# ; yellow = 1# ; blue = 2# ; faded = 3# ;
complement :: Int# -> Int# -> Int#
complement a b | a ==# b = a
| otherwise = 3# -# a -# b;
args <- getArgs
goMeet <- newCh
let meetings = if null args then (1000000::Int) else (read . head) args
meetingPlace = replicateM_ meetings match >> fade
where match = do (color1,pobox1) <- readCh goMeet
(color2,pobox2) <- readCh goMeet
putMVar pobox1 color2
putMVar pobox2 color1
fade = do (_,pobox) <- readCh goMeet
putMVar pobox (I# faded)
fade
spawn :: Int# -> IO (MVar Int)
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
let creature havemet color = do
writeCh goMeet (I# color,pobox)
(I# other) <- takeMVar pobox
if (other ==# faded)
then let color = faded in putMVar metVar havemet
else (creature $! (havemet+1)) (complement color other)
forkIO $ creature 0 startingColor
return metVar
forkIO meetingPlace
metVars <- sequence [spawn blue,spawn red,spawn yellow,spawn blue]
total <- liftM sum $ mapM takeMVar metVars
print total
Full case tweak of older version
The following rewrite of complement from the above entry gains another 10%, it generates much better code as Eq is slower than case. I think we should use it. -- DonStewart
data Color = Red | Yellow | Blue | Faded
complement a b = case (a,b) of -- faster than Eq
(Red,Yellow) -> Blue; (Red,Blue) -> Yellow; (Red,Red) -> Red;
(Yellow,Blue) -> Red; (Yellow,Red) -> Blue; (Yellow,Yellow) -> Yellow;
(Blue,Red) -> Yellow; (Blue,Yellow) -> Red; (Blue,Blue) -> Blue;
previous version before the 10% tweak to Ch, runs in 2.6 seconds of user time:
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005
modified by Einar Karttunen
This entry uses a separate thread to manage the meetings
-}
import Control.Concurrent
import Control.Monad(replicateM_,foldM,mapM,when)
import System (getArgs)
data Color = Red | Yellow | Blue | Faded deriving (Eq)
complement a b | a==b = a
complement Red b = if b==Yellow then Blue else Yellow
complement Yellow b = if b==Blue then Red else Blue
complement Blue b = if b==Red then Yellow else Red
newtype Ch a = Ch (MVar ([a], [MVar a]))
newCh = newMVar ([], []) >>= return . Ch
readCh (Ch mv) = takeMVar mv >>= \lst ->
case lst of
([],l) -> do m <- newEmptyMVar
putMVar mv ([],(m:l))
takeMVar m
((x:xs),l) -> do putMVar mv (xs,l) >> return x
writeCh (Ch mv) v = takeMVar mv >>= \lst ->
case lst of
(p,(w:ws)) -> putMVar mv (p,ws) >> putMVar w v
(p,ws) -> putMVar mv ((v:p),ws)
main = do
args <- getArgs
goMeet <- newCh
let meetings = if null args then (100::Int) else (read . head) args
meetingPlace = replicateM_ meetings match >> fade
where match = do (color1,pobox1) <- readCh goMeet
(color2,pobox2) <- readCh goMeet
putMVar pobox1 color2
putMVar pobox2 color1
fade = do (_,pobox) <- readCh goMeet
putMVar pobox Faded
fade
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
let creature havemet color = do
writeCh goMeet (color,pobox)
other <- takeMVar pobox
case other of
Faded -> let color = Faded in putMVar metVar havemet
_ -> (creature $! (havemet+1)) $! (complement color other)
forkIO $ creature 0 startingColor
return metVar
forkIO meetingPlace
metVars <- mapM spawn [Blue,Red,Yellow,Blue]
total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
print total
I don't this this tweak to use the full case statement is faster than the submitted entry, though is it faster than the previous version you are comparing to (which has an older Ch implementation) -- ChrisKuklewicz
Other versions
This is the older fastest entry which uses Chans and is slower, at 6 seconds of user time:
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005
modified by ...
This entry uses a separate thread to manage the meetings
-}
import Control.Concurrent
import Control.Monad(replicateM_,foldM,mapM)
import System (getArgs)
data Color = Red | Yellow | Blue | Faded deriving (Eq)
complement a b | a==b = a
complement Red b = if b==Yellow then Blue else Yellow
complement Yellow b = if b==Blue then Red else Blue
complement Blue b = if b==Red then Yellow else Red
main = do
args <- getArgs
goMeet <- newChan
let meetings = if null args then (100::Int) else (read . head) args
meetingPlace = replicateM_ meetings match >> fade
where match = do (color1,pobox1) <- readChan goMeet
(color2,pobox2) <- readChan goMeet
putMVar pobox1 color2
putMVar pobox2 color1
fade = do (_,pobox) <- readChan goMeet
putMVar pobox Faded
fade
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
let creature havemet color = do
writeChan goMeet (color,pobox)
other <- takeMVar pobox
case other of
Faded -> let color = Faded in putMVar metVar havemet
_ -> (creature $! (havemet+1)) $! (complement color other)
forkIO $ creature 0 startingColor
return metVar
forkIO meetingPlace
metVars <- mapM spawn [Blue,Red,Yellow,Blue]
total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
print total
Josh Goldfoot
Josh submitted the first haskell entry:
{- The Great Computer Language Shootout
http://shootout.alioth.debian.org/
contributed by Josh Goldfoot
-}
import Control.Concurrent
import System(getArgs)
data Color = Blue | Red | Yellow | Faded deriving (Eq, Show)
data MeetingPlace = MeetingPlace { first :: Maybe Color, second :: Maybe (MVar Color), meetingsLeft :: Int }
data Creature = Creature {meetings :: Int, color :: Color, mp :: MVar MeetingPlace}
main = do
[nstring] <- getArgs
theMeetingPlace <- newMVar MeetingPlace { first = Nothing, second = Nothing, meetingsLeft = (read nstring) }
result1 <- newEmptyMVar -- Create MVars, through which the 4 creature threads will report their # of meetings
result2 <- newEmptyMVar
result3 <- newEmptyMVar
result4 <- newEmptyMVar
let creatures = [runCreature Creature { meetings = 0, color = col, mp = theMeetingPlace } res | (col, res) <-
[ (Blue, result1), (Red, result2), (Yellow, result3), (Blue, result4)]]
mapM forkIO creatures -- This one line starts the 4 "creature" threads
d1 <- takeMVar result1 -- This waits until the 1st creature thread reports a result
d2 <- takeMVar result2
d3 <- takeMVar result3
d4 <- takeMVar result4
putStrLn $ show (sum [d1, d2, d3, d4]) -- We have all 4 results; sum them, and print.
runCreature creature resultVar
| (color creature) == Faded = putMVar resultVar ((meetings creature) - 1) -- If we are faded, report & die
| otherwise = do
mpdata <- takeMVar (mp creature) -- Waits for there to be a meeting place variable to take
if (first mpdata) == Nothing
then do -- The meeting place is empty. Let the next guy know how to find us.
secondCreatureColor <- newEmptyMVar
putMVar (mp creature) MeetingPlace { first = Just (color creature), second = Just secondCreatureColor, meetingsLeft = (meetingsLeft mpdata) }
secondCreatureColorData <- takeMVar secondCreatureColor
putMVar (mp creature) MeetingPlace { first = Nothing, second = Nothing, meetingsLeft = decrement (meetingsLeft mpdata) }
runCreature Creature { meetings = (meetings creature) + 1,
color = newColor (meetingsLeft mpdata) (color creature) (Just secondCreatureColorData),
mp = (mp creature) } resultVar
else do -- We are the second creature here. Let the first guy know we arrived.
putMVar (unjust (second mpdata)) (color creature)
runCreature Creature { meetings = (meetings creature) + 1,
color = newColor (meetingsLeft mpdata) (color creature) (first mpdata),
mp = (mp creature) } resultVar
newColor 0 _ _ = Faded
newColor _ me (Just other) = complement me other
unjust (Just x) = x
complement me other
| other == Faded = Faded
| me == other = me
| me == Blue = if other == Red then Yellow else Red
| me == Red = if other == Blue then Yellow else Blue
| me == Yellow = if other == Blue then Red else Blue
| me == Faded = Faded
decrement 0 = 0
decrement n = n - 1
STM version
This version does not use a separate manager thread. It employs STM to ensure the semantics of "meet". The code is not easy to follow, especially since I tweaked things to get it down to 7.6 seconds user time.
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005
modified by ...
This entry does not use a separate thread to manage the meetings
-}
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad (mapM,foldM,join,liftM)
import System (getArgs)
import Data.IORef
data Color = Red | Yellow | Blue | Faded deriving (Eq)
complement a b | a==b = a
complement Red b = if b==Yellow then Blue else Yellow
complement Yellow b = if b==Blue then Red else Blue
complement Blue b = if b==Red then Yellow else Red
spawn enter startingColor = do
metVar <- newEmptyMVar
let child havemet color = let cps = (\other -> case other of
Faded -> let color = Faded in do putMVar metVar havemet
_ -> (child $! (havemet+1)) (complement color other))
in enter color cps
forkIO $ child 0 startingColor
return metVar
main = do args <- getArgs
let meetings = case args of
[] -> 100 :: Int
(n:_) -> read n
togoVar <- newIORef (2*meetings)
firstVar <- atomically $ newEmptyTMVar
secondVar <- atomically $ newEmptyTMVar
let enter color cps = cps =<< (join $ atomicModifyIORef togoVar
(\v -> if (v>0) then let v' = v-1 in v' `seq` (v',meet color)
else (0,return Faded) ) )
meet color = join $ atomically $ do
inFirst <- tryPutTMVar firstVar color
if inFirst
then return $ atomically $ do other <- takeTMVar secondVar
takeTMVar firstVar
return other
else do putTMVar secondVar color
other <- readTMVar firstVar
return $ return other
metVars <- mapM (spawn enter) [Blue,Red,Yellow,Blue]
total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) (0::Int) metVars
print total
Over annotated original version
This is the first version I posted, in annotated form. It runs in about 8.5 seconds user time on my powerbook.
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
contributed by Chris Kuklewicz, 28 Dec 2005
modified by ...
-}
import Control.Concurrent
import Control.Concurrent.STM
import Control.Monad (mapM,foldM,join)
import System (getArgs)
import Data.Word
data Color = Red | Yellow | Blue | Faded deriving (Eq,Show)
{- complement is commutative.
complement acts over the domain Red, Yellow, Blue only
-}
complement :: Color -> Color -> Color
complement a b | a==b = a
complement Red b = if b==Yellow then Blue else Yellow
complement Yellow b = if b==Blue then Red else Blue
complement Blue b = if b==Red then Yellow else Red
{- spawn
enter : the action to try and enter the room to meet another thread
startingColor : the inital color of this thread
return value metVar : where the thread puts its answer before exiting
The returned MVar is used to allow an easy thread-join operation
-}
spawn :: (Color -> IO Color) -> Color -> IO (MVar Word32)
spawn enter startingColor = do
metVar <- newEmptyMVar
{- child calls itself tail-recursively until passed Faded
havemet : running total for this thread of other thread met
color : current color of this thread
End by putting total into metVar, then the thread exits
-}
let child :: Word32 -> Color -> IO ()
child havemet Faded = putMVar metVar havemet
child havemet color = do result <- enter color -- returns color of other thread or Faded
case result of
Faded -> child havemet Faded
-- Use strictness to ensure running total is computed here
-- Use strictness to enture next color is computed here
other -> (child $! (havemet+1)) (complement color other)
forkIO $ child 0 startingColor -- create new child thread, running child
return metVar -- return metVar to parent thread
main = do args <- getArgs
let meetings :: Word32
meetings = case args of
[] -> 100
(n:_) -> read n
togoVar <- newMVar (2*meetings) -- final total will also be 2*meetings
-- firstVar and secondVar hold colors for two threads meeting in the room
firstVar <- atomically $ newEmptyTMVar
secondVar <- atomically $ newEmptyTMVar
-- define functions in lexical scopr of togoVar,firstVar,secondVar
let
{- canProceed decrement the value in togoVar
It returns True if the original value was above zero
Otherwise it returns False
-}
canProceed :: IO Bool
canProceed = modifyMVar togoVar (\v -> if (v>0) then let v' = v-1
in return $ v' `seq` (v',True)
else return (0,False) )
{- meet holds most of the semantics of the thread interactions
It takes the color of the current thread and returns the
color of the thread it meets.
This was very tricky to design to ensure that thead 1 and 2
get each others' colors and thread 3 cannot intervene.
-}
meet :: Color -> IO Color
-- Note the join...the STM operation returns an IO operation
-- Thus the IO operation runs after the STM operation commits
meet color = join $ atomically $ do
-- This always returns a boolean, never blocks or calls retry
inFirst <- tryPutTMVar firstVar color
if inFirst
-- immediately commit and return a new operation to perform atomically
then return $ atomically $ do
-- atomically takeTMVar on both secondVar and firstVar
-- This means they are emptied simultaneously
other <- takeTMVar secondVar
takeTMVar firstVar
return other
else do
-- If firstVar is full, then try secondVar
-- This will call retry if secondVar is also full
putTMVar secondVar color
-- We know this read cannot block is inFirst was false
other <- readTMVar firstVar
-- commit and return a simple IO action of (return other)
return $ return other
{- enter
color : this thread's current color
This is the action passed to spawn. It is self-explanatory.
-}
enter color = do proceed <- canProceed
if proceed then meet color
else return Faded
-- Blue Red Yellow Blue is the specified set of starting
-- threads. metVars is a list of empty MVars which will hold
-- each thread's individual total.
metVars <- mapM (spawn enter) [Blue,Red,Yellow,Blue]
-- This reads each metVar in turn and adds them up. This will block
-- on a metVar until that thread has finished.
total <- foldM (\tot mv -> takeMVar mv >>= return.(tot+)) 0 metVars
-- This should print 2*meetings
print total
MVar version, no manager
Posted by AaronDenney
{-# OPTIONS -O2 -funbox-strict-fields #-}
{- The Computer Language Shootout
http://shootout.alioth.debian.org/
http://shootout.alioth.debian.org/benchmark.php?test=chameneos&lang=all
-}
import Control.Concurrent
import Control.Monad
import System (getArgs)
import GHC.Base
type Color = Int
red = 0; yellow = 1; blue = 2; faded = 3
complement :: Color -> Color -> Color
complement a b | a == b = a
| otherwise = 3 - a - b
data Meeting = M !(MVar ()) !(MVar Int) !(MVar (Color, MVar Color))
new_meeting = do
lock <- newMVar ()
meets <- newMVar 0
chameno <- newEmptyMVar
return $ M lock meets chameno
wait_other (M lock meets waiting) wake_up color = do
_ <- takeMVar lock
global_meets <- readMVar meets
other_in <- tryTakeMVar waiting
other_c <- case other_in of Nothing -> sleep_on lock waiting color wake_up
Just (c, w) -> wake_waiter lock w c color meets
return (other_c, global_meets + 1)
wake_waiter lock wake_up c color meets = do
met <- takeMVar meets
putMVar meets (met + 1)
putMVar wake_up color
putMVar lock ()
return c
sleep_on lock waiting color wake_up =
do putMVar waiting (color, wake_up)
putMVar lock ()
takeMVar wake_up
creature meeting_place max_meets report wake_up start_color =
do meets <- inner_creature start_color 0
putMVar report meets
where inner_creature color have_met = do
color `seq` have_met `seq` return ()
(other, global_meets) <- wait_other meeting_place wake_up color
if (global_meets > max_meets) then
return (have_met) else
inner_creature (complement color other) (have_met + 1)
main = do
args <- getArgs
meeting_place <- new_meeting
let meetings = if null args then (1000000::Int) else (read . head) args
spawn :: Int -> IO (MVar Int)
spawn startingColor = do
metVar <- newEmptyMVar
pobox <- newEmptyMVar
forkIO $ creature meeting_place meetings metVar pobox startingColor
return metVar
metVars <- mapM spawn [blue, red, yellow, blue]
vals <- mapM takeMVar metVars
print $ sum vals