diff --git a/test/dune b/test/dune index e5d032c7..56261dad 100644 --- a/test/dune +++ b/test/dune @@ -9,6 +9,7 @@ t_chan_train t_resource t_unfair + t_ws_deque t_bounded_queue) (libraries moonpool diff --git a/test/t_fib.ml b/test/t_fib.ml index 38e3cb50..32e264e9 100644 --- a/test/t_fib.ml +++ b/test/t_fib.ml @@ -1,5 +1,12 @@ open Moonpool +let ( let@ ) = ( @@ ) + +let with_pool ~kind () f = + match kind with + | `Simple_pool -> Simple_pool.with_ ~min:4 () f + | `Pool -> Pool.with_ ~min:4 () f + let rec fib x = if x <= 1 then 1 @@ -8,8 +15,7 @@ let rec fib x = let () = assert (List.init 10 fib = [ 1; 1; 2; 3; 5; 8; 13; 21; 34; 55 ]) -let run_test () = - let pool = Pool.create ~min:4 () in +let run_test ~pool () = let fibs = Array.init 30 (fun n -> Fut.spawn ~on:pool (fun () -> fib n)) in let res = Fut.join_array fibs |> Fut.wait_block in Pool.shutdown pool; @@ -50,11 +56,23 @@ let run_test () = 832040; |]) -let () = +let run ~kind () = for _i = 1 to 4 do - run_test () + let@ pool = with_pool ~kind () in + run_test ~pool () done; (* now make sure we can do this with multiple pools in parallel *) - let jobs = Array.init 4 (fun _ -> Thread.create run_test ()) in + let jobs = + Array.init 4 (fun _ -> + Thread.create + (fun () -> + let@ pool = with_pool ~kind () in + run_test ~pool ()) + ()) + in Array.iter Thread.join jobs + +let () = + run ~kind:`Pool (); + run ~kind:`Simple_pool () diff --git a/test/t_fib_rec.ml b/test/t_fib_rec.ml index b76fe875..d79e85b4 100644 --- a/test/t_fib_rec.ml +++ b/test/t_fib_rec.ml @@ -1,4 +1,6 @@ -open Moonpool +open! Moonpool + +let ( let@ ) = ( @@ ) let rec fib_direct x = if x <= 1 then @@ -6,9 +8,13 @@ let rec fib_direct x = else fib_direct (x - 1) + fib_direct (x - 2) +let n_calls_fib_direct = Atomic.make 0 + let rec fib ~on x : int Fut.t = if x <= 18 then - Fut.spawn ~on (fun () -> fib_direct x) + Fut.spawn ~on (fun () -> + Atomic.incr n_calls_fib_direct; + fib_direct x) else let open Fut.Infix_local in let+ t1 = fib ~on (x - 1) and+ t2 = fib ~on (x - 2) in @@ -16,14 +22,19 @@ let rec fib ~on x : int Fut.t = let () = assert (List.init 10 fib_direct = [ 1; 1; 2; 3; 5; 8; 13; 21; 34; 55 ]) -let fib_40 : int = - let pool = Pool.create ~min:8 () in - let r = fib ~on:pool 40 |> Fut.wait_block_exn in - Pool.shutdown pool; - r +let fib_40 : int lazy_t = + lazy + (let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "fib40" in + let pool = Pool.create ~min:8 () in + let r = fib ~on:pool 40 |> Fut.wait_block_exn in + Pool.shutdown pool; + r) let run_test () = - let pool = Pool.create ~min:8 () in + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "run-test" in + let@ pool = Pool.with_ ~min:8 () in + + let (lazy fib_40) = fib_40 in assert ( List.init 10 (fib ~on:pool) @@ -34,11 +45,26 @@ let run_test () = let fibs = Array.init n_fibs (fun _ -> fib ~on:pool 40) in let res = Fut.join_array fibs |> Fut.wait_block in - Pool.shutdown pool; assert (res = Ok (Array.make n_fibs fib_40)) +let setup_counter () = + if Trace.enabled () then + ignore + (Thread.create + (fun () -> + while true do + Thread.delay 0.01; + Trace.counter_int "n-fib-direct" (Atomic.get n_calls_fib_direct) + done) + () + : Thread.t) + let () = + let@ () = Trace_tef.with_setup () in + setup_counter (); + + let (lazy fib_40) = fib_40 in Printf.printf "fib 40 = %d\n%!" fib_40; for _i = 1 to 2 do run_test () diff --git a/test/t_props.ml b/test/t_props.ml index ae6638ae..01e3c174 100644 --- a/test/t_props.ml +++ b/test/t_props.ml @@ -1,49 +1,54 @@ module Q = QCheck open Moonpool +let ( let@ ) = ( @@ ) let tests = ref [] let add_test t = tests := t :: !tests -(* main pool *) -let pool = Pool.create ~min:4 ~per_domain:1 () - -(* pool for future combinators *) -let pool_fut = Pool.create ~min:2 () - -module Fut2 = (val Fut.infix pool_fut) +let with_pool ~kind () f = + match kind with + | `Simple_pool -> Simple_pool.with_ ~min:4 ~per_domain:1 () f + | `Pool -> Pool.with_ ~min:4 ~per_domain:1 () f let () = - add_test - @@ Q.Test.make ~name:"map then join_list" - Q.(small_list small_int) - (fun l -> - let l' = List.map (fun x -> Fut.spawn ~on:pool (fun () -> x + 1)) l in - let l' = Fut.join_list l' |> Fut.wait_block_exn in - if l' <> List.map succ l then Q.Test.fail_reportf "bad list"; - true) + add_test @@ fun ~kind -> + let@ pool = with_pool ~kind () in + Q.Test.make ~name:"map then join_list" + Q.(small_list small_int) + (fun l -> + let l' = List.map (fun x -> Fut.spawn ~on:pool (fun () -> x + 1)) l in + let l' = Fut.join_list l' |> Fut.wait_block_exn in + if l' <> List.map succ l then Q.Test.fail_reportf "bad list"; + true) let () = - add_test - @@ Q.Test.make ~name:"map bind" - Q.(small_list small_int) - (fun l -> - let open Fut2 in - let l' = - l - |> List.map (fun x -> - let* x = Fut.spawn ~on:pool_fut (fun () -> x + 1) in - let* y = Fut.return (x - 1) in - let+ z = Fut.spawn ~on:pool_fut (fun () -> string_of_int y) in - z) - in + add_test @@ fun ~kind -> + let@ pool = with_pool ~kind () in + Q.Test.make ~name:"map bind" + Q.(small_list small_int) + (fun l -> + let open Fut.Infix_local in + let l' = + l + |> List.map (fun x -> + let* x = Fut.spawn ~on:pool (fun () -> x + 1) in + let* y = Fut.return (x - 1) in + let+ z = Fut.spawn ~on:pool (fun () -> string_of_int y) in + z) + in - Fut.wait_list l' |> Fut.wait_block_exn; + Fut.wait_list l' |> Fut.wait_block_exn; - let l_res = List.map Fut.get_or_fail_exn l' in - if l_res <> List.map string_of_int l then - Q.Test.fail_reportf "bad list: from %s, to %s" - Q.Print.(list int l) - Q.Print.(list string l_res); - true) + let l_res = List.map Fut.get_or_fail_exn l' in + if l_res <> List.map string_of_int l then + Q.Test.fail_reportf "bad list: from %s, to %s" + Q.Print.(list int l) + Q.Print.(list string l_res); + true) -let () = QCheck_base_runner.run_tests_main !tests +let () = + let tests = + List.map (fun t -> [ t ~kind:`Simple_pool; t ~kind:`Pool ]) !tests + |> List.flatten + in + QCheck_base_runner.run_tests_main tests diff --git a/test/t_resource.ml b/test/t_resource.ml index a9686867..01f8be57 100644 --- a/test/t_resource.ml +++ b/test/t_resource.ml @@ -2,8 +2,13 @@ open! Moonpool let ( let@ ) = ( @@ ) +let with_pool ~kind () f = + match kind with + | `Simple_pool -> Simple_pool.with_ ~min:4 ~per_domain:1 () f + | `Pool -> Pool.with_ ~min:4 ~per_domain:1 () f + (* test proper resource handling *) -let () = +let run ~kind () = let@ () = Trace_tef.with_setup () in let a = Atomic.make 0 in for _i = 1 to 1_000 do @@ -12,7 +17,11 @@ let () = if _i mod 100 = 0 then Thread.delay 0.8; (* allocate a new pool at each iteration *) - let@ p = Pool.with_ ~min:4 () in + let@ p = with_pool ~kind () in Pool.run_wait_block p (fun () -> Atomic.incr a) done; assert (Atomic.get a = 1_000) + +let () = + run ~kind:`Pool (); + run ~kind:`Simple_pool () diff --git a/test/t_tree_futs.ml b/test/t_tree_futs.ml index 5ebf2bff..56bde804 100644 --- a/test/t_tree_futs.ml +++ b/test/t_tree_futs.ml @@ -2,6 +2,11 @@ open Moonpool let ( let@ ) = ( @@ ) +let with_pool ~kind ~j () f = + match kind with + | `Simple_pool -> Simple_pool.with_ ~min:j () f + | `Pool -> Pool.with_ ~min:j () f + type 'a tree = | Leaf of 'a | Node of 'a tree Fut.t * 'a tree Fut.t @@ -61,15 +66,13 @@ let stat_thread () = done) () -let () = - (* - Tracy_client_trace.setup (); - *) +let run_main ~kind () = + let@ _sp = Trace.with_span ~__FILE__ ~__LINE__ "run_main" in let start = Unix.gettimeofday () in let n = try int_of_string (Sys.getenv "N") with _ -> default_n in let j = try int_of_string (Sys.getenv "J") with _ -> 4 in - let pool = Pool.create ~min:j () in + let@ pool = with_pool ~kind ~j () in ignore (stat_thread () : Thread.t); Printf.printf "n=%d, j=%d\n%!" n j; @@ -79,3 +82,11 @@ let () = assert (n1 = 1 lsl (n - 1)); assert (n2 = 1 lsl (n - 1)); () + +let () = + let@ () = Trace_tef.with_setup () in + (* + Tracy_client_trace.setup (); + *) + run_main ~kind:`Pool (); + run_main ~kind:`Simple_pool ()