The Computer Language
Benchmarks Game

chameneos-redux Haskell GHC #4 program

source code

{- The Computer Language Benchmarks Game
   http://benchmarksgame.alioth.debian.org/
   Written by Tom Pledger, 13 Nov 2006. modified by Don Stewart
   Updated for chameneos-redux by Spencer Janssen, 27 Nov 2007
   Modified by Péter Diviánszky, 19 May 2010
   Modified by Louis Wasserman, 14 June 2010

   Should be compiled with -O2 -threaded -fvia-c -optc-O3 and run with +RTS -N<number of cores>.
   -}

import Control.Concurrent
import Control.Monad
import Data.Char
import Data.IORef
import System.Environment
import System.IO
import GHC.Conc
import Foreign hiding (complement)

newtype Color = C Int deriving (Storable,Enum)

#define Y (C 2)
#define R (C 1)
#define B (C 0)

instance Show Color where
	show Y = "yellow"
	show R = "red"
	show B = "blue"

complement :: Color -> Color -> Color
complement !a !b = case a of
    B -> case b of R -> Y; B -> B; _ -> R
    R -> case b of B -> Y; R -> R; _ -> B
    Y -> case b of B -> R; Y -> Y; _ -> B

type Chameneous = Ptr Color
data MP = Nobody !Int | Somebody !Int !Chameneous !(MVar Chameneous)

arrive :: MVar MP -> MVar (Int, Int) -> Chameneous -> IO ()
arrive !mpv !finish !ch = do
    waker <- newEmptyMVar
    let inc x = (fromEnum (ch == x) +)
        go !t !b = do
            w <- takeMVar mpv
            case w of
                Nobody 0
                 -> do
                    putMVar mpv w
                    putMVar finish (t, b)
  		Nobody q -> do
                    putMVar mpv $ Somebody q ch waker
                    ch' <- takeMVar waker
                    go (t+1) $ inc ch' b

                Somebody q ch' waker' -> do
                    c  <- peek ch
                    c' <- peek ch'
                    let !c'' = complement c c'
                    poke ch  c''
                    poke ch' c''
                    putMVar waker' ch
                    let !q' = q-1
                    putMVar mpv $ Nobody q'
                    go (t+1) $ inc ch' b
    go 0 0

showN = unwords . map ((digits !!) . digitToInt) . show

digits = words "zero one two three four five six seven eight nine"

run :: Int -> Int -> [Color] -> IO (IO ())
run n cpu cs = do
    fs    <- replicateM (length cs) newEmptyMVar
    mpv   <- newMVar (Nobody n)
    withArrayLen cs $ \ n cols -> do
    	zipWithM_ ((forkOn cpu .) . arrive mpv) fs (take n (iterate (`advancePtr` 1) cols))

    	return $ do
	  putStrLn . map toLower . unwords . ([]:) . map show $ cs
	  ns    <- mapM takeMVar fs
	  putStr . map toLower . unlines $ [unwords [show n, showN b] | (n, b) <- ns]
	  putStrLn . (" "++) . showN . sum . map fst $ ns
	  putStrLn ""

main = do
    putStrLn . map toLower . unlines $
        [unwords [show a, "+", show b, "->", show $ complement a b]
            | a <- [B..Y], b <- [B..Y]]

    n <- readIO . head =<< getArgs
    actions <- zipWithM (run n) [0..] [[B..Y],[B,R,Y,R,Y,B,R,Y,R,B]]
    sequence_ actions
    

notes, command-line, and program output

NOTES:
64-bit Ubuntu quad core
The Glorious Glasgow Haskell Compilation System, version 8.2.1


Tue, 14 Nov 2017 22:16:47 GMT

MAKE:
mv chameneosredux.ghc-4.ghc chameneosredux.ghc-4.hs
/opt/src/ghc-8.2.1/bin/ghc --make -fllvm -O2 -XBangPatterns -threaded -rtsopts -XCPP -XGeneralizedNewtypeDeriving chameneosredux.ghc-4.hs -o chameneosredux.ghc-4.ghc_run
[1 of 1] Compiling Main             ( chameneosredux.ghc-4.hs, chameneosredux.ghc-4.o )

chameneosredux.ghc-4.hs:27:1: warning: [-Wtabs]
    Tab character found here, and in 11 further locations.
    Please use spaces instead.
   |
27 |         show Y = "yellow"
   | ^^^^^^^^
You are using an unsupported version of LLVM!
Currently only 3.9 is supported.
We will try though...
Linking chameneosredux.ghc-4.ghc_run ...
rm chameneosredux.ghc-4.hs

2.64s to complete and log all make actions

COMMAND LINE:
./chameneosredux.ghc-4.ghc_run +RTS -qa -qm -N4 -RTS 6000000

PROGRAM OUTPUT:
blue + blue -> blue
blue + red -> yellow
blue + yellow -> red
red + blue -> yellow
red + red -> red
red + yellow -> blue
yellow + blue -> red
yellow + red -> blue
yellow + yellow -> yellow

 blue red yellow
3705761 zero
3968622 zero
4325617 zero
 one two zero zero zero zero zero zero

 blue red yellow red yellow blue red yellow red blue
1200000 zero
1200001 zero
1200001 zero
1200001 zero
1200000 zero
1200000 zero
1200000 zero
1199999 zero
1199999 zero
1199999 zero
 one two zero zero zero zero zero zero