WIP: Sleeping barbers

README.md

@@ -75,6 +75,7 @@ is distributed under the [ISC license](LICENSE.md).
   - [Programming with transactional data structures](#programming-with-transactional-data-structures)
     - [The dining philosophers problem](#the-dining-philosophers-problem)
     - [A transactional LRU cache](#a-transactional-lru-cache)
+    - [The sleeping barbers problem](#the-sleeping-barbers-problem)
   - [Programming with primitive operations](#programming-with-primitive-operations)
 - [Designing lock-free algorithms with k-CAS](#designing-lock-free-algorithms-with-k-cas)
   - [Understand performance](#understand-performance)
@@ -1049,6 +1050,169 @@ val a_cache : (int, string) cache =
 As an exercise, implement an operation to `remove` associations from a cache and
 an operation to change the capacity of the cache.
 
+#### The sleeping barbers problem
+
+The
+[sleeping barber problem](https://en.wikipedia.org/wiki/Sleeping_barber_problem)
+is another classic communication and synchronization problem. Let's write a
+solution using **kcas**. There are many ways to solve the problem and, in
+particular, there is a concise and subtle implementations using semaphores.
+Instead of transliterating a solution using semaphores, our approach uses queues
+and other concurrent data structures. We also solve the generalized problem with
+multiple barbers and we also allow implement a mechanism to close the
+barbershop.
+
+```ocaml
+module Barbershop : sig
+  type ('barber, 'customer) t
+  val create : int -> ('b, 'c) t
+  val get_barber_opt : xt:'x Xt.t -> ('b, 'c) t -> 'b option
+  val try_enqueue : xt:'x Xt.t -> ('b, 'c) t -> 'c -> bool
+  val get_customer_opt : xt:'x Xt.t -> ('b, 'c) t -> 'c option
+  val sleep : xt:'x Xt.t -> ('b, 'c) t -> 'b -> unit
+  val is_closed : xt:'x Xt.t -> ('b, 'c) t -> bool
+  val close : xt:'x Xt.t -> ('b, 'c) t -> unit
+end = struct
+  type ('barber, 'customer) t = {
+    sleeping_barbers : 'barber Queue.t;
+    waiting_customers : 'customer Queue.t;
+    is_closed : bool Loc.t;
+  }
+
+  let create capacity =
+    let sleeping_barbers = Queue.create ()
+    and waiting_customers = Queue.create ~capacity ()
+    and is_closed = Loc.make false in
+    { sleeping_barbers; waiting_customers; is_closed }
+
+  let get_barber_opt ~xt bs =
+    Queue.Xt.take_opt ~xt bs.sleeping_barbers
+
+  let try_enqueue ~xt bs customer =
+    not (Xt.get ~xt bs.is_closed) &&
+    Queue.Xt.try_add ~xt customer bs.waiting_customers
+
+  let get_customer_opt ~xt bs =
+    Queue.Xt.take_opt ~xt bs.waiting_customers
+
+  let sleep ~xt bs barber =
+    if not (Xt.get ~xt bs.is_closed)
+    then Queue.Xt.add ~xt barber bs.sleeping_barbers
+
+  let is_closed ~xt bs = Xt.get ~xt bs.is_closed
+
+  let close ~xt bs =
+    Xt.set ~xt bs.is_closed true;
+    Queue.Xt.clear ~xt bs.sleeping_barbers;
+    Queue.Xt.clear ~xt bs.waiting_customers
+end
+```
+
+```ocaml
+type customer = {
+  cut_hair : 'x.xt:'x Xt.t -> unit;
+}
+
+type barber = {
+  wake_up : 'x.xt:'x Xt.t -> customer -> unit;
+}
+```
+
+```ocaml
+# let customer shop cuts =
+    let clean = Mvar.create None in
+    let self = { cut_hair = Mvar.Xt.put clean true } in
+    while not (Xt.commit { tx = Barbershop.is_closed shop }) do
+      let try_get_barber ~xt =
+        match Barbershop.get_barber_opt ~xt shop with
+        | None ->
+          Barbershop.try_enqueue ~xt shop self
+        | Some barber ->
+          barber.wake_up ~xt self;
+          true
+      in
+      if Xt.commit { tx = try_get_barber } then
+        let try_get_haircut ~xt =
+          not (Barbershop.is_closed ~xt shop) &&
+          Mvar.Xt.take ~xt clean
+        in
+        if Xt.commit { tx = try_get_haircut } then
+          Loc.incr cuts
+    done
+val customer : (barber, customer) Barbershop.t -> int Loc.t -> unit = <fun>
+```
+
+```ocaml
+# let barber shop cuts =
+    let customer = Mvar.create None in
+    let self = { wake_up = Mvar.Xt.put customer } in
+    while not (Xt.commit { tx = Barbershop.is_closed shop }) do
+      let cut customer =
+        Xt.commit { tx = customer.cut_hair };
+        Loc.incr cuts
+      in
+      let try_get_customer ~xt =
+        match Barbershop.get_customer_opt ~xt shop with
+        | Some _ as some -> some
+        | None ->
+          Barbershop.sleep ~xt shop self;
+          None
+      in
+      match Xt.commit { tx = try_get_customer } with
+      | Some customer -> cut customer
+      | None ->
+        let sleeping ~xt =
+          if Barbershop.is_closed ~xt shop then None
+          else Some (Mvar.Xt.take ~xt customer)
+        in
+        match Xt.commit { tx = sleeping } with
+        | Some customer -> cut customer
+        | None -> ()
+    done
+val barber : (barber, customer) Barbershop.t -> int Loc.t -> unit = <fun>
+```
+
+```ocaml
+# let sleeping_barbers ~barbers
+                       ~queue_max
+                       ~customers
+                       ~cuts_per_agent =
+    assert (0 < barbers
+         && 0 <= queue_max
+         && 0 <= customers
+         && 0 <= cuts_per_agent);
+    let shop = Barbershop.create queue_max in
+    let barbers = Array.init barbers @@ fun _ ->
+      let cuts = Loc.make 0 in
+      (cuts, Domain.spawn (fun () -> barber shop cuts))
+    and customers = Array.init customers @@ fun _ ->
+      let cuts = Loc.make 0 in
+      (cuts, Domain.spawn (fun () -> customer shop cuts))
+    in
+    let agents = Array.append barbers customers in
+    while agents
+          |> Array.map fst
+          |> Array.exists @@ fun c ->
+             Loc.get c < cuts_per_agent do
+      Domain.cpu_relax ()
+    done;
+    Xt.commit { tx = Barbershop.close shop };
+    agents
+    |> Array.map snd
+    |> Array.iter Domain.join
+val sleeping_barbers :
+  barbers:int -> queue_max:int -> customers:int -> cuts_per_agent:int -> unit =
+  <fun>
+```
+
+```ocaml
+# sleeping_barbers ~barbers:2
+                   ~queue_max:1
+                   ~customers:4
+                   ~cuts_per_agent:10
+- : unit = ()
+```
+
 ### Programming with primitive operations
 
 In addition to the transactional interface, **Kcas** also provides the