Repository: ocaml-multicore/picos
Pull request #63 (2024-03-21 14:02:01)

Add `picos.sync` library
This PR adds a public `picos.sync` library that initially provides

* `Mutex` &mdash; Stdlib style mutex,
* `Condition` &mdash; Stdlib style condition, and
* `Lazy` &mdash; Stdlib style suspension

that are scheduler friendly (and are parallelism safe) such that blocking does not prevent a scheduler from running other fibers on the underlying thread and that blocking operations can be canceled.

This PR also makes some additions to the core library to allow better implementation of the above constructs:
* `Fiber.Maybe` module is introduced to allow optionally dealing with a fiber without allocations.
* `Fiber.exchange` and `Fiber.set` operations are introduced to allow updating cancelation propagation without allocations.


Patch:
diff --git a/README.md b/README.md
index ec2720a..0a69ff4 100644
--- a/README.md
+++ b/README.md
@@ -1,5 +1,7 @@
 [API reference](https://ocaml-multicore.github.io/picos/doc/picos/index.html)
 &middot; [Benchmarks](https://bench.ci.dev/ocaml-multicore/picos/branch/main)
+&middot;
+[Stdlib Benchmarks](https://bench.ci.dev/ocaml-multicore/multicore-bench/branch/main)
 
 # **Picos** &mdash; Interoperable effects based concurrency
 
diff --git a/bench/bench_mutex.ml b/bench/bench_mutex.ml
new file mode 100644
index 0000000..8d9b51f
--- /dev/null
+++ b/bench/bench_mutex.ml
@@ -0,0 +1,78 @@
+open Multicore_bench
+open Picos
+open Picos_sync
+
+(** This will keep a domain running. *)
+let yielder computation =
+  let main () =
+    try
+      while true do
+        Fiber.yield ()
+      done
+    with Exit -> ()
+  in
+  Fiber.spawn ~forbid:false computation [ main ]
+
+let run_one ~budgetf ~n_fibers ~use_domains () =
+  let n_domains = if use_domains then n_fibers else 1 in
+  let n_ops = (if use_domains then 10 else 100) * Util.iter_factor in
+
+  let v = ref 0 in
+  let n_ops_todo = Atomic.make 0 |> Multicore_magic.copy_as_padded in
+  let mutex = Mutex.create () in
+
+  let init _ =
+    assert (!v = 0);
+    Atomic.set n_ops_todo n_ops
+  in
+  let wrap _ () = Scheduler.run in
+  let work _ () =
+    let n_live = Atomic.make (if use_domains then 1 else n_fibers) in
+    let computation = Computation.create () in
+    let rec work () =
+      let n = Util.alloc n_ops_todo in
+      if n <> 0 then
+        let rec loop n =
+          if 0 < n then begin
+            Mutex.lock mutex;
+            let x = !v in
+            v := x + 1;
+            Fiber.yield ();
+            assert (!v = x + 1);
+            v := x;
+            Mutex.unlock mutex;
+            loop (n - 1)
+          end
+          else work ()
+        in
+        loop n
+      else if 1 = Atomic.fetch_and_add n_live (-1) then
+        Computation.cancel computation (Exn_bt.get_callstack 0 Exit)
+    in
+    if use_domains then begin
+      yielder computation;
+      work ()
+    end
+    else begin
+      List.init n_fibers (fun _ -> work)
+      |> Fiber.spawn ~forbid:false computation;
+      Computation.wait computation
+    end
+  in
+
+  let config =
+    Printf.sprintf "%d %s%s" n_fibers
+      (if use_domains then "domain" else "fiber")
+      (if n_fibers = 1 then "" else "s")
+  in
+  Times.record ~budgetf ~n_domains ~init ~wrap ~work ()
+  |> Times.to_thruput_metrics ~n:n_ops ~singular:"locked yield" ~config
+
+let run_suite ~budgetf =
+  Util.cross [ false; true ] [ 1; 2; 4; 8 ]
+  |> List.concat_map @@ fun (use_domains, n_fibers) ->
+     if
+       use_domains
+       && (n_fibers = 1 || Picos_domain.recommended_domain_count () < n_fibers)
+     then []
+     else run_one ~budgetf ~n_fibers ~use_domains ()
diff --git a/bench/bench_ref_mutex.ml b/bench/bench_ref_mutex.ml
new file mode 100644
index 0000000..c565a95
--- /dev/null
+++ b/bench/bench_ref_mutex.ml
@@ -0,0 +1,77 @@
+open Multicore_bench
+open Picos_sync
+
+module Ref = struct
+  type 'a t = 'a ref
+
+  let make = ref
+
+  let[@inline] compare_and_set x before after =
+    !x == before
+    && begin
+         x := after;
+         true
+       end
+
+  let[@inline] exchange x after =
+    let before = !x in
+    x := after;
+    before
+end
+
+type t = Op : string * 'a * ('a Ref.t -> unit) * ('a Ref.t -> unit) -> t
+
+let run_one ~budgetf ?checked ?(n_iter = 250 * Util.iter_factor)
+    (Op (name, value, op1, op2)) =
+  let mutex = Mutex.create () in
+  let loc = Ref.make value in
+
+  let init _ = () in
+  let wrap _ () = Scheduler.run in
+  let work _ () =
+    let rec loop i =
+      if i > 0 then begin
+        Mutex.lock ?checked mutex;
+        op1 loc;
+        Mutex.unlock ?checked mutex;
+        Mutex.lock ?checked mutex;
+        op2 loc;
+        Mutex.unlock ?checked mutex;
+        loop (i - 2)
+      end
+    in
+    loop n_iter
+  in
+
+  let config =
+    Printf.sprintf "%s (%s)" name
+      (match checked with
+      | None | Some true -> "checked"
+      | Some false -> "unchecked")
+  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 [ None; Some false ]
+    [
+      (let get x = !x |> ignore in
+       Op ("get", 42, get, get));
+      (let incr x = x := !x + 1 in
+       Op ("incr", 0, incr, incr));
+      (let push x = x := 101 :: !x
+       and pop x = match !x with [] -> () | _ :: xs -> x := xs in
+       Op ("push & pop", [], push, pop));
+      (let cas01 x = Ref.compare_and_set x 0 1 |> ignore
+       and cas10 x = Ref.compare_and_set x 1 0 |> ignore in
+       Op ("cas int", 0, cas01, cas10));
+      (let xchg1 x = Ref.exchange x 1 |> ignore
+       and xchg0 x = Ref.exchange x 0 |> ignore in
+       Op ("xchg int", 0, xchg1, xchg0));
+      (let swap x =
+         let l, r = !x in
+         x := (r, l)
+       in
+       Op ("swap", (4, 2), swap, swap));
+    ]
+  |> List.concat_map @@ fun (checked, op) -> run_one ~budgetf ?checked op
diff --git a/bench/dune b/bench/dune
index 459ce86..283e63e 100644
--- a/bench/dune
+++ b/bench/dune
@@ -6,6 +6,8 @@
  (libraries
   picos
   picos.mpsc_queue
+  picos.sync
+  picos.domain
   (select
    scheduler.ml
    from
diff --git a/bench/main.ml b/bench/main.ml
index d53a314..3b35158 100644
--- a/bench/main.ml
+++ b/bench/main.ml
@@ -3,7 +3,9 @@ let benchmarks =
     ("Picos Computation", Bench_computation.run_suite);
     ("Picos Current", Bench_current.run_suite);
     ("Picos FLS (excluding Current)", Bench_fls_excluding_current.run_suite);
+    ("Picos Mutex", Bench_mutex.run_suite);
     ("Picos Yield", Bench_yield.run_suite);
+    ("Ref with Picos_sync.Mutex", Bench_ref_mutex.run_suite);
     ("Foundation Mpsc_queue", Bench_mpsc_queue.run_suite);
   ]
 
diff --git a/lib/picos/bootstrap/picos_bootstrap.ml b/lib/picos/bootstrap/picos_bootstrap.ml
index a6baf65..4597ae5 100644
--- a/lib/picos/bootstrap/picos_bootstrap.ml
+++ b/lib/picos/bootstrap/picos_bootstrap.ml
@@ -193,32 +193,42 @@ end
 module Fiber = struct
   type non_float = [ `Non_float of non_float ]
 
-  type t =
+  type _ tdt =
+    | Nothing : [> `Nothing ] tdt
     | Fiber : {
         computation : 'a Computation.t;
         mutable forbid : bool;
         mutable fls : non_float array;
       }
-        -> t
+        -> [> `Fiber ] tdt
+
+  type t = [ `Fiber ] tdt
 
   let create ~forbid computation = Fiber { computation; forbid; fls = [||] }
-  let has_forbidden (Fiber r) = r.forbid
+  let has_forbidden (Fiber r : t) = r.forbid
 
-  let is_canceled (Fiber r) =
+  let is_canceled (Fiber r : t) =
     (not r.forbid) && Computation.is_canceled r.computation
 
-  let canceled (Fiber r) =
+  let canceled (Fiber r : t) =
     if r.forbid then None else Computation.canceled r.computation
 
-  let try_attach (Fiber r) trigger =
+  let try_attach (Fiber r : t) trigger =
     Computation.try_attach r.computation trigger
 
-  let detach (Fiber r) trigger = Computation.detach r.computation trigger
+  let detach (Fiber r : t) trigger = Computation.detach r.computation trigger
   let[@inline] equal t1 t2 = t1 == t2
-  let computation (Fiber r) = Computation.Packed r.computation
-  let check (Fiber r) = if not r.forbid then Computation.check r.computation
+  let computation (Fiber r : t) = Computation.Packed r.computation
+  let check (Fiber r : t) = if not r.forbid then Computation.check r.computation
+
+  let exchange (Fiber r : t) ~forbid =
+    let before = r.forbid in
+    r.forbid <- forbid;
+    before
+
+  let set (Fiber r : t) ~forbid = r.forbid <- forbid
 
-  let explicitly (Fiber r) body ~forbid =
+  let explicitly (Fiber r : t) body ~forbid =
     if r.forbid = forbid then body ()
     else
       match body (r.forbid <- forbid) with
@@ -232,7 +242,7 @@ module Fiber = struct
   let forbid t body = explicitly t body ~forbid:true
   let permit t body = explicitly t body ~forbid:false
 
-  let try_suspend (Fiber r) trigger x y resume =
+  let try_suspend (Fiber r : t) trigger x y resume =
     if not r.forbid then begin
       if Computation.try_attach r.computation trigger then
         Trigger.on_signal trigger x y resume
@@ -283,7 +293,7 @@ module Fiber = struct
           { index; default; compute }
       | Computed compute -> { index; default = unique; compute }
 
-    let get (type a) (Fiber r) (key : a key) =
+    let get (type a) (Fiber r : t) (key : a key) =
       let fls = r.fls in
       if key.index < Array.length fls then begin
         let value = Array.unsafe_get fls key.index in
@@ -313,7 +323,7 @@ module Fiber = struct
             (Sys.opaque_identity (Obj.magic value : non_float));
           value
 
-    let set (type a) (Fiber r) (key : a key) (value : a) =
+    let set (type a) (Fiber r : t) (key : a key) (value : a) =
       let fls = r.fls in
       if key.index < Array.length fls then
         Array.unsafe_set fls key.index
diff --git a/lib/picos/picos.common.ml b/lib/picos/picos.common.ml
index 9c5777a..9202f3a 100644
--- a/lib/picos/picos.common.ml
+++ b/lib/picos/picos.common.ml
@@ -27,6 +27,37 @@ end
 module Fiber = struct
   include Picos_bootstrap.Fiber
   include Picos_ocaml.Fiber
+
+  module Maybe = struct
+    type t = T : [< `Nothing | `Fiber ] tdt -> t [@@unboxed]
+
+    let[@inline] to_fiber_or_current = function
+      | T Nothing -> current ()
+      | T (Fiber r) -> Fiber r
+
+    let[@inline] or_current t = T (to_fiber_or_current t)
+    let nothing = T Nothing
+    let[@inline] equal x y = x == y || x == nothing || y == nothing
+    let[@inline] unequal x y = x != y || x == nothing
+    let[@inline] of_fiber t = T t
+
+    let[@inline] current_if checked =
+      match checked with
+      | None | Some true -> of_fiber (current ())
+      | Some false -> nothing
+
+    let[@inline] current_and_check_if checked =
+      match checked with
+      | None | Some true ->
+          let fiber = current () in
+          check fiber;
+          of_fiber fiber
+      | Some false -> nothing
+
+    let[@inline] check = function
+      | T Nothing -> ()
+      | T (Fiber r) -> check (Fiber r)
+  end
 end
 
 module Handler = struct
diff --git a/lib/picos/picos.mli b/lib/picos/picos.mli
index 85ffe93..3807e0e 100644
--- a/lib/picos/picos.mli
+++ b/lib/picos/picos.mli
@@ -855,6 +855,9 @@ module Fiber : sig
       typically {i not} concurrency or parallelism safe, because the fiber is
       considered to be owned by a single thread of execution. *)
 
+  type fiber := t
+  (** Type alias for {!Fiber.t} within this signature. *)
+
   val current : unit -> t
   (** [current ()] returns the current fiber.
 
@@ -957,6 +960,14 @@ module Fiber : sig
 
       ⚠️ It is only safe to call [check] from the fiber itself. *)
 
+  val exchange : t -> forbid:bool -> bool
+  (** [exchange fiber ~forbid] sets the bit that tells the scheduler whether to
+      propagate cancelation or not and returns the previous state. *)
+
+  val set : t -> forbid:bool -> unit
+  (** [set fiber ~forbid] sets the bit that tells the scheduler whether to
+      propagate cancelation or not. *)
+
   module FLS : sig
     (** Fiber local storage
 
@@ -1037,6 +1048,70 @@ module Fiber : sig
   (** [detach fiber trigger] is equivalent to
       [let Packed c = computation fiber in Computation.detach c trigger]. *)
 
+  module Maybe : sig
+    (** An unboxed optional {{!Fiber.t} fiber}. *)
+
+    type t
+    (** Either a {{!Fiber.t} fiber} or {!nothing}. *)
+
+    val nothing : t
+    (** Not a fiber. *)
+
+    val of_fiber : fiber -> t
+    (** [of_fiber fiber] casts the fiber into an optional fiber.
+
+        🏎️ This performs no allocations. *)
+
+    val current_if : bool option -> t
+    (** [current_if checked] returns {!nothing} in case [checked] is
+        [Some false] and otherwise [of_fiber (Fiber.current ())]. *)
+
+    val current_and_check_if : bool option -> t
+    (** [current_check_if checked] returns {!nothing} in case [checked] is
+        [Some false] and otherwise [of_fiber (Fiber.current ())] and also calls
+        {!Fiber.check} on the fiber. *)
+
+    val or_current : t -> t
+    (** [or_current maybe] returns [of_fiber (Fiber.current ())] in case [maybe]
+        is {!nothing} and otherwise returns [maybe]. *)
+
+    val to_fiber_or_current : t -> fiber
+    (** [to_fiber_or_current maybe] returns [Fiber.current ()] in case [maybe]
+        is {!nothing} and otherwise returns the fiber that [maybe] was cast
+        from. *)
+
+    val check : t -> unit
+    (** [check maybe] returns immediately if [maybe] is [nothing] and otherwise
+        calls {!Fiber.check} on the fiber. *)
+
+    val equal : t -> t -> bool
+    (** [equal l r] determines whether [l] and [r] are maybe equal.
+        Specifically, if either [l] or [r] or both is {!nothing}, then they are
+        considered (maybe) equal.  Otherwise [l] and [r] are compared for
+        {{!Fiber.equal} physical equality}. *)
+
+    val unequal : t -> t -> bool
+    (** [equal l r] determines whether [l] and [r] are maybe unequal.
+        Specifically, if either [l] or [r] or both is {!nothing}, then they are
+        considered (maybe) unequal.  Otherwise [l] and [r] are compared for
+        {{!Fiber.equal} physical equality}. *)
+
+    (** {2 Design rationale}
+
+        The fiber identity is often needed only for the purpose of dynamically
+        checking against programming errors.  Unfortunately it can be relative
+        expensive to obtain the {{!Fiber.current} current} fiber.
+
+        As a data point, in a benchmark that increments an [int ref] protected
+        by a mutex, obtaining the fiber identity for the lock and unlock
+        operations — that only need it for error checking purposes — roughly
+        tripled the cost of an increment on a machine.
+
+        Using GADTs internally allows an optional fiber to be provided without
+        adding overhead to operations on non-optional fibers and allows optional
+        fibers to used without allocations at a very low cost. *)
+  end
+
   (** {2 Interface for schedulers} *)
 
   val create : forbid:bool -> 'a Computation.t -> t
diff --git a/lib/picos_domain/picos_domain.mli b/lib/picos_domain/picos_domain.mli
index d7748c6..baae424 100644
--- a/lib/picos_domain/picos_domain.mli
+++ b/lib/picos_domain/picos_domain.mli
@@ -10,6 +10,10 @@ val at_exit : (unit -> unit) -> unit
     On OCaml 5 this calls [Domain.at_exit].  On OCaml 4 this calls
     [Stdlib.at_exit]. *)
 
+val recommended_domain_count : unit -> int
+(** [recommended_domain_count ()] returns [1] on OCaml 4 and
+    [Domain.recommended_domain_count ()] on OCaml 5.  *)
+
 module DLS : sig
   (** Domain-local storage for Picos. *)
 
diff --git a/lib/picos_domain/picos_domain.ocaml4.ml b/lib/picos_domain/picos_domain.ocaml4.ml
index 40c9867..7bac688 100644
--- a/lib/picos_domain/picos_domain.ocaml4.ml
+++ b/lib/picos_domain/picos_domain.ocaml4.ml
@@ -1,4 +1,5 @@
 let at_exit = Stdlib.at_exit
+let recommended_domain_count () = 1
 
 module DLS = struct
   type 'a state = Value of { mutable value : 'a } | Default of (unit -> 'a)
diff --git a/lib/picos_domain/picos_domain.ocaml5.ml b/lib/picos_domain/picos_domain.ocaml5.ml
index 59e7453..efe5356 100644
--- a/lib/picos_domain/picos_domain.ocaml5.ml
+++ b/lib/picos_domain/picos_domain.ocaml5.ml
@@ -1,4 +1,5 @@
 let at_exit = Domain.at_exit
+let recommended_domain_count = Domain.recommended_domain_count
 
 module DLS = struct
   include Domain.DLS
diff --git a/lib/picos_sync/condition.ml b/lib/picos_sync/condition.ml
new file mode 100644
index 0000000..730ea26
--- /dev/null
+++ b/lib/picos_sync/condition.ml
@@ -0,0 +1,105 @@
+open Picos
+
+type state = Empty | Queue of { head : Trigger.t list; tail : Trigger.t list }
+type t = state Atomic.t
+
+let create ?(padded = false) () =
+  let t = Atomic.make Empty in
+  if padded then Multicore_magic.copy_as_padded t else t
+
+let broadcast t =
+  if Atomic.get t != Empty then
+    match Atomic.exchange t Empty with
+    | Empty -> ()
+    | Queue r ->
+        List.iter Trigger.signal r.head;
+        List.iter Trigger.signal (List.rev r.tail)
+
+(* We try to avoid starvation of signal by making it so that when, at the start
+   of signal or wait, the head is empty, the tail is reversed into the head.
+   This way both signal and wait attempt O(1) and O(n) operations at the same
+   time. *)
+
+let rec signal t backoff =
+  match Atomic.get t with
+  | Empty -> ()
+  | Queue r as before -> begin
+      match r.head with
+      | trigger :: head ->
+          signal_cas t backoff before
+            (if head == [] && r.tail == [] then Empty else Queue { r with head })
+            trigger
+      | [] -> begin
+          match List.rev r.tail with
+          | trigger :: head ->
+              signal_cas t backoff before
+                (if head == [] then Empty else Queue { head; tail = [] })
+                trigger
+          | [] -> failwith "impossible"
+        end
+    end
+
+and signal_cas t backoff before after trigger =
+  if Atomic.compare_and_set t before after then Trigger.signal trigger
+  else signal t (Backoff.once backoff)
+
+let signal t = signal t Backoff.default
+
+let rec cleanup backoff trigger t =
+  (* We have been canceled.  If we can't drop our trigger from the variable, we
+     signal the next trigger in queue to make sure each signal wakes up at least
+     one non-canceled waiter if possible. *)
+  match Atomic.get t with
+  | Empty -> ()
+  | Queue r as before -> begin
+      if r.head != [] then
+        match List_ext.drop_first_or_not_found trigger r.head with
+        | head ->
+            cleanup_cas backoff trigger t before
+              (if head == [] && r.tail == [] then Empty
+               else Queue { r with head })
+        | exception Not_found -> begin
+            match List_ext.drop_first_or_not_found trigger r.tail with
+            | tail ->
+                cleanup_cas backoff trigger t before (Queue { r with tail })
+            | exception Not_found -> signal t
+          end
+      else
+        match List_ext.drop_first_or_not_found trigger r.tail with
+        | tail ->
+            cleanup_cas backoff trigger t before
+              (if tail == [] then Empty else Queue { head = []; tail })
+        | exception Not_found -> signal t
+    end
+
+and cleanup_cas backoff trigger t before after =
+  if not (Atomic.compare_and_set t before after) then
+    cleanup (Backoff.once backoff) trigger t
+
+let rec wait t mutex trigger fiber backoff =
+  let before = Atomic.get t in
+  let after =
+    match before with
+    | Empty -> Queue { head = [ trigger ]; tail = [] }
+    | Queue r ->
+        if r.head != [] then Queue { r with tail = trigger :: r.tail }
+        else Queue { head = List.rev_append r.tail [ trigger ]; tail = [] }
+  in
+  if Atomic.compare_and_set t before after then begin
+    Mutex.unlock_as (Fiber.Maybe.of_fiber fiber) mutex Backoff.default;
+    let result = Trigger.await trigger in
+    let forbid = Fiber.exchange fiber ~forbid:true in
+    Mutex.lock_as (Fiber.Maybe.of_fiber fiber) mutex Backoff.default;
+    Fiber.set fiber ~forbid;
+    match result with
+    | None -> ()
+    | Some exn_bt ->
+        cleanup Backoff.default trigger t;
+        Exn_bt.raise exn_bt
+  end
+  else wait t mutex trigger fiber (Backoff.once backoff)
+
+let wait t mutex =
+  let fiber = Fiber.current () in
+  let trigger = Trigger.create () in
+  wait t mutex trigger fiber Backoff.default
diff --git a/lib/picos_sync/dune b/lib/picos_sync/dune
new file mode 100644
index 0000000..6905b64
--- /dev/null
+++ b/lib/picos_sync/dune
@@ -0,0 +1,4 @@
+(library
+ (name picos_sync)
+ (public_name picos.sync)
+ (libraries picos backoff multicore-magic))
diff --git a/lib/picos_sync/mutex.ml b/lib/picos_sync/mutex.ml
new file mode 100644
index 0000000..345e131
--- /dev/null
+++ b/lib/picos_sync/mutex.ml
@@ -0,0 +1,134 @@
+open Picos
+
+let[@inline never] owner () = raise (Sys_error "Mutex: owner")
+let[@inline never] unlocked () = raise (Sys_error "Mutex: unlocked")
+let[@inline never] not_owner () = raise (Sys_error "Mutex: not owner")
+
+type entry = { trigger : Trigger.t; fiber : Fiber.Maybe.t }
+
+type state =
+  | Unlocked
+  | Locked of { fiber : Fiber.Maybe.t; head : entry list; tail : entry list }
+
+type t = state Atomic.t
+
+let create ?(padded = false) () =
+  let t = Atomic.make Unlocked in
+  if padded then Multicore_magic.copy_as_padded t else t
+
+(* We try to avoid starvation of unlock by making it so that when, at the start
+   of lock or unlock, the head is empty, the tail is reversed into the head.
+   This way both lock and unlock attempt O(1) and O(n) operations at the same
+   time. *)
+
+let locked_nothing =
+  Locked { fiber = Fiber.Maybe.nothing; head = []; tail = [] }
+
+let rec unlock_as owner t backoff =
+  match Atomic.get t with
+  | Unlocked -> unlocked ()
+  | Locked r as before ->
+      if Fiber.Maybe.equal r.fiber owner then
+        match r.head with
+        | { trigger; fiber } :: rest ->
+            let after = Locked { r with fiber; head = rest } in
+            transfer_as owner t backoff before after trigger
+        | [] -> begin
+            match List.rev r.tail with
+            | { trigger; fiber } :: rest ->
+                let after = Locked { fiber; head = rest; tail = [] } in
+                transfer_as owner t backoff before after trigger
+            | [] ->
+                if not (Atomic.compare_and_set t before Unlocked) then
+                  unlock_as owner t (Backoff.once backoff)
+          end
+      else not_owner ()
+
+and transfer_as owner t backoff before after trigger =
+  if Atomic.compare_and_set t before after then Trigger.signal trigger
+  else unlock_as owner t (Backoff.once backoff)
+
+let[@inline] unlock ?checked t =
+  let owner = Fiber.Maybe.current_if checked in
+  unlock_as owner t Backoff.default
+
+let rec cleanup_as entry t backoff =
+  (* We have been canceled.  If we are the owner, we must unlock the mutex.
+     Otherwise we must remove our entry from the queue. *)
+  match Atomic.get t with
+  | Locked r as before ->
+      (* At this point we must use strict physical equality [==] rather than
+         [Fiber.Maybe.equal]! *)
+      if r.fiber == entry.fiber then unlock_as entry.fiber t backoff
+      else if r.head != [] then
+        match List_ext.drop_first_or_not_found entry r.head with
+        | head ->
+            let after = Locked { r with head } in
+            cancel_as entry t backoff before after
+        | exception Not_found ->
+            let tail = List_ext.drop_first_or_not_found entry r.tail in
+            let after = Locked { r with tail } in
+            cancel_as entry t backoff before after
+      else
+        let tail =
+          List_ext.drop_first_or_not_found entry r.tail (* wont raise *)
+        in
+        let after = Locked { r with tail } in
+        cancel_as entry t backoff before after
+  | Unlocked -> unlocked () (* impossible *)
+
+and cancel_as fiber t backoff before after =
+  if not (Atomic.compare_and_set t before after) then
+    cleanup_as fiber t (Backoff.once backoff)
+
+let rec lock_as fiber t backoff =
+  match Atomic.get t with
+  | Unlocked as before ->
+      let after =
+        if fiber == Fiber.Maybe.nothing then locked_nothing
+        else Locked { fiber; head = []; tail = [] }
+      in
+      if not (Atomic.compare_and_set t before after) then
+        lock_as fiber t (Backoff.once backoff)
+  | Locked r as before ->
+      let fiber = Fiber.Maybe.or_current fiber in
+      if Fiber.Maybe.unequal r.fiber fiber then
+        let trigger = Trigger.create () in
+        let entry = { trigger; fiber } in
+        let after =
+          if r.head == [] then
+            Locked { r with head = List.rev_append r.tail [ entry ]; tail = [] }
+          else Locked { r with tail = entry :: r.tail }
+        in
+        if Atomic.compare_and_set t before after then begin
+          match Trigger.await trigger with
+          | None -> ()
+          | Some exn_bt ->
+              cleanup_as entry t Backoff.default;
+              Exn_bt.raise exn_bt
+        end
+        else lock_as fiber t (Backoff.once backoff)
+      else owner ()
+
+let[@inline] lock ?checked t =
+  let fiber = Fiber.Maybe.current_and_check_if checked in
+  lock_as fiber t Backoff.default
+
+let try_lock ?checked t =
+  let fiber = Fiber.Maybe.current_and_check_if checked in
+  Atomic.get t == Unlocked
+  && Atomic.compare_and_set t Unlocked
+       (if fiber == Fiber.Maybe.nothing then locked_nothing
+        else Locked { fiber; head = []; tail = [] })
+
+let protect ?checked t body =
+  let fiber = Fiber.Maybe.current_and_check_if checked in
+  lock_as fiber t Backoff.default;
+  match body () with
+  | value ->
+      unlock_as fiber t Backoff.default;
+      value
+  | exception exn ->
+      let bt = Printexc.get_raw_backtrace () in
+      unlock_as fiber t Backoff.default;
+      Printexc.raise_with_backtrace exn bt
diff --git a/lib/picos_sync/picos_sync.ml b/lib/picos_sync/picos_sync.ml
new file mode 100644
index 0000000..075338d
--- /dev/null
+++ b/lib/picos_sync/picos_sync.ml
@@ -0,0 +1,3 @@
+module Mutex = Mutex
+module Condition = Condition
+module Lazy = Lazy
diff --git a/lib/picos_sync/picos_sync.mli b/lib/picos_sync/picos_sync.mli
new file mode 100644
index 0000000..c67643e
--- /dev/null
+++ b/lib/picos_sync/picos_sync.mli
@@ -0,0 +1,150 @@
+(** A library of basic communication and synchronization primitives for
+    {!Picos}. *)
+
+module Mutex : sig
+  (** A mutex implementation for {!Picos}.
+
+      ℹ️ This intentionally mimics the interface of {!Stdlib.Mutex}.  Unlike with
+      the standard library mutex, blocking on this mutex potentially allows an
+      effects based scheduler to run other fibers on the thread.
+
+      🏎️ The optional [checked] argument taken by most of the operations defaults
+      to [true].  When explicitky specified as [~checked:false] the mutex
+      implementation may avoid having to obtain the {{!Picos.Fiber.current}
+      current fiber}, which expensive relative to locking or unlocking an
+      uncontested mutex.  Note that specifying [~checked:false] on an operation
+      may prevent error checking also on a subsequent operation. *)
+
+  type t
+  (** Represents a mutual-exclusion lock or mutex. *)
+
+  val create : ?padded:bool -> unit -> t
+  (** [create ()] returns a new mutex that is initially unlocked. *)
+
+  val lock : ?checked:bool -> t -> unit
+  (** [lock mutex] locks the [mutex].
+
+      ℹ️ If the fiber has been canceled and propagation of cancelation is
+      allowed, this may raise the cancelation exception before locking the
+      mutex.  If [~checked:false] was specified, the cancelation exception may
+      or may not be raised.
+
+      @raise Sys_error if the mutex is already locked by the fiber.  If
+        [~checked:false] was specified for some previous operation on the mutex
+        the exception may or may not be raised. *)
+
+  val try_lock : ?checked:bool -> t -> bool
+  (** [try_lock mutex] locks the mutex in case the mutex is unlocked.  Returns
+      [true] on success and [false] in case the mutex was locked.
+
+      ℹ️ If the fiber has been canceled and propagation of cancelation is
+      allowed, this may raise the cancelation exception before locking the
+      mutex.  If [~checked:false] was specified, the cancelation exception may
+      or may not be raised. *)
+
+  val unlock : ?checked:bool -> t -> unit
+  (** [unlock mutex] unlocks the mutex.
+
+      @raise Sys_error if the mutex was locked by another fiber.  If
+        [~checked:false] was specified for some previous operation on the mutex
+        the exception may or may not be raised. *)
+
+  val protect : ?checked:bool -> t -> (unit -> 'a) -> 'a
+  (** [protect mutex thunk] locks the [mutex], runs [thunk ()], and unlocks the
+      [mutex] after [thunk ()] returns or raises.
+
+      ℹ️ If the fiber has been canceled and propagation of cancelation is
+      allowed, this may raise the cancelation exception before locking the
+      mutex.  If [~checked:false] was specified, the cancelation exception may
+      or may not be raised.
+
+      @raise Sys_error for the same reasons as {!lock} and {!unlock}. *)
+end
+
+module Condition : sig
+  (** A condition implementation for {!Picos}.
+
+      ℹ️ This intentionally mimics the interface of {!Stdlib.Condition}.  Unlike
+      with the standard library condition variable, blocking on this condition
+      variable allows an effects based scheduler to run other fibers on the
+      thread. *)
+
+  type t
+  (** Represents a condition variable. *)
+
+  val create : ?padded:bool -> unit -> t
+  (** [create ()] return a new condition variable. *)
+
+  val wait : t -> Mutex.t -> unit
+  (** [wait condition] unlocks the [mutex], waits for the [condition], and locks
+      the [mutex] before returning or raising due to the operation being
+      canceled.
+
+      ℹ️ If the fiber has been canceled and propagation of cancelation is
+      allowed, this may raise the cancelation exception. *)
+
+  val signal : t -> unit
+  (** [signal condition] wakes up one fiber waiting on the [condition] variable
+      unless there are no such fibers. *)
+
+  val broadcast : t -> unit
+  (** [broadcast condition] wakes up all the fibers waiting on the [condition]
+      variable. *)
+end
+
+module Lazy : sig
+  (** A lazy implementation for {!Picos}.
+
+      ℹ️ This intentionally mimics the interface of {!Stdlib.Lazy}.  Unlike with
+      the stadard library suspensions an attempt to force a suspension from
+      multiple fibers, possibly running on different domains, does not raise the
+      {!Undefined} exception. *)
+
+  exception Undefined
+  (** Synonym for {!Stdlib.Lazy.Undefined}. *)
+
+  type !'a t
+  (** Represents a deferred computation or suspension. *)
+
+  val from_fun : (unit -> 'a) -> 'a t
+  (** [from_fun thunk] returns a suspension. *)
+
+  val from_val : 'a -> 'a t
+  (** [from_val value] returns an already forced suspension whose result is the
+      given [value]. *)
+
+  val is_val : 'a t -> bool
+  (** [is_val susp] determines whether the suspension has already been forced
+      and didn't raise an exception. *)
+
+  val force : 'a t -> 'a
+  (** [force susp] forces the suspension, i.e. computes [thunk ()] using the
+      [thunk] passed to {!from_fun}, stores the result of the computation to the
+      suspension and reproduces its result.  In case the suspension has already
+      been forced the computation is skipped and stored result is reproduced.
+
+      ℹ️ This will check whether the current fiber has been canceled before
+      starting the computation of [thunk ()].  This allows the suspension to be
+      forced by another fiber.  However, if the fiber is canceled and the
+      cancelation exception is raised after the computation has been started,
+      the suspension will then store the cancelation exception.
+
+      @raise Undefined in case the suspension is currently being forced by the
+        {{!Picos.Fiber.current} current} fiber. *)
+
+  val force_val : 'a t -> 'a
+  (** [force_val] is a synonym for {!force}. *)
+
+  val map : ('a -> 'b) -> 'a t -> 'b t
+  (** [map fn susp] is equivalent to:
+      {[from_fun (fun () -> fn (force susp))]} *)
+
+  val map_val : ('a -> 'b) -> 'a t -> 'b t
+  (** [map_val fn susp] is equivalent to:
+      {@ocaml skip[
+        if is_val susp then
+          from_val (fn (force susp))
+        else
+          map fn susp
+      ]} *)
+end


Test patch:
diff --git a/test/lib/elements/lazy.ml b/lib/picos_sync/lazy.ml
similarity index 78%
rename from test/lib/elements/lazy.ml
rename to lib/picos_sync/lazy.ml
index 81fadc1..2ad92d0 100644
--- a/test/lib/elements/lazy.ml
+++ b/lib/picos_sync/lazy.ml
@@ -1,5 +1,6 @@
 open Picos
-open Foundation
+
+exception Undefined = Stdlib.Lazy.Undefined
 
 type 'a state =
   | Fun of (unit -> 'a)
@@ -17,7 +18,7 @@ let rec cleanup t trigger backoff =
   | Val _ | Exn _ -> ()
   | Fun _ -> failwith "impossible"
   | Run r as before -> begin
-      match List.drop_first_or_not_found trigger r.triggers with
+      match List_ext.drop_first_or_not_found trigger r.triggers with
       | triggers ->
           let after = Run { r with triggers } in
           if not (Atomic.compare_and_set t before after) then
@@ -47,7 +48,7 @@ let rec force t fiber backoff =
       end
       else force t fiber (Backoff.once backoff)
   | Run r as before ->
-      if Fiber.equal r.fiber fiber then raise Stdlib.Lazy.Undefined
+      if Fiber.equal r.fiber fiber then raise Undefined
       else
         let trigger = Trigger.create () in
         let triggers = trigger :: r.triggers in
@@ -65,6 +66,20 @@ let force t =
   match Atomic.get t with
   | Val v -> v
   | Exn r -> Printexc.raise_with_backtrace r.exn r.trace
-  | Fun _ | Run _ -> force t (Fiber.current ()) Backoff.default
+  | Fun _ | Run _ ->
+      let fiber = Fiber.current () in
+      Fiber.check fiber;
+      force t fiber Backoff.default
 
 let map f t = from_fun @@ fun () -> f (force t)
+
+let is_val t =
+  match Atomic.get t with Val _ -> true | Fun _ | Run _ | Exn _ -> false
+
+let map_val f t =
+  match Atomic.get t with
+  | Val x -> from_val (f x)
+  | Exn { exn; trace } -> Printexc.raise_with_backtrace exn trace
+  | _ -> map f t
+
+let force_val = force
diff --git a/test/lib/foundation/list.ml b/lib/picos_sync/list_ext.ml
similarity index 62%
rename from test/lib/foundation/list.ml
rename to lib/picos_sync/list_ext.ml
index d17d2da..7952992 100644
--- a/test/lib/foundation/list.ml
+++ b/lib/picos_sync/list_ext.ml
@@ -1,7 +1,3 @@
-include Stdlib.List
-
 let[@tail_mod_cons] rec drop_first_or_not_found x' = function
   | [] -> raise_notrace Not_found
   | x :: xs -> if x == x' then xs else x :: drop_first_or_not_found x' xs
-
-let drop_first x' xs = try drop_first_or_not_found x' xs with Not_found -> xs
diff --git a/test/dune b/test/dune
index f17a62b..6aa1cdf 100644
--- a/test/dune
+++ b/test/dune
@@ -26,6 +26,14 @@
 
 ;;
 
+(test
+ (name test_sync)
+ (package picos)
+ (modules test_sync)
+ (libraries picos picos.sync test_scheduler alcotest domain_shims))
+
+;;
+
 (rule
  (action
   (progn
diff --git a/test/lib/elements/lazy.mli b/test/lib/elements/lazy.mli
deleted file mode 100644
index 332d082..0000000
--- a/test/lib/elements/lazy.mli
+++ /dev/null
@@ -1,16 +0,0 @@
-(** A lazy implementation for Picos *)
-
-type !'a t
-(** *)
-
-val from_fun : (unit -> 'a) -> 'a t
-(** *)
-
-val from_val : 'a -> 'a t
-(** *)
-
-val force : 'a t -> 'a
-(** *)
-
-val map : ('a -> 'b) -> 'a t -> 'b t
-(** *)
diff --git a/test/lib/elements/sync.ml b/test/lib/elements/sync.ml
deleted file mode 100644
index 6f0f825..0000000
--- a/test/lib/elements/sync.ml
+++ /dev/null
@@ -1,225 +0,0 @@
-open Picos
-open Foundation
-
-module Checked = struct
-  type entry = { trigger : Trigger.t; fiber : Fiber.t }
-
-  type state =
-    | Unlocked
-    | Locked of { fiber : Fiber.t; head : entry list; tail : entry list }
-
-  type t = state Atomic.t
-
-  let create () = Atomic.make Unlocked
-  let[@inline never] owner () = raise (Sys_error "Mutex: owner")
-  let[@inline never] unlocked () = raise (Sys_error "Mutex: unlocked")
-  let[@inline never] not_owner () = raise (Sys_error "Mutex: not owner")
-
-  (* We try to avoid starvation of unlock by making it so that when, at the start
-     of lock or unlock, the head is empty, the tail is reversed into the head.
-     This way both lock and unlock attempt O(1) and O(n) operations at the same
-     time. *)
-
-  let rec unlock_as t owner backoff =
-    match Atomic.get t with
-    | Unlocked -> unlocked ()
-    | Locked r as before ->
-        if Fiber.equal r.fiber owner then
-          match r.head with
-          | { trigger; fiber } :: rest ->
-              let after = Locked { r with fiber; head = rest } in
-              transfer_as t owner before after trigger backoff
-          | [] -> begin
-              match List.rev r.tail with
-              | { trigger; fiber } :: rest ->
-                  let after = Locked { fiber; head = rest; tail = [] } in
-                  transfer_as t owner before after trigger backoff
-              | [] ->
-                  if not (Atomic.compare_and_set t before Unlocked) then
-                    unlock_as t owner (Backoff.once backoff)
-            end
-        else not_owner ()
-
-  and transfer_as t owner before after trigger backoff =
-    if Atomic.compare_and_set t before after then Trigger.signal trigger
-    else unlock_as t owner (Backoff.once backoff)
-
-  let unlock t = unlock_as t (Fiber.current ()) Backoff.default
-
-  let rec cleanup_as t entry backoff =
-    (* We have been canceled.  If we are the owner, we must unlock the mutex.
-       Otherwise we must remove our entry from the queue. *)
-    match Atomic.get t with
-    | Locked r as before ->
-        if Fiber.equal r.fiber entry.fiber then unlock_as t entry.fiber backoff
-        else if r.head != [] then
-          match List.drop_first_or_not_found entry r.head with
-          | head ->
-              let after = Locked { r with head } in
-              cancel_as t entry before after backoff
-          | exception Not_found ->
-              let tail = List.drop_first_or_not_found entry r.tail in
-              let after = Locked { r with tail } in
-              cancel_as t entry before after backoff
-        else
-          let tail =
-            List.drop_first_or_not_found entry r.tail (* wont raise *)
-          in
-          let after = Locked { r with tail } in
-          cancel_as t entry before after backoff
-    | Unlocked -> unlocked () (* impossible *)
-
-  and cancel_as t fiber before after backoff =
-    if not (Atomic.compare_and_set t before after) then
-      cleanup_as t fiber (Backoff.once backoff)
-
-  let rec lock_as t fiber backoff =
-    match Atomic.get t with
-    | Unlocked as before ->
-        let after = Locked { fiber; head = []; tail = [] } in
-        if not (Atomic.compare_and_set t before after) then
-          lock_as t fiber (Backoff.once backoff)
-    | Locked r as before ->
-        if Fiber.equal r.fiber fiber then owner ()
-        else
-          let trigger = Trigger.create () in
-          let entry = { trigger; fiber } in
-          let after =
-            if r.head == [] then
-              Locked
-                { r with head = List.rev_append [ entry ] r.tail; tail = [] }
-            else Locked { r with tail = entry :: r.tail }
-          in
-          if Atomic.compare_and_set t before after then begin
-            match Trigger.await trigger with
-            | None -> ()
-            | Some exn_bt ->
-                cleanup_as t entry Backoff.default;
-                Exn_bt.raise exn_bt
-          end
-          else lock_as t fiber (Backoff.once backoff)
-
-  let lock t = lock_as t (Fiber.current ()) Backoff.default
-
-  let try_lock t =
-    let fiber = Fiber.current () in
-    Atomic.get t == Unlocked
-    && Atomic.compare_and_set t Unlocked
-         (Locked { fiber; head = []; tail = [] })
-
-  let protect t body =
-    let fiber = Fiber.current () in
-    lock_as t fiber Backoff.default;
-    match body () with
-    | value ->
-        unlock_as t fiber Backoff.default;
-        value
-    | exception exn ->
-        let bt = Printexc.get_raw_backtrace () in
-        unlock_as t fiber Backoff.default;
-        Printexc.raise_with_backtrace exn bt
-
-  let succumb t body =
-    let fiber = Fiber.current () in
-    unlock_as t fiber Backoff.default;
-    match body () with
-    | value ->
-        Fiber.forbid fiber (fun () -> lock_as t fiber Backoff.default);
-        value
-    | exception exn ->
-        let bt = Printexc.get_raw_backtrace () in
-        Fiber.forbid fiber (fun () -> lock_as t fiber Backoff.default);
-        Printexc.raise_with_backtrace exn bt
-end
-
-module Make (Mutex : Sync_intf.Mutex) :
-  Sync_intf.Condition with type mutex := Mutex.t = struct
-  type state = { head : Trigger.t list; tail : Trigger.t list }
-
-  let empty = { head = []; tail = [] }
-
-  type t = state Atomic.t
-
-  let create () = Atomic.make empty
-
-  let broadcast t =
-    if Atomic.get t != empty then begin
-      let state = Atomic.exchange t empty in
-      List.iter Trigger.signal state.head;
-      List.iter Trigger.signal (List.rev state.tail)
-    end
-
-  let update_head before head =
-    if head == [] && before.tail == [] then empty else { before with head }
-
-  let[@inline] of_head head = if head == [] then empty else { head; tail = [] }
-  let[@inline] of_tail tail = if tail == [] then empty else { head = []; tail }
-
-  (* We try to avoid starvation of signal by making it so that when, at the start
-     of signal or wait, the head is empty, the tail is reversed into the head.
-     This way both signal and wait attempt O(1) and O(n) operations at the same
-     time. *)
-
-  let rec signal backoff t =
-    let before = Atomic.get t in
-    if before != empty then
-      match before.head with
-      | trigger :: head ->
-          signal_cas backoff t before (update_head before head) trigger
-      | [] -> begin
-          match List.rev before.tail with
-          | trigger :: head ->
-              signal_cas backoff t before (of_head head) trigger
-          | [] -> failwith "impossible"
-        end
-
-  and signal_cas backoff t before after trigger =
-    if Atomic.compare_and_set t before after then Trigger.signal trigger
-    else signal (Backoff.once backoff) t
-
-  let signal t = signal Backoff.default t
-
-  let rec cleanup backoff trigger t =
-    (* We have been canceled.  If we can't drop our trigger from the variable, we
-       signal the next trigger in queue to make sure each signal wakes up at least
-       one non-canceled waiter if possible. *)
-    let before = Atomic.get t in
-    if before != empty then
-      if before.head != [] then
-        match List.drop_first_or_not_found trigger before.head with
-        | head -> cleanup_cas backoff trigger t before (update_head before head)
-        | exception Not_found -> begin
-            match List.drop_first_or_not_found trigger before.tail with
-            | tail -> cleanup_cas backoff trigger t before { before with tail }
-            | exception Not_found -> signal t
-          end
-      else
-        match List.drop_first_or_not_found trigger before.tail with
-        | tail -> cleanup_cas backoff trigger t before (of_tail tail)
-        | exception Not_found -> signal t
-
-  and cleanup_cas backoff trigger t before after =
-    if not (Atomic.compare_and_set t before after) then
-      cleanup (Backoff.once backoff) trigger t
-
-  let rec wait backoff trigger t mutex =
-    let before = Atomic.get t in
-    let after =
-      if before == empty then { head = [ trigger ]; tail = [] }
-      else if before.head != [] then
-        { before with tail = trigger :: before.tail }
-      else
-        let head = List.rev_append [ trigger ] before.tail in
-        { head; tail = [] }
-    in
-    if Atomic.compare_and_set t before after then begin
-      match Mutex.succumb mutex @@ fun () -> Trigger.await trigger with
-      | None -> ()
-      | Some exn_bt ->
-          cleanup Backoff.default trigger t;
-          Exn_bt.raise exn_bt
-    end
-    else wait (Backoff.once backoff) trigger t mutex
-
-  let wait t mutex = wait Backoff.default (Trigger.create ()) t mutex
-end
diff --git a/test/lib/elements/sync.mli b/test/lib/elements/sync.mli
deleted file mode 100644
index 5c885e8..0000000
--- a/test/lib/elements/sync.mli
+++ /dev/null
@@ -1,8 +0,0 @@
-(** Mutex and Condition implementations for Picos *)
-
-module Checked : Sync_intf.Mutex
-(** *)
-
-(** *)
-module Make : functor (Mutex : Sync_intf.Mutex) ->
-  Sync_intf.Condition with type mutex := Mutex.t
diff --git a/test/lib/elements/sync_intf.ml b/test/lib/elements/sync_intf.ml
deleted file mode 100644
index d0c6997..0000000
--- a/test/lib/elements/sync_intf.ml
+++ /dev/null
@@ -1,46 +0,0 @@
-module type Mutex = sig
-  (** A mutex implementation for Picos *)
-
-  type t
-  (** *)
-
-  val create : unit -> t
-  (** *)
-
-  val lock : t -> unit
-  (** *)
-
-  val try_lock : t -> bool
-  (** *)
-
-  val unlock : t -> unit
-  (** *)
-
-  val protect : t -> (unit -> 'a) -> 'a
-  (** *)
-
-  val succumb : t -> (unit -> 'a) -> 'a
-  (** *)
-end
-
-module type Condition = sig
-  (** A condition implementation for Picos *)
-
-  type mutex
-  (** *)
-
-  type t
-  (** *)
-
-  val create : unit -> t
-  (** *)
-
-  val wait : t -> mutex -> unit
-  (** *)
-
-  val signal : t -> unit
-  (** *)
-
-  val broadcast : t -> unit
-  (** *)
-end
diff --git a/test/lib/foundation/list.mli b/test/lib/foundation/list.mli
deleted file mode 100644
index 98deec2..0000000
--- a/test/lib/foundation/list.mli
+++ /dev/null
@@ -1,7 +0,0 @@
-include module type of Stdlib.List
-
-val drop_first_or_not_found : 'a -> 'a list -> 'a list
-(** *)
-
-val drop_first : 'a -> 'a list -> 'a list
-(** *)
diff --git a/test/test_sync.ml b/test/test_sync.ml
new file mode 100644
index 0000000..9cb11e5
--- /dev/null
+++ b/test/test_sync.ml
@@ -0,0 +1,218 @@
+open Picos
+open Picos_sync
+
+module Fiber = struct
+  include Fiber
+
+  let start thunk =
+    let computation = Computation.create () in
+    Fiber.spawn ~forbid:false computation
+      [ Computation.capture computation thunk ];
+    computation
+
+  let run thunk = Computation.await (start thunk)
+end
+
+let is_ocaml4 = String.starts_with ~prefix:"4." Sys.ocaml_version
+
+let test_mutex_and_condition_basics () =
+  Test_scheduler.run @@ fun () ->
+  let mutex = Mutex.create () in
+  let condition = Condition.create () in
+
+  [ None; Some false ]
+  |> List.iter @@ fun checked ->
+     [ Computation.create (); Computation.finished ]
+     |> List.iter @@ fun computation ->
+        [ Condition.signal; Condition.broadcast ]
+        |> List.iter @@ fun release ->
+           let n = Atomic.make 10 in
+           let test = Computation.create () in
+
+           let main () =
+             Mutex.protect ?checked mutex (fun () ->
+                 Condition.wait condition mutex);
+             if 1 = Atomic.fetch_and_add n (-1) then Computation.finish test
+           in
+           Fiber.spawn ~forbid:false computation
+             (List.init (Atomic.get n) @@ fun _ -> main);
+
+           while Computation.is_running test do
+             Fiber.yield ();
+             release condition
+           done
+
+let test_mutex_and_condition_errors () =
+  Test_scheduler.run @@ fun () ->
+  let mutex = Mutex.create () in
+  let condition = Condition.create () in
+  Mutex.protect mutex @@ fun () ->
+  begin
+    match Fiber.run (fun () -> Mutex.unlock mutex) with
+    | () -> assert false
+    | exception Sys_error _ -> ()
+  end;
+  begin
+    match Fiber.run (fun () -> Condition.wait condition mutex) with
+    | () -> assert false
+    | exception Sys_error _ -> ()
+  end
+
+let test_mutex_and_condition_cancelation () =
+  let mutex = Mutex.create () in
+  let condition = Condition.create () in
+
+  let step = ref 0 in
+
+  let step_1 = Atomic.make 0 in
+  let step_2 = Atomic.make 0 in
+  let step_3 = Atomic.make 0 in
+  let step_4 = Atomic.make 0 in
+  let step_5 = Atomic.make 0 in
+
+  let steps = [| step_1; step_2; step_3; step_4; step_5 |] in
+
+  let exit_exn_bt = Exn_bt.get_callstack 0 Exit in
+
+  let n = if 4 <= Domain.recommended_domain_count () - 2 then 4 else 2 in
+
+  let computations =
+    Array.init n @@ fun _ -> Computation.Packed (Computation.create ())
+  in
+
+  let attempt i finished ?checked () =
+    computations.(i) <- Fiber.computation (Fiber.current ());
+    match
+      Atomic.incr step_1;
+      Domain.cpu_relax ();
+      Mutex.lock ?checked mutex
+    with
+    | () -> begin
+        let n = !step in
+        Atomic.incr step_2;
+        Domain.cpu_relax ();
+        step := n + 1;
+        match Condition.wait condition mutex with
+        | () ->
+            let n = !step in
+            Atomic.incr step_3;
+            Domain.cpu_relax ();
+            step := n + 1;
+            Mutex.unlock ?checked mutex;
+            Trigger.signal finished
+        | exception _ ->
+            let n = !step in
+            Atomic.incr step_4;
+            Domain.cpu_relax ();
+            step := n + 1;
+            Mutex.unlock ?checked mutex;
+            Trigger.signal finished
+      end
+    | exception _ ->
+        Atomic.incr step_5;
+        Trigger.signal finished
+  in
+
+  let exit = Atomic.make n in
+
+  let limit = if is_ocaml4 then 1_000 else 10_000 in
+
+  let some_false = Some false in
+
+  let main i () =
+    Fun.protect ~finally:(fun () -> Atomic.decr exit) @@ fun () ->
+    Test_scheduler.run @@ fun () ->
+    let state = Random.State.make_self_init () in
+    while Array.exists (fun step -> Atomic.get step < limit) steps do
+      let finished = Trigger.create () in
+      let checked = if Random.State.bool state then None else some_false in
+      Fiber.spawn ~forbid:false (Computation.create ())
+        [ attempt i finished ?checked ];
+      Trigger.await finished |> ignore
+    done
+  in
+  let domains =
+    Domain.spawn (fun () ->
+        let state = Random.State.make_self_init () in
+        while Atomic.get exit <> 0 do
+          Domain.cpu_relax ();
+          let (Packed computation) =
+            computations.(Random.State.bits state land (n - 1))
+          in
+          Computation.cancel computation exit_exn_bt
+        done)
+    :: List.init n (fun i -> Domain.spawn (main i))
+  in
+  let state = Random.State.make_self_init () in
+  while Atomic.get exit <> 0 do
+    Domain.cpu_relax ();
+    if Random.State.bool state then Condition.broadcast condition
+    else Condition.signal condition
+  done;
+  List.iter Domain.join domains;
+  assert (!step = Atomic.get step_2 + Atomic.get step_3 + Atomic.get step_4);
+  Array.iter (fun step -> assert (limit <= Atomic.get step)) steps
+
+let test_lazy_basics () =
+  Test_scheduler.run @@ fun () ->
+  assert (101 = (Lazy.from_fun (fun () -> 101) |> Lazy.force_val));
+  assert (42 = (Lazy.from_val 40 |> Lazy.map (( + ) 2) |> Lazy.force));
+  assert (42 = (Lazy.from_val 21 |> Lazy.map_val (( * ) 2) |> Lazy.force_val));
+  let s = ref (Lazy.from_val 0) in
+  s := Lazy.from_fun (fun () -> 1 + Lazy.force !s);
+  match Lazy.force !s with
+  | _ -> assert false
+  | exception Stdlib.Lazy.Undefined -> ()
+
+let test_lazy_cancelation () =
+  Test_scheduler.run @@ fun () ->
+  let susp ?to_signal ~to_await result =
+    Lazy.from_fun @@ fun () ->
+    Option.iter Trigger.signal to_signal;
+    match Trigger.await to_await with
+    | None -> result
+    | Some exn_bt -> Exn_bt.raise exn_bt
+  in
+  assert (
+    let to_await = Trigger.create () in
+    let s = susp ~to_await 42 in
+    let tried = Atomic.make false in
+    let main () =
+      match Lazy.force s with
+      | _ -> assert false
+      | exception Exit -> Atomic.set tried true
+    in
+    let computation = Computation.create () in
+    Computation.cancel computation (Exn_bt.get_callstack 0 Exit);
+    Fiber.spawn ~forbid:false computation [ main ];
+    while not (Atomic.get tried) do
+      Fiber.yield ()
+    done;
+    Trigger.signal to_await;
+    (not (Lazy.is_val s)) && Lazy.force s = 42);
+
+  let to_await = Trigger.create () in
+  let to_signal = Trigger.create () in
+  let s = susp ~to_signal ~to_await 101 in
+  let c = Fiber.start @@ fun () -> Lazy.force s in
+  Trigger.await to_signal |> ignore;
+  Computation.cancel c (Exn_bt.get_callstack 0 Exit);
+  Trigger.signal to_await;
+  match Lazy.force s with _ -> assert false | exception Exit -> ()
+
+let () =
+  [
+    ( "Mutex and Condition",
+      [
+        Alcotest.test_case "basics" `Quick test_mutex_and_condition_basics;
+        Alcotest.test_case "errors" `Quick test_mutex_and_condition_errors;
+        Alcotest.test_case "cancelation" `Quick
+          test_mutex_and_condition_cancelation;
+      ] );
+    ( "Lazy",
+      [
+        Alcotest.test_case "basics" `Quick test_lazy_basics;
+        Alcotest.test_case "cancelation" `Quick test_lazy_cancelation;
+      ] );
+  ]
+  |> Alcotest.run "Picos_sync"