Jeu de tests pour les threads.

git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@727 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02

otherlibs/threads/Tests/Makefile

@@ -0,0 +1,18 @@
+PROGS=test1.byt test2.byt test3.byt test4.byt test5.byt test6.byt test7.byt test8.byt test9.byt testA.byt torture.byt
+
+include ../../../config/Makefile
+
+all: $(PROGS)
+
+clean:
+	rm -f *.cm* *.byt
+
+sorts.byt: sorts.ml
+	cslc -custom -o sorts.byt -I .. -I ../../graph threads.cma graphics.cma sorts.ml ../libthreads.a ../../graph/libgraphics.a $(X11_LINK) $(PTHREADS_LINK)
+
+.SUFFIXES: .ml .byt
+
+.ml.byt:
+	cslc -custom -o $*.byt -I .. -I ../../unix unix.cma threads.cma $*.ml ../libthreads.a ../../unix/libunix.a $(PTHREADS_LINK)
+
+$(PROGS): ../threads.cma ../libthreads.a

otherlibs/threads/Tests/sorts.ml

@@ -0,0 +1,222 @@
+(* Animation of sorting algorithms. *)
+
+open Graphics
+
+(* Information on a given sorting process *)
+
+type graphic_context =
+  { array: int array;                   (* Data to sort *)
+    x0: int;                            (* X coordinate, lower left corner *)
+    y0: int;                            (* Y coordinate, lower left corner *)
+    width: int;                         (* Width in pixels *)
+    height: int;                        (* Height in pixels *)
+    nelts: int;                         (* Number of elements in the array *)
+    maxval: int;                        (* Max val in the array + 1 *)
+    rad: int                            (* Dimension of the rectangles *)
+  }
+
+(* Array assignment and exchange with screen update *)
+
+let draw gc i v =
+  fill_rect (gc.x0 + (gc.width * i) / gc.nelts)
+            (gc.y0 + (gc.height * v) / gc.maxval)
+            gc.rad gc.rad
+
+let assign gc i v =
+  set_color background; draw gc i gc.array.(i);
+  set_color foreground; draw gc i v;
+  gc.array.(i) <- v
+
+let exchange gc i j =
+  let val_i = gc.array.(i) in
+  assign gc i gc.array.(j);
+  assign gc j val_i
+
+(* Construction of a graphic context *)
+
+let initialize name array maxval x y w h =
+  let (_, label_height) = text_size name in
+  let rad = (w - 2) / (Array.length array) - 1 in
+  let gc =
+    { array = Array.copy array;
+      x0 = x + 1;                       (* Leave one pixel left for Y axis *)
+      y0 = y + 1;                       (* Leave one pixel below for X axis *)
+      width = w - 2;                    (* 1 pixel left, 1 pixel right *)
+      height = h - 1 - label_height - rad;
+      nelts = Array.length array;
+      maxval = maxval;
+      rad = rad } in
+  moveto (gc.x0 - 1) (gc.y0 + gc.height);
+  lineto (gc.x0 - 1) (gc.y0 - 1);
+  lineto (gc.x0 + gc.width) (gc.y0 - 1);
+  moveto (gc.x0 - 1) (gc.y0 + gc.height);
+  draw_string name;
+  for i = 0 to Array.length array - 1 do
+    draw gc i array.(i)
+  done;
+  gc
+
+(* Main animation function *)
+
+let display functs nelts maxval =
+  let a = Array.new nelts 0 in
+  for i = 0 to nelts - 1 do
+    a.(i) <- Random.int maxval
+  done;
+  let num_finished = ref 0 in
+  let lock_finished = Mutex.new() in
+  let cond_finished = Condition.new() in
+  for i = 0 to Array.length functs - 1 do
+    let (name, funct, x, y, w, h) = functs.(i) in
+    let gc = initialize name a maxval x y w h in
+    Thread.new
+      (fun () ->
+        funct gc;
+        Mutex.lock lock_finished;
+        incr num_finished;
+        Mutex.unlock lock_finished;
+        Condition.signal cond_finished)
+      ()
+  done;
+  Mutex.lock lock_finished;
+  while !num_finished < Array.length functs do
+    Condition.wait cond_finished lock_finished
+  done;
+  Mutex.unlock lock_finished;
+  read_key()
+
+(*****
+  let delay = ref 0 in
+  try
+    while true do
+      let gc = Queue.take q in
+        begin match gc.action with
+          Finished -> ()
+        | Pause f ->
+            gc.action <- f ();
+            for i = 0 to !delay do () done;
+            Queue.add gc q
+        end;
+      if key_pressed() then begin
+        match read_key() with
+          'q'|'Q' ->
+            raise Exit
+        | '0'..'9' as c ->
+            delay := (Char.code c - 48) * 500
+        | _ ->
+            ()
+      end
+    done
+  with Exit -> ()
+     | Queue.Empty -> read_key(); ()
+*****)
+
+(* The sorting functions. *)
+
+(* Bubble sort *)
+
+let bubble_sort gc =
+  let ordered = ref false in
+  while not !ordered do
+    ordered := true;
+    for i = 0 to Array.length gc.array - 2 do
+      if gc.array.(i+1) < gc.array.(i) then begin
+        exchange gc i (i+1);
+        ordered := false
+      end
+    done
+  done
+
+(* Insertion sort *)
+
+let insertion_sort gc =
+  for i = 1 to Array.length gc.array - 1 do
+    let val_i = gc.array.(i) in
+    let j = ref (i - 1) in
+    while !j >= 0 & val_i < gc.array.(!j) do
+      assign gc (!j + 1) gc.array.(!j);
+      decr j
+    done;
+    assign gc (!j + 1) val_i
+  done
+
+(* Selection sort *)
+
+let selection_sort gc =
+  for i = 0 to Array.length gc.array - 1 do
+    let min = ref i in
+    for j = i+1 to Array.length gc.array - 1 do
+      if gc.array.(j) < gc.array.(!min) then min := j
+    done;
+    exchange gc i !min
+  done
+
+(* Quick sort *)
+
+let quick_sort gc =
+  let rec quick lo hi =
+    if lo < hi then begin
+      let i = ref lo in
+      let j = ref hi in
+      let pivot = gc.array.(hi) in
+      while !i < !j do
+        while !i < hi & gc.array.(!i) <= pivot do incr i done;
+        while !j > lo & gc.array.(!j) >= pivot do decr j done;
+        if !i < !j then exchange gc !i !j
+      done;
+      exchange gc !i hi;
+      quick lo (!i-1);
+      quick (!i+1) hi
+    end
+  in quick 0 (Array.length gc.array - 1)
+
+(* Merge sort *)
+
+let merge_sort gc =
+  let rec merge i l1 l2 =
+    match (l1, l2) with
+      ([], []) ->
+        ()
+    | ([], v2::r2) ->
+        assign gc i v2; merge (i+1) l1 r2
+    | (v1::r1, []) ->
+        assign gc i v1; merge (i+1) r1 l2
+    | (v1::r1, v2::r2) ->
+        if v1 < v2
+        then begin assign gc i v1; merge (i+1) r1 l2 end
+        else begin assign gc i v2; merge (i+1) l1 r2 end in
+  let rec msort start len =
+    if len < 2 then () else begin
+      let m = len / 2 in
+      msort start m;
+      msort (start+m) (len-m);
+      merge start
+            (Array.to_list (Array.sub gc.array start m))
+            (Array.to_list (Array.sub gc.array (start+m) (len-m)))
+    end in
+  msort 0 (Array.length gc.array)
+
+(* Main program *)
+
+let animate() =
+  open_graph "";
+  moveto 0 0; draw_string "Press a key to start...";
+  let seed = ref 0 in
+  while not (key_pressed()) do incr seed done;
+  read_key();
+  Random.init !seed;
+  clear_graph();
+  let prompt = "0: fastest ... 9: slowest, press 'q' to quit" in
+  moveto 0 0; draw_string prompt;
+  let (_, h) = text_size prompt in
+  let sx = size_x() / 2 and sy = (size_y() - h) / 3 in
+  display [| "Bubble", bubble_sort, 0, h, sx, sy;
+             "Insertion", insertion_sort, 0, h+sy, sx, sy;
+             "Selection", selection_sort, 0, h+2*sy, sx, sy;
+             "Quicksort", quick_sort, sx, h, sx, sy;
+             (** "Heapsort", heap_sort, sx, h+sy, sx, sy; **)
+             "Mergesort", merge_sort, sx, h+2*sy, sx, sy |]
+          100 1000;
+  close_graph()
+
+let _ = if !Sys.interactive then () else begin animate(); exit 0 end

otherlibs/threads/Tests/test1.ml

@@ -0,0 +1,59 @@
+(* Classic producer-consumer *)
+
+type 'a prodcons =
+  { buffer: 'a array;
+    lock: Mutex.t;
+    mutable readpos: int;
+    mutable writepos: int;
+    notempty: Condition.t;
+    notfull: Condition.t }
+
+let new size init =
+  { buffer = Array.new size init;
+    lock = Mutex.new();
+    readpos = 0;
+    writepos = 0;
+    notempty = Condition.new();
+    notfull = Condition.new() }
+
+let put p data =
+  Mutex.lock p.lock;
+  while (p.writepos + 1) mod Array.length p.buffer = p.readpos do
+    Condition.wait p.notfull p.lock
+  done;
+  p.buffer.(p.writepos) <- data;
+  p.writepos <- (p.writepos + 1) mod Array.length p.buffer;
+  Condition.signal p.notempty;
+  Mutex.unlock p.lock
+
+let get p =
+  Mutex.lock p.lock;
+  while p.writepos = p.readpos do
+    Condition.wait p.notempty p.lock
+  done;
+  let data = p.buffer.(p.readpos) in
+  p.readpos <- (p.readpos + 1) mod Array.length p.buffer;
+  Condition.signal p.notfull;
+  Mutex.unlock p.lock;
+  data
+
+(* Test *)
+
+let buff = new 20 0
+
+let rec produce n =
+  print_int n; print_string "-->"; print_newline();
+  put buff n;
+  produce (n+1)
+
+let rec consume () =
+  let n = get buff in
+  print_string "-->"; print_int n; print_newline();
+  consume ()
+
+let _ =
+  Thread.new produce 0;
+  consume()
+
+
+

otherlibs/threads/Tests/test2.ml

@@ -0,0 +1,9 @@
+let print_message c =
+  for i = 1 to 10000 do
+    print_char c; flush stdout
+  done
+
+let _ =
+  let t1 = Thread.new print_message 'a' in
+  let t2 = Thread.new print_message 'b' in
+  Thread.join t1; Thread.join t2; exit 0

otherlibs/threads/Tests/test3.ml

@@ -0,0 +1,8 @@
+let print_message delay c =
+  while true do
+    print_char c; flush stdout; Unix.sleep delay
+  done
+
+let _ =
+  Thread.new (print_message 2) 'a';
+  print_message 3 'b'

otherlibs/threads/Tests/test4.ml

@@ -0,0 +1,13 @@
+let rec fib n = if n <= 2 then 1 else fib(n-1) + fib(n-2)
+
+let fibtask n =
+  while true do
+    print_int(fib n); print_newline()
+  done
+
+let _ =
+  Thread.new fibtask 28;
+  while true do
+    let l = read_line () in
+    print_string ">> "; print_string l; print_newline()
+  done

otherlibs/threads/Tests/test5.ml

@@ -0,0 +1,22 @@
+open Event
+
+let ch = (new_channel() : string channel)
+
+let rec sender msg =
+  sync (send ch msg);
+  sender msg
+
+let rec receiver name =
+  print_string (name ^ ": " ^ sync (receive ch) ^ "\n");
+  flush stdout;
+  receiver name
+
+let _ =
+  Thread.new sender "hello";
+  Thread.new sender "world";
+  Thread.new receiver "A";
+  Thread.new receiver "B";
+  read_line();
+  exit 0
+
+

otherlibs/threads/Tests/test6.ml

@@ -0,0 +1,18 @@
+open Event
+
+let ch = (new_channel() : string channel)
+
+let rec f tag msg =
+  select [
+    send ch msg;
+    wrap (receive ch) (fun x -> print_string(tag ^ ": " ^ x); print_newline())
+  ];
+  f tag msg
+
+let _ =
+  Thread.new (f "A") "hello";
+  Thread.new (f "B") "world";
+  read_line();
+  exit 0
+
+

otherlibs/threads/Tests/test7.ml

@@ -0,0 +1,28 @@
+open Event
+
+let add_ch = new_channel()
+let sub_ch = new_channel()
+let read_ch = new_channel()
+
+let rec accu n =
+  select [
+    wrap (receive add_ch) (fun x -> accu (n+x));
+    wrap (receive sub_ch) (fun x -> accu (n-x));
+    wrap (send read_ch n) (fun () -> accu n)
+  ]
+
+let rec sender chan value =
+  sync(send chan value); sender chan value
+
+let read () =
+  print_int(sync(receive read_ch)); print_newline()
+
+let main () =
+  Thread.new accu 0;
+  Thread.new (sender add_ch) 1;
+  Thread.new (sender sub_ch) 1;
+  while true do read() done
+
+let _ = Printexc.catch main ()
+
+  

otherlibs/threads/Tests/test7instr.ml

@@ -0,0 +1,32 @@
+open Event
+
+let add_ch = new_channel()
+let sub_ch = new_channel()
+let read_ch = new_channel()
+
+let rec accu n =
+  print_string "?"; flush stdout;
+  select [
+    wrap (receive add_ch) (fun x -> print_string "+"; flush stdout; accu (n+x));
+    wrap (receive sub_ch) (fun x -> print_string "-"; flush stdout; accu (n-x));
+    wrap (send read_ch n) (fun () -> print_string "="; flush stdout; accu n)
+  ]
+
+let rec adder value =
+  print_string "!"; flush stdout; sync(send add_ch value); adder value
+
+let rec subber value =
+  print_string "@"; flush stdout; sync(send sub_ch value); subber value
+
+let read () =
+  print_int(sync(receive read_ch)); print_newline()
+
+let main () =
+  Thread.new accu 0;
+  Thread.new adder 1;
+  Thread.new subber 1;
+  while true do read() done
+
+let _ = Printexc.catch main ()
+
+  

otherlibs/threads/Tests/test8.ml

@@ -0,0 +1,46 @@
+open Event
+
+type 'a buffer_channel = { input: 'a channel; output: 'a channel }
+
+let new_buffer_channel() =
+  let ic = new_channel() in
+  let oc = new_channel() in
+  let buff = Queue.new() in
+  let rec buffer_process front rear =
+    match (front, rear) with
+      ([], []) -> buffer_process [sync(receive ic)] []
+    | (hd::tl, _) ->
+        select [
+          wrap (receive ic) (fun x -> buffer_process front (x::rear));
+          wrap (send oc hd) (fun () -> buffer_process tl rear)
+        ]
+    | ([], _) -> buffer_process (List.rev rear) [] in
+  Thread.new (buffer_process []) [];
+  { input = ic; output = oc }
+
+let buffer_send bc data =
+  sync(send bc.input data)
+
+let buffer_receive bc =
+  receive bc.output
+
+(* Test *)
+
+let box = new_buffer_channel()
+let ch = new_channel()
+
+let f () =
+  buffer_send box "un";
+  buffer_send box "deux";
+  sync (send ch 3)
+
+let g () =
+  print_int (sync(receive ch)); print_newline();
+  print_string (sync(buffer_receive box)); print_newline();
+  print_string (sync(buffer_receive box)); print_newline()
+
+let _ =
+  Thread.new f ();
+  g()
+
+

otherlibs/threads/Tests/test9.ml

@@ -0,0 +1,26 @@
+open Event
+
+type 'a swap_chan = ('a * 'a channel) channel
+
+let swap msg_out ch =
+  guard (fun () ->
+    let ic = new_channel() in
+    choose [
+      wrap (receive ch) (fun (msg_in, oc) -> sync (send oc msg_out); msg_in);
+      wrap (send ch (msg_out, ic)) (fun () -> sync (receive ic))
+    ])
+
+let ch = new_channel()
+
+let f () =
+  let res = sync (swap "F" ch) in
+  print_string "f "; print_string res; print_newline()
+
+let g () =
+  let res = sync (swap "G" ch) in
+  print_string "g "; print_string res; print_newline()
+
+let _ =
+  let id = Thread.new f () in
+  g ();
+  Thread.join id

otherlibs/threads/Tests/testA.ml

@@ -0,0 +1,24 @@
+let private_data = (Hashtbl.new 17 : (Thread.t, string) Hashtbl.t)
+let private_data_lock = Mutex.new()
+
+let set_private_data data =
+  Mutex.lock private_data_lock;
+  Hashtbl.add private_data (Thread.self()) data;
+  Mutex.unlock private_data_lock
+
+let get_private_data () =
+  Hashtbl.find private_data (Thread.self())
+
+let process id data =
+  set_private_data data;
+  print_int id; print_string " --> "; print_string(get_private_data());
+  print_newline()
+
+let _ =
+  let t1 = Thread.new (process 1) "un" in
+  let t2 = Thread.new (process 2) "deux" in
+  let t3 = Thread.new (process 3) "trois" in
+  let t4 = Thread.new (process 4) "quatre" in
+  let t5 = Thread.new (process 5) "cinq" in
+  List.iter Thread.join [t1;t2;t3;t4;t5]
+

otherlibs/threads/Tests/torture.ml

@@ -0,0 +1,44 @@
+(* Torture test - lots of GC *)
+
+let gc_thread () =
+  while true do
+(*    print_string "gc"; print_newline(); *)
+    Gc.minor(); Thread.yield()
+  done
+
+let stdin_thread () =
+  while true do
+    print_string "> "; flush stdout;
+    let s = read_line() in
+    print_string ">>> "; print_string s; print_newline()
+  done
+
+let writer_thread (oc, size) =
+  while true do
+(*    print_string "writer "; print_int size; print_newline(); *)
+    let buff = String.make size 'a' in
+    Unix.write oc buff 0 size
+  done
+
+let reader_thread (ic, size) =
+  while true do
+(*    print_string "reader "; print_int size; print_newline(); *)
+    let buff = String.create size in
+    let n = Unix.read ic buff 0 size in
+    for i = 0 to n-1 do
+      if buff.[i] <> 'a' then prerr_endline "error in reader_thread"
+    done
+  done
+
+let main() =
+  Thread.new gc_thread ();
+  let (out1, in1) = Unix.pipe() in
+  Thread.new writer_thread (in1, 4096);
+  Thread.new reader_thread (out1, 4096);
+  let (out2, in2) = Unix.pipe() in
+  Thread.new writer_thread (in2, 16);
+  Thread.new reader_thread (out2, 16);
+  stdin_thread()
+
+let _ = main()
+