Add a semaphore implementation Sem using Awaitable

bench/bench_hashtbl.ml

@@ -1,4 +1,5 @@
 open Multicore_bench
+open Picos_std_sync
 
 module Key = struct
   type t = int
@@ -9,45 +10,6 @@ end
 
 module Hashtbl = Hashtbl.Make (Key)
 
-module Hashtbl_lock : sig
-  type 'v t
-
-  val create : unit -> 'v t
-  val clear : 'v t -> unit
-  val find_opt : 'v t -> Key.t -> 'v option
-  val replace : 'v t -> Key.t -> 'v -> unit
-  val remove : 'v t -> Key.t -> unit
-end = struct
-  open Picos_std_sync
-
-  type 'v t = { htbl : 'v Hashtbl.t; lock : Lock.t }
-
-  let create () =
-    { htbl = Hashtbl.create 1000; lock = Lock.create ~padded:true () }
-    |> Multicore_magic.copy_as_padded
-
-  let clear t =
-    Lock.acquire t.lock;
-    Hashtbl.clear t.htbl;
-    Lock.release t.lock
-
-  let find_opt t key =
-    Lock.acquire t.lock;
-    let result = Hashtbl.find_opt t.htbl key in
-    Lock.release t.lock;
-    result
-
-  let replace t key value =
-    Lock.acquire t.lock;
-    Hashtbl.replace t.htbl key value;
-    Lock.release t.lock
-
-  let remove t key =
-    Lock.acquire t.lock;
-    Hashtbl.remove t.htbl key;
-    Lock.release t.lock
-end
-
 let run_one ~budgetf ~n_domains ?(n_ops = 100 * Util.iter_factor)
     ?(n_keys = 1000) ~percent_mem ?(percent_add = (100 - percent_mem + 1) / 2)
     ?(prepopulate = true) ~lock_type () =
@@ -57,7 +19,9 @@ let run_one ~budgetf ~n_domains ?(n_ops = 100 * Util.iter_factor)
   assert (0 <= limit_mem && limit_mem <= 100);
   assert (limit_mem <= limit_add && limit_add <= 100);
 
-  let t = Hashtbl_lock.create () in
+  let t = Hashtbl.create 1000 in
+  let lock = Lock.create ~padded:true () in
+  let sem = Sem.create ~padded:true 1 in
 
   let n_ops = (100 + percent_mem) * n_ops / 100 in
   let n_ops = n_ops * n_domains in
@@ -68,14 +32,26 @@ let run_one ~budgetf ~n_domains ?(n_ops = 100 * Util.iter_factor)
     begin
       match lock_type with
       | `Lock ->
-          Hashtbl_lock.clear t;
+          Lock.holding lock @@ fun () ->
+          Hashtbl.clear t;
           if prepopulate then begin
             for _ = 1 to n_keys do
               let value = Random.bits () in
               let key = value mod n_keys in
-              Hashtbl_lock.replace t key value
+              Hashtbl.replace t key value
             done
           end
+      | `Sem ->
+          Sem.acquire sem;
+          Hashtbl.clear t;
+          if prepopulate then begin
+            for _ = 1 to n_keys do
+              let value = Random.bits () in
+              let key = value mod n_keys in
+              Hashtbl.replace t key value
+            done
+          end;
+          Sem.release sem
     end;
     Countdown.non_atomic_set n_ops_todo n_ops
   in
@@ -91,9 +67,49 @@ let run_one ~budgetf ~n_domains ?(n_ops = 100 * Util.iter_factor)
               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 Hashtbl_lock.find_opt t key |> ignore
-              else if op < limit_add then Hashtbl_lock.replace t key value
-              else Hashtbl_lock.remove t key
+              if op < percent_mem then begin
+                Lock.acquire lock;
+                Hashtbl.find_opt t key |> ignore;
+                Lock.release lock
+              end
+              else if op < limit_add then begin
+                Lock.acquire lock;
+                Hashtbl.replace t key value;
+                Lock.release lock
+              end
+              else begin
+                Lock.acquire lock;
+                Hashtbl.remove t key;
+                Lock.release lock
+              end
+            done;
+            work ()
+          end
+        in
+        work ()
+    | `Sem ->
+        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 begin
+                Sem.acquire sem;
+                Hashtbl.find_opt t key |> ignore;
+                Sem.release sem
+              end
+              else if op < limit_add then begin
+                Sem.acquire sem;
+                Hashtbl.replace t key value;
+                Sem.release sem
+              end
+              else begin
+                Sem.acquire sem;
+                Hashtbl.remove t key;
+                Sem.release sem
+              end
             done;
             work ()
           end
@@ -105,14 +121,14 @@ let run_one ~budgetf ~n_domains ?(n_ops = 100 * Util.iter_factor)
     Printf.sprintf "%d worker%s, %d%% reads with %s" n_domains
       (if n_domains = 1 then "" else "s")
       percent_mem
-      (match lock_type with `Lock -> "Lock")
+      (match lock_type with `Lock -> "Lock" | `Sem -> "Sem")
   in
   Times.record ~budgetf ~n_domains ~n_warmups:1 ~n_runs_min:1 ~before ~init
     ~wrap ~work ()
   |> Times.to_thruput_metrics ~n:n_ops ~singular:"operation" ~config
 
 let run_suite ~budgetf =
-  Util.cross [ 1; 2; 4; 8 ] (Util.cross [ `Lock ] [ 10; 50; 90; 95; 100 ])
+  Util.cross [ 1; 2; 4; 8 ] (Util.cross [ `Lock; `Sem ] [ 10; 50; 90; 95; 100 ])
   |> List.concat_map @@ fun (n_domains, (lock_type, percent_mem)) ->
      if Picos_domain.recommended_domain_count () < n_domains then []
      else run_one ~budgetf ~n_domains ~percent_mem ~lock_type ()

bench/bench_lock_yield.ml

@@ -16,10 +16,14 @@ let run_one ~budgetf ~n_fibers ~use_domains ~lock_type () =
     (if use_domains || is_ocaml4 then 10 else 100) * Util.iter_factor
   in
 
-  let v = ref 0 in
+  let v = ref 0 |> Multicore_magic.copy_as_padded in
   let n_ops_todo = Countdown.create ~n_domains () in
 
   let lock = Lock.create ~padded:true () in
+  let sem =
+    Sem.create ~padded:true (match lock_type with `Sem_n n -> n | _ -> 1)
+  in
+  let counter = Atomic.make 0 |> Multicore_magic.copy_as_padded in
 
   let batch = if use_domains || n_fibers < 16 then 1000 else 100 in
 
@@ -49,6 +53,37 @@ let run_one ~budgetf ~n_fibers ~use_domains ~lock_type () =
               else work ()
             in
             loop n
+      | `Sem ->
+          if n <> 0 then
+            let rec loop n =
+              if 0 < n then begin
+                Sem.acquire sem;
+                let x = !v in
+                v := x + 1;
+                Control.yield ();
+                assert (!v = x + 1);
+                v := x;
+                Sem.release sem;
+                loop (n - 1)
+              end
+              else work ()
+            in
+            loop n
+      | `Sem_n n_resources ->
+          if n <> 0 then
+            let rec loop n =
+              if 0 < n then begin
+                Sem.acquire sem;
+                Atomic.incr counter;
+                Control.yield ();
+                let n_live = Atomic.fetch_and_add counter (-1) in
+                assert (n_live <= n_resources);
+                Sem.release sem;
+                loop (n - 1)
+              end
+              else work ()
+            in
+            loop n
     in
     if use_domains then begin
       if not is_ocaml4 then Flock.fork yielder;
@@ -65,15 +100,20 @@ let run_one ~budgetf ~n_fibers ~use_domains ~lock_type () =
     Printf.sprintf "%d %s%s with %s" n_fibers
       (if use_domains then "domain" else "fiber")
       (if n_fibers = 1 then "" else "s")
-      (match lock_type with `Lock -> "Lock")
+      (match lock_type with
+      | `Lock -> "Lock"
+      | `Sem -> "Sem"
+      | `Sem_n n -> Printf.sprintf "Sem %d" n)
   in
   Times.record ~budgetf ~n_domains ~n_warmups:1 ~n_runs_min:1 ~init ~wrap ~work
     ()
   |> Times.to_thruput_metrics ~n:n_ops ~singular:"locked yield" ~config
 
 let run_suite ~budgetf =
   Util.cross [ false; true ]
-    (Util.cross [ `Lock ] [ 1; 2; 4; 8; 256; 512; 1024 ])
+    (Util.cross
+       [ `Lock; `Sem; `Sem_n 2; `Sem_n 3; `Sem_n 4 ]
+       [ 1; 2; 3; 4; 8; 256; 512; 1024 ])
   |> List.concat_map @@ fun (use_domains, (lock_type, n_fibers)) ->
      if
        use_domains

bench/bench_ref.ml

@@ -25,6 +25,8 @@ type t =
 let run_one ~budgetf ?(n_iter = 250 * Util.iter_factor) ~lock_type
     (Op (name, value, op1, op2, op_kind)) =
   let lock = Lock.create () in
+  let sem = Sem.create 1 in
+
   let loc = Ref.make value in
 
   let init _ = () in
@@ -44,16 +46,30 @@ let run_one ~budgetf ?(n_iter = 250 * Util.iter_factor) ~lock_type
           end
         in
         loop n_iter
+    | `Sem, _ ->
+        let rec loop i =
+          if i > 0 then begin
+            Sem.acquire sem;
+            op1 loc |> ignore;
+            Sem.release sem;
+            Sem.acquire sem;
+            op2 loc |> ignore;
+            Sem.release sem;
+            loop (i - 2)
+          end
+        in
+        loop n_iter
   in
 
   let config =
-    Printf.sprintf "%s with %s" name (match lock_type with `Lock -> "Lock")
+    Printf.sprintf "%s with %s" name
+      (match lock_type with `Lock -> "Lock" | `Sem -> "Sem")
   in
   Times.record ~budgetf ~n_domains:1 ~init ~wrap ~work ()
   |> Times.to_thruput_metrics ~n:n_iter ~singular:"op" ~config
 
 let run_suite ~budgetf =
-  Util.cross [ `Lock ]
+  Util.cross [ `Lock; `Sem ]
     [
       (let get x = !x in
        Op ("get", 42, get, get, `RO));

bench/dune

@@ -9,7 +9,6 @@
    (run %{test} -brief "Picos TLS")
    (run %{test} -brief "Picos DLS")
    (run %{test} -brief "Yield with Picos_std_sync")
-   (run %{test} -brief "Picos Semaphore")
    (run %{test} -brief "Picos Spawn")
    (run %{test} -brief "Picos Yield")
    (run %{test} -brief "Picos Cancel_after with Picos_select")

bench/main.ml

@@ -8,7 +8,6 @@ let benchmarks =
     ("Picos TLS", Bench_tls.run_suite);
     ("Picos DLS", Bench_dls.run_suite);
     ("Yield with Picos_std_sync", Bench_lock_yield.run_suite);
-    ("Picos Semaphore", Bench_semaphore.run_suite);
     ("Picos Spawn", Bench_spawn.run_suite);
     ("Picos Yield", Bench_yield.run_suite);
     ("Picos Cancel_after with Picos_select", Bench_cancel_after.run_suite);

lib/picos_std.sync/picos_std_sync.ml

@@ -2,6 +2,7 @@ module Mutex = Mutex
 module Condition = Condition
 module Semaphore = Semaphore
 module Lock = Lock
+module Sem = Sem
 module Lazy = Lazy
 module Latch = Latch
 module Ivar = Ivar