Skip to content

Commit

Permalink
Change bench for safe/unsafe htbl and ms_queue from first class modul…
Browse files Browse the repository at this point in the history 
…e to functor (more readable). (#161)
  • Loading branch information
@lyrm
lyrm authored Nov 23, 2024
1 parent fcd94ac commit d9cd634
Show file tree
Hide file tree
Showing 5 changed files with 150 additions and 129 deletions.
119 changes: 61 additions & 58 deletions bench/bench_htbl.ml
View file
Original file line number Diff line number Diff line change
@@ -1,79 +1,82 @@
open Multicore_bench

module type BENCH = sig
val run_suite : budgetf:float -> Metric.t list
end

module Key = struct
type t = int

let equal = Int.equal
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)
143 changes: 77 additions & 66 deletions bench/bench_queue.ml
View file
Original file line number Diff line number Diff line change
@@ -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)
5 changes: 5 additions & 0 deletions bench/dune
View file
Original file line number Diff line number Diff line change
Expand Up @@ -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)
Expand Down
6 changes: 4 additions & 2 deletions bench/main.ml
View file
Original file line number Diff line number Diff line change
@@ -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);
Expand Down
6 changes: 3 additions & 3 deletions src/michael_scott_queue/michael_scott_queue_intf.ml
View file
Original file line number Diff line number Diff line change
@@ -1,5 +1,4 @@
module type MS_QUEUE = sig
(*
(*
* Copyright (c) 2015, Théo Laurent <[email protected]>
* Copyright (c) 2015, KC Sivaramakrishnan <[email protected]>
*
Expand All @@ -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
Expand All @@ -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. *)

Expand Down

0 comments on commit d9cd634

Please sign in to comment.