Forbid cancelation propagation during release

I was previously undecided on whether it should be done implicitly, but it has
turned out to be surprising, so, now I'm convinced that the right thing to do is
to forbid cancelation propagation during resource `release` calls.

The issue is that if a fiber gets canceled, then resource `release` operations
that might need to await for something asynchronous may not be properly run to
completion.  This can be surprising and, also, because this only happens in
cases of cancelation, which could happen at any moment, could be a major source
of subtle bugs.

The downside of forbidding cancelation is that in some cases a `release`
operation might block indefinitely and this can also cause issues.  However, I
believe those cases will be both harder to miss (your program hangs rather than
leaks) and easier to debug (a debugger or stack trace should be able to point
you to the `release` call).

Author: polytypic

lib/picos_std.finally/picos_std_finally.ml

@@ -32,13 +32,34 @@ let[@inline never] check_released () =
 
 (* *)
 
+let forbidden release x =
+  match Fiber.current () with
+  | fiber -> begin
+      if Fiber.exchange fiber ~forbid:true then release x
+      else
+        match release x with
+        | () -> Fiber.set fiber ~forbid:false
+        | exception exn ->
+            Fiber.set fiber ~forbid:false;
+            raise exn
+    end
+  | exception _exn ->
+      (* This should only happen when not running under a scheduler.  However,
+         we don't match on a specific exception, because it depends on the OCaml
+         version.
+
+         We also do not reraise the exception! *)
+      release x
+
+(* *)
+
 let rec drop instance =
   match Atomic.get instance with
   | Transferred | Dropped -> ()
   | Borrowed as case -> error case
   | Resource r as before ->
       if Atomic.compare_and_set instance before Dropped then begin
-        r.release r.resource;
+        forbidden r.release r.resource;
         Trigger.signal r.transferred_or_dropped
       end
       else drop instance
@@ -141,11 +162,11 @@ let[@inline never] rec move from scope =
           scope r.resource
         with
         | result ->
-            r.release r.resource;
+            forbidden r.release r.resource;
             result
         | exception exn ->
             let bt = Printexc.get_raw_backtrace () in
-            r.release r.resource;
+            forbidden r.release r.resource;
             Printexc.raise_with_backtrace exn bt
       end
       else move from scope
@@ -156,11 +177,11 @@ let[@inline never] finally release acquire scope =
   let x = acquire () in
   match scope x with
   | y ->
-      release x;
+      forbidden release x;
       y
   | exception exn ->
       let bt = Printexc.get_raw_backtrace () in
-      release x;
+      forbidden release x;
       Printexc.raise_with_backtrace exn bt
 
 external ( let@ ) : ('a -> 'b) -> 'a -> 'b = "%apply"

lib/picos_std.finally/picos_std_finally.mli

@@ -28,7 +28,10 @@ val ( let@ ) : ('a -> 'b) -> 'a -> 'b
 val finally : ('r -> unit) -> (unit -> 'r) -> ('r -> 'a) -> 'a
 (** [finally release acquire scope] calls [acquire ()] to obtain a [resource],
     calls [scope resource], and then calls [release resource] after the scope
-    exits. *)
+    exits.
+
+    ℹ️ {{!Picos_std_structured.Control.protect} Cancelation propagation will be
+    forbidden} during the call of [release]. *)
 
 (** {2 Instances} *)
 
@@ -42,7 +45,10 @@ val instantiate : ('r -> unit) -> (unit -> 'r) -> ('r instance -> 'a) -> 'a
     and stores it as an {!instance}, calls [scope instance].  Then, if [scope]
     returns normally, awaits until the {!instance} becomes empty.  In case
     [scope] raises an exception or the fiber is canceled, the instance will be
-    {{!drop} dropped}. *)
+    {{!drop} dropped}.
+
+    ℹ️ {{!Picos_std_structured.Control.protect} Cancelation propagation will be
+    forbidden} during the call of [release]. *)
 
 val drop : 'r instance -> unit
 (** [drop instance] releases the resource, if any, contained by the {!instance}.