summaryrefslogtreecommitdiffstats
diff options
context:
space:
mode:
Diffstat
-rw-r--r--otherlibs/threads/Tests/Makefile18
-rw-r--r--otherlibs/threads/Tests/sorts.ml222
-rw-r--r--otherlibs/threads/Tests/test1.ml59
-rw-r--r--otherlibs/threads/Tests/test2.ml9
-rw-r--r--otherlibs/threads/Tests/test3.ml8
-rw-r--r--otherlibs/threads/Tests/test4.ml13
-rw-r--r--otherlibs/threads/Tests/test5.ml22
-rw-r--r--otherlibs/threads/Tests/test6.ml18
-rw-r--r--otherlibs/threads/Tests/test7.ml28
-rw-r--r--otherlibs/threads/Tests/test7instr.ml32
-rw-r--r--otherlibs/threads/Tests/test8.ml46
-rw-r--r--otherlibs/threads/Tests/test9.ml26
-rw-r--r--otherlibs/threads/Tests/testA.ml24
-rw-r--r--otherlibs/threads/Tests/torture.ml44
14 files changed, 569 insertions, 0 deletions
diff --git a/otherlibs/threads/Tests/Makefile b/otherlibs/threads/Tests/Makefile
new file mode 100644
index 000000000..77ccdcce0
--- /dev/null
+++ b/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
diff --git a/otherlibs/threads/Tests/sorts.ml b/otherlibs/threads/Tests/sorts.ml
new file mode 100644
index 000000000..ebdc61dac
--- /dev/null
+++ b/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
diff --git a/otherlibs/threads/Tests/test1.ml b/otherlibs/threads/Tests/test1.ml
new file mode 100644
index 000000000..91b951039
--- /dev/null
+++ b/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()
+
+
+
diff --git a/otherlibs/threads/Tests/test2.ml b/otherlibs/threads/Tests/test2.ml
new file mode 100644
index 000000000..e4763e58e
--- /dev/null
+++ b/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
diff --git a/otherlibs/threads/Tests/test3.ml b/otherlibs/threads/Tests/test3.ml
new file mode 100644
index 000000000..19002305c
--- /dev/null
+++ b/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'
diff --git a/otherlibs/threads/Tests/test4.ml b/otherlibs/threads/Tests/test4.ml
new file mode 100644
index 000000000..b564dc53b
--- /dev/null
+++ 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
diff --git a/otherlibs/threads/Tests/test5.ml b/otherlibs/threads/Tests/test5.ml
new file mode 100644
index 000000000..38327ffa0
--- /dev/null
+++ b/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
+
+
diff --git a/otherlibs/threads/Tests/test6.ml b/otherlibs/threads/Tests/test6.ml
new file mode 100644
index 000000000..9942a4054
--- /dev/null
+++ b/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
+
+
diff --git a/otherlibs/threads/Tests/test7.ml b/otherlibs/threads/Tests/test7.ml
new file mode 100644
index 000000000..58d3fde32
--- /dev/null
+++ b/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 ()
+
+
diff --git a/otherlibs/threads/Tests/test7instr.ml b/otherlibs/threads/Tests/test7instr.ml
new file mode 100644
index 000000000..c845fac84
--- /dev/null
+++ b/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 ()
+
+
diff --git a/otherlibs/threads/Tests/test8.ml b/otherlibs/threads/Tests/test8.ml
new file mode 100644
index 000000000..37ad9289a
--- /dev/null
+++ b/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()
+
+
diff --git a/otherlibs/threads/Tests/test9.ml b/otherlibs/threads/Tests/test9.ml
new file mode 100644
index 000000000..ae169d8cd
--- /dev/null
+++ b/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
diff --git a/otherlibs/threads/Tests/testA.ml b/otherlibs/threads/Tests/testA.ml
new file mode 100644
index 000000000..f46143be4
--- /dev/null
+++ b/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]
+
diff --git a/otherlibs/threads/Tests/torture.ml b/otherlibs/threads/Tests/torture.ml
new file mode 100644
index 000000000..1fbef0f69
--- /dev/null
+++ b/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()
+
generated by cgit v1.2.3-70-g09d2 (git 2.46.0) at 2025-03-29 14:43:31 +0000