Shootout again - chameneos

[Matthieu Dubuget <matthieu.dubuget@gmail.com>]

[-- Attachment #1: Type: text/plain, Size: 269 bytes --]

Hello.

I attach an implementation for one of the new shootout test.
http://shootout.alioth.debian.org/debian/benchmark.php?test=chameneos&lang=all

It is based on the mlton's implementation.

Any idea/suggestion to improve it's speed ?

Thanks in advance.

Matthieu



[-- Attachment #2: chameneos.ml --]
[-- Type: text/plain, Size: 1722 bytes --]

(* 
 *
 * The Great Computer Language Shootout
 * http://shootout.alioth.debian.org/
 *
 * compilation: ocamlopt -noassert -unsafe -ccopt -O3 unix.cmxa threads.cmxa chameneos.ml
 *
 * Contributed by Matthieu Dubuget
 *)

(* color manipulation *)
type color = Blue | Red | Yellow

(* val compl : color * color -> color *)
let compl = function
  | Blue, Blue | Red, Yellow | Yellow, Red -> Blue
  | Blue, Red | Red, Blue | Yellow, Yellow -> Yellow
  | Blue, Yellow | Yellow, Blue | Red, Red -> Red

(* val place : int -> ('a option Event.channel * 'a) Event.channel *)
let place n =
  let chan = Event.new_channel () in
  let ev = Event.receive chan in
  let rec lp n =
	let ch1, c1 = Event.sync ev in
	  match n with
	    | 0 -> Event.sync (Event.send ch1 None); lp 0
	    | n -> let ch2, c2 = Event.sync ev in
		ignore (Event.sync(Event.send ch1 (Some c2)));
		ignore (Event.sync(Event.send ch2 (Some c1)));
		lp (pred n) in
    ignore( Thread.create lp n );
    chan

(*  val animal :
    (color option Event.channel * color) Event.channel ->
    int Event.channel -> color -> unit *)
let animal p m c =
  let a = Event.new_channel () in
  let rec lp n c =
    Event.sync( Event.send p (a, c));
    match Event.sync (Event.receive a) with
	None -> ignore (Event.sync (Event.send m n))
      | Some oc -> lp (succ n) (compl (c, oc)) in
    ignore(Thread.create (lp 0) c)

(* val go : int -> int *)
let go n =
  let p = place n
  and m = Event.new_channel () in
  let colors =  [Blue; Red; Yellow; Blue] in
    List.iter (animal p m) colors;
    List.fold_left (fun s c -> s + Event.sync (Event.receive m)) 0 colors

let main () =
  let n = go (int_of_string Sys.argv.(1)) in
    print_int n; print_newline () ;;

main ()