From f03bb6979f8737039cdfa8c4abc186cd2a69884e Mon Sep 17 00:00:00 2001
From: Vesa Karvonen <vesa.a.j.k@gmail.com>
Date: Mon, 23 Sep 2024 14:56:42 +0300
Subject: [PATCH] Note and test that certain operations are not cancelable

This can help to simplify and optimize code in some cases as these operations
are often used in finalizers.
---
 lib/picos_std.sync/picos_std_sync.mli | 18 +++++++++++++++---
 test/dune                             |  1 +
 test/test_sync.ml                     | 23 +++++++++++++++++++++++
 3 files changed, 39 insertions(+), 3 deletions(-)

diff --git a/lib/picos_std.sync/picos_std_sync.mli b/lib/picos_std.sync/picos_std_sync.mli
index 9cde2be2..c4cd77d8 100644
--- a/lib/picos_std.sync/picos_std_sync.mli
+++ b/lib/picos_std.sync/picos_std_sync.mli
@@ -59,6 +59,8 @@ module Mutex : sig
   val unlock : ?checked:bool -> t -> unit
   (** [unlock mutex] unlocks the mutex.
 
+      ℹ️ This operation is not cancelable.
+
       @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. *)
@@ -128,6 +130,8 @@ module Semaphore : sig
     val release : t -> unit
     (** [release semaphore] increments the count of the semaphore.
 
+        ℹ️ This operation is not cancelable.
+
         @raise Sys_error in case the count would overflow. *)
 
     val acquire : t -> unit
@@ -154,7 +158,9 @@ module Semaphore : sig
         [initial] is [true] and count of [0] otherwise. *)
 
     val release : t -> unit
-    (** [release semaphore] sets the count of the semaphore to [1]. *)
+    (** [release semaphore] sets the count of the semaphore to [1].
+
+        ℹ️ This operation is not cancelable. *)
 
     val acquire : t -> unit
     (** [acquire semaphore] waits until the count of the semaphore is [1] and
@@ -259,6 +265,8 @@ module Latch : sig
           invalid_arg "zero count"
       ]}
 
+      ℹ️ This operation is not cancelable.
+
       @raise Invalid_argument in case the count of the latch is zero. *)
 
   val try_incr : t -> bool
@@ -309,7 +317,9 @@ module Ivar : sig
   (** [try_poison_at ivar exn bt] attempts to poison the incremental variable
       with the specified exception and backtrace.  Returns [true] on success and
       [false] in case the variable had already been poisoned or assigned a
-      value. *)
+      value.
+
+      ℹ️ This operation is not cancelable. *)
 
   val try_poison : ?callstack:int -> 'a t -> exn -> bool
   (** [try_poison ivar exn] is equivalent to
@@ -364,7 +374,9 @@ module Stream : sig
   val poison_at : 'a t -> exn -> Printexc.raw_backtrace -> unit
   (** [poison_at stream exn bt] marks the stream as poisoned at the current
       position, which means that subsequent attempts to {!push} to the [stream]
-      will raise the given exception with backtrace. *)
+      will raise the given exception with backtrace.
+
+      ℹ️ This operation is not cancelable. *)
 
   val poison : ?callstack:int -> 'a t -> exn -> unit
   (** [poison stream exn] is equivalent to
diff --git a/test/dune b/test/dune
index d422a671..b8c4ec1e 100644
--- a/test/dune
+++ b/test/dune
@@ -59,6 +59,7 @@
    (run %{test} -- "Lazy" 1)
    (run %{test} -- "Semaphore" 0)
    (run %{test} -- "Semaphore" 1)
+   (run %{test} -- "Non-cancelable ops" 0)
    (run %{test} -- "Mutex and Condition" 0)
    (run %{test} -- "Mutex and Condition" 1)
    (run %{test} -- "Mutex and Condition" 2))))
diff --git a/test/test_sync.ml b/test/test_sync.ml
index cd5bb2b1..59cf6905 100644
--- a/test/test_sync.ml
+++ b/test/test_sync.ml
@@ -287,6 +287,26 @@ let test_event_basics () =
     | exception Exit -> ()
   end
 
+let test_non_cancelable_ops () =
+  Test_scheduler.run @@ fun () ->
+  let ivar = Ivar.create () in
+  let stream = Stream.create () in
+  let latch = Latch.create 1 in
+  let mutex = Mutex.create () in
+  let counting = Semaphore.Counting.make 0 in
+  let binary = Semaphore.Binary.make false in
+  Flock.join_after @@ fun () ->
+  Mutex.lock ~checked:(Random.bool ()) mutex;
+  Flock.terminate ();
+  try
+    Ivar.poison ivar Exit;
+    Stream.poison stream Exit;
+    Latch.decr latch;
+    Mutex.unlock ~checked:(Random.bool ()) mutex;
+    Semaphore.Counting.release counting;
+    Semaphore.Binary.release binary
+  with _ -> assert false
+
 let () =
   try
     [
@@ -308,6 +328,9 @@ let () =
           Alcotest.test_case "cancelation" `Quick test_lazy_cancelation;
         ] );
       ("Event", [ Alcotest.test_case "basics" `Quick test_event_basics ]);
+      ( "Non-cancelable ops",
+        [ Alcotest.test_case "are not canceled" `Quick test_non_cancelable_ops ]
+      );
     ]
     |> Alcotest.run ~and_exit:false "Picos_sync";
     !msgs |> List.iter (Printf.eprintf "%s\n%!")