Skip to content

Commit

Permalink
WIP: Sleeping barbers
Browse files Browse the repository at this point in the history
  • Loading branch information
polytypic committed Jun 13, 2023
1 parent 27e78c0 commit ba41da4
Showing 1 changed file with 159 additions and 0 deletions.
159 changes: 159 additions & 0 deletions README.md
Original file line number Diff line number Diff line change
Expand Up @@ -56,6 +56,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)
- [Minimize accesses](#minimize-accesses)
Expand Down Expand Up @@ -940,6 +941,164 @@ 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**.

```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
Expand Down

0 comments on commit ba41da4

Please sign in to comment.