Change bench for safe/unsafe htbl and ms queue

bench/bench_htbl.ml

@@ -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)

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)

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)

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);
   ]

src/michael_scott_queue/michael_scott_queue_intf.ml

@@ -1,5 +1,4 @@
-module type MS_QUEUE = sig
-  (*
+(*
  * Copyright (c) 2015, Théo Laurent <[email protected]>
  * Copyright (c) 2015, KC Sivaramakrishnan <[email protected]>
  *
@@ -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. *)