CP-43755 add semaphore_vendored

Signed-off-by: Christian Lindig <[email protected]>

ocaml/xapi/semaphore_vendored.ml

@@ -0,0 +1,102 @@
+(**************************************************************************)
+(*                                                                        *)
+(*                                 OCaml                                  *)
+(*                                                                        *)
+(*          Xavier Leroy, Collège de France and INRIA Paris               *)
+(*                                                                        *)
+(*   Copyright 2020 Institut National de Recherche en Informatique et     *)
+(*     en Automatique.                                                    *)
+(*                                                                        *)
+(*   All rights reserved.  This file is distributed under the terms of    *)
+(*   the GNU Lesser General Public License version 2.1, with the          *)
+(*   special exception on linking described in the file LICENSE.          *)
+(*                                                                        *)
+(**************************************************************************)
+
+(** Semaphores *)
+
+type sem = {
+    mut: Mutex.t
+  ; (* protects [v] *)
+    mutable v: int
+  ; (* the current value *)
+    nonzero: Condition.t (* signaled when [v > 0] *)
+}
+
+module Counting = struct
+  type t = sem
+
+  let make v =
+    if v < 0 then invalid_arg "Semaphore.Counting.init: wrong initial value" ;
+    {mut= Mutex.create (); v; nonzero= Condition.create ()}
+
+  let release s =
+    Mutex.lock s.mut ;
+    if s.v < max_int then (
+      s.v <- s.v + 1 ;
+      Condition.signal s.nonzero ;
+      Mutex.unlock s.mut
+    ) else (
+      Mutex.unlock s.mut ;
+      raise (Sys_error "Semaphore.Counting.release: overflow")
+    )
+
+  let acquire s =
+    Mutex.lock s.mut ;
+    while s.v = 0 do
+      Condition.wait s.nonzero s.mut
+    done ;
+    s.v <- s.v - 1 ;
+    Mutex.unlock s.mut
+
+  let try_acquire s =
+    Mutex.lock s.mut ;
+    let ret =
+      if s.v = 0 then
+        false
+      else (
+        s.v <- s.v - 1 ;
+        true
+      )
+    in
+    Mutex.unlock s.mut ; ret
+
+  let get_value s = s.v
+end
+
+module Binary = struct
+  type t = sem
+
+  let make b =
+    {
+      mut= Mutex.create ()
+    ; v= (if b then 1 else 0)
+    ; nonzero= Condition.create ()
+    }
+
+  let release s =
+    Mutex.lock s.mut ;
+    s.v <- 1 ;
+    Condition.signal s.nonzero ;
+    Mutex.unlock s.mut
+
+  let acquire s =
+    Mutex.lock s.mut ;
+    while s.v = 0 do
+      Condition.wait s.nonzero s.mut
+    done ;
+    s.v <- 0 ;
+    Mutex.unlock s.mut
+
+  let try_acquire s =
+    Mutex.lock s.mut ;
+    let ret =
+      if s.v = 0 then
+        false
+      else (
+        s.v <- 0 ;
+        true
+      )
+    in
+    Mutex.unlock s.mut ; ret
+end