diff --git a/bench/bench_htbl.ml b/bench/bench_htbl.ml index 970e7a0b..52d88a46 100644 --- a/bench/bench_htbl.ml +++ b/bench/bench_htbl.ml @@ -1,5 +1,9 @@ open Multicore_bench +module type BENCH = sig + val run_suite : budgetf:float -> Metric.t list +end + module Key = struct type t = int @@ -7,73 +11,72 @@ module Key = struct let hash = Fun.id end -let run_one ~budgetf ~n_domains ?(n_ops = 20 * Util.iter_factor) - ?(n_keys = 10000) ~percent_mem ?(percent_add = (100 - percent_mem + 1) / 2) - ?(prepopulate = true) ~unsafe (module Htbl : Htbl_intf.HTBL) = - let limit_mem = percent_mem in - let limit_add = percent_mem + percent_add in +module Make (Htbl : Htbl_intf.HTBL) : BENCH = struct + let run_one ~budgetf ~n_domains ?(n_ops = 20 * Util.iter_factor) + ?(n_keys = 10000) ~percent_mem + ?(percent_add = (100 - percent_mem + 1) / 2) ?(prepopulate = true) () = + let limit_mem = percent_mem in + let limit_add = percent_mem + percent_add in - assert (0 <= limit_mem && limit_mem <= 100); - assert (limit_mem <= limit_add && limit_add <= 100); + assert (0 <= limit_mem && limit_mem <= 100); + assert (limit_mem <= limit_add && limit_add <= 100); - let t = Htbl.create ~hashed_type:(module Key) () in + let t = Htbl.create ~hashed_type:(module Key) () in - let n_ops = (100 + percent_mem) * n_ops / 100 in - let n_ops = n_ops * n_domains in + let n_ops = (100 + percent_mem) * n_ops / 100 in + let n_ops = n_ops * n_domains in - let n_ops_todo = Countdown.create ~n_domains () in + let n_ops_todo = Countdown.create ~n_domains () in - let before () = - let _ : _ Seq.t = Htbl.remove_all t in - Countdown.non_atomic_set n_ops_todo n_ops - in - let init i = - let state = Random.State.make_self_init () in - if prepopulate then begin - let n = ((i + 1) * n_keys / n_domains) - (i * n_keys / n_domains) in - for _ = 1 to n do - let value = Random.State.bits state in - let key = value mod n_keys in - Htbl.try_add t key value |> ignore - done - end; - state - in - let work domain_index state = - let rec work () = - let n = Countdown.alloc n_ops_todo ~domain_index ~batch:1000 in - if n <> 0 then begin + let before () = + let _ : _ Seq.t = Htbl.remove_all t in + Countdown.non_atomic_set n_ops_todo n_ops + in + let init i = + let state = Random.State.make_self_init () in + if prepopulate then begin + let n = ((i + 1) * n_keys / n_domains) - (i * n_keys / n_domains) in for _ = 1 to n do let value = Random.State.bits state in - let op = (value asr 20) mod 100 in let key = value mod n_keys in - if op < percent_mem then - match Htbl.find_exn t key with _ -> () | exception Not_found -> () - else if op < limit_add then Htbl.try_add t key value |> ignore - else Htbl.try_remove t key |> ignore - done; - work () - end + Htbl.try_add t key value |> ignore + done + end; + state + in + let work domain_index state = + let rec work () = + let n = Countdown.alloc n_ops_todo ~domain_index ~batch:1000 in + if n <> 0 then begin + for _ = 1 to n do + let value = Random.State.bits state in + let op = (value asr 20) mod 100 in + let key = value mod n_keys in + if op < percent_mem then + match Htbl.find_exn t key with + | _ -> () + | exception Not_found -> () + else if op < limit_add then Htbl.try_add t key value |> ignore + else Htbl.try_remove t key |> ignore + done; + work () + end + in + work () in - work () - in - let config = - Printf.sprintf "%d worker%s, %d%% reads %s" n_domains - (if n_domains = 1 then "" else "s") - percent_mem - (if unsafe then " (unsafe)" else "") - in - Times.record ~budgetf ~n_domains ~before ~init ~work () - |> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config + let config = + Printf.sprintf "%d worker%s, %d%% reads" n_domains + (if n_domains = 1 then "" else "s") + percent_mem + in + Times.record ~budgetf ~n_domains ~before ~init ~work () + |> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config -let run_suite ~budgetf = - let run ~unsafe (module Htbl : Htbl_intf.HTBL) = + let run_suite ~budgetf = Util.cross [ 10; 50; 90 ] [ 1; 2; 4 ] |> List.concat_map @@ fun (percent_mem, n_domains) -> - run_one ~budgetf ~n_domains ~percent_mem ~unsafe (module Htbl) - in - List.fold_right2 - (fun safe unsafe acc -> safe :: unsafe :: acc) - (run ~unsafe:false (module Saturn.Htbl)) - (run ~unsafe:true (module Saturn.Htbl_unsafe)) - [] + run_one ~budgetf ~n_domains ~percent_mem () +end + +module Safe = Make (Saturn.Htbl) +module Unsafe = Make (Saturn.Htbl_unsafe) diff --git a/bench/bench_queue.ml b/bench/bench_queue.ml index 3b5dfc9d..dc285c68 100644 --- a/bench/bench_queue.ml +++ b/bench/bench_queue.ml @@ -1,79 +1,90 @@ open Multicore_bench -module Queue = Saturn.Queue -let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = - let t = Queue.create () in +module type BENCH = sig + val run_suite : budgetf:float -> Metric.t list +end - let op push = if push then Queue.push t 101 else Queue.pop_opt t |> ignore in +module Make (Queue : Michael_scott_queue_intf.MS_QUEUE) : BENCH = struct + let run_one_domain ~budgetf ?(n_msgs = 50 * Util.iter_factor) () = + let t = Queue.create () in - let init _ = - assert (Queue.is_empty t); - Util.generate_push_and_pop_sequence n_msgs - in - let work _ bits = Util.Bits.iter op bits in + let op push = + if push then Queue.push t 101 else Queue.pop_opt t |> ignore + in - Times.record ~budgetf ~n_domains:1 ~init ~work () - |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config:"one domain" + let init _ = + assert (Queue.is_empty t); + Util.generate_push_and_pop_sequence n_msgs + in + let work _ bits = Util.Bits.iter op bits in -let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2) - ?(n_msgs = 50 * Util.iter_factor) () = - let n_domains = n_adders + n_takers in + Times.record ~budgetf ~n_domains:1 ~init ~work () + |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" + ~config:"one domain" - let t = Queue.create () in + let run_one ~budgetf ?(n_adders = 2) ?(n_takers = 2) + ?(n_msgs = 50 * Util.iter_factor) () = + let n_domains = n_adders + n_takers in - let n_msgs_to_take = Atomic.make 0 |> Multicore_magic.copy_as_padded in - let n_msgs_to_add = Atomic.make 0 |> Multicore_magic.copy_as_padded in + let t = Queue.create () in - let init _ = - assert (Queue.is_empty t); - Atomic.set n_msgs_to_take n_msgs; - Atomic.set n_msgs_to_add n_msgs - in - let work i () = - if i < n_adders then - let rec work () = - let n = Util.alloc n_msgs_to_add in - if 0 < n then begin - for i = 1 to n do - Queue.push t i - done; - work () - end - in - work () - else - let rec work () = - let n = Util.alloc n_msgs_to_take in - if n <> 0 then - let rec loop n = - if 0 < n then begin - match Queue.pop_opt t with - | None -> - Domain.cpu_relax (); - loop n - | Some _ -> loop (n - 1) - end - else work () - in - loop n - in - work () - in + let n_msgs_to_take = Atomic.make 0 |> Multicore_magic.copy_as_padded in + let n_msgs_to_add = Atomic.make 0 |> Multicore_magic.copy_as_padded in - let config = - let format role n = - Printf.sprintf "%d %s%s" n role (if n = 1 then "" else "s") + let init _ = + assert (Queue.is_empty t); + Atomic.set n_msgs_to_take n_msgs; + Atomic.set n_msgs_to_add n_msgs + in + let work i () = + if i < n_adders then + let rec work () = + let n = Util.alloc n_msgs_to_add in + if 0 < n then begin + for i = 1 to n do + Queue.push t i + done; + work () + end + in + work () + else + let rec work () = + let n = Util.alloc n_msgs_to_take in + if n <> 0 then + let rec loop n = + if 0 < n then begin + match Queue.pop_opt t with + | None -> + Domain.cpu_relax (); + loop n + | Some _ -> loop (n - 1) + end + else work () + in + loop n + in + work () in - Printf.sprintf "%s, %s" - (format "nb adder" n_adders) - (format "nb taker" n_takers) - in - Times.record ~budgetf ~n_domains ~init ~work () - |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config + let config = + let format role n = + Printf.sprintf "%d %s%s" n role (if n = 1 then "" else "s") + in + Printf.sprintf "%s, %s" + (format "nb adder" n_adders) + (format "nb taker" n_takers) + in + + Times.record ~budgetf ~n_domains ~init ~work () + |> Times.to_thruput_metrics ~n:n_msgs ~singular:"message" ~config + + let run_suite ~budgetf = + run_one_domain ~budgetf () + @ (Util.cross [ 1; 2 ] [ 1; 2 ] + |> List.concat_map @@ fun (n_adders, n_takers) -> + run_one ~budgetf ~n_adders ~n_takers ()) +end -let run_suite ~budgetf = - run_one_domain ~budgetf () - @ (Util.cross [ 1; 2 ] [ 1; 2 ] - |> List.concat_map @@ fun (n_adders, n_takers) -> - run_one ~budgetf ~n_adders ~n_takers ()) +module Safe = Make (Saturn.Queue) +module Unsafe = Make (Saturn.Queue_unsafe) diff --git a/bench/dune b/bench/dune index 0e22cbd8..671a62c5 100644 --- a/bench/dune +++ b/bench/dune @@ -12,6 +12,11 @@ let () = (copy ../src/htbl/htbl_intf.mli htbl_intf.ml)) (package saturn)) +(rule + (action + (copy ../src/michael_scott_queue/michael_scott_queue_intf.ml michael_scott_queue_intf.ml)) + (package saturn)) + (test (package saturn) (name main) diff --git a/bench/main.ml b/bench/main.ml index 1c9fefb8..c072d174 100644 --- a/bench/main.ml +++ b/bench/main.ml @@ -1,10 +1,12 @@ let benchmarks = [ - ("Saturn Queue", Bench_queue.run_suite); + ("Saturn Queue", Bench_queue.Safe.run_suite); + ("Saturn Queue_unsafe", Bench_queue.Unsafe.run_suite); ("Saturn Single_prod_single_cons_queue", Bench_spsc_queue.run_suite); ("Saturn Size", Bench_size.run_suite); ("Saturn Skiplist", Bench_skiplist.run_suite); - ("Saturn Htbl", Bench_htbl.run_suite); + ("Saturn Htbl", Bench_htbl.Safe.run_suite); + ("Saturn Htbl_unsafe", Bench_htbl.Unsafe.run_suite); ("Saturn Stack", Bench_stack.run_suite); ("Saturn Work_stealing_deque", Bench_ws_deque.run_suite); ("Saturn Bounded_Stack", Bench_bounded_stack.run_suite); diff --git a/src/michael_scott_queue/michael_scott_queue_intf.ml b/src/michael_scott_queue/michael_scott_queue_intf.ml index a35deaa2..9b63e79a 100644 --- a/src/michael_scott_queue/michael_scott_queue_intf.ml +++ b/src/michael_scott_queue/michael_scott_queue_intf.ml @@ -1,5 +1,4 @@ -module type MS_QUEUE = sig - (* +(* * Copyright (c) 2015, Théo Laurent * Copyright (c) 2015, KC Sivaramakrishnan * @@ -16,7 +15,7 @@ module type MS_QUEUE = sig * OR IN CONNECTION WITH THE USE OR PERFORMANCE OF THIS SOFTWARE. *) - (** +(** Michael-Scott classic multi-producer multi-consumer queue. All functions are lockfree. It is the recommended starting point @@ -26,6 +25,7 @@ module type MS_QUEUE = sig Queue Algorithms}. *) +module type MS_QUEUE = sig type 'a t (** The type of lock-free queue. *)