From 72726a001411b9399dda63a7328a13ef33240e1a Mon Sep 17 00:00:00 2001
From: Vesa Karvonen <vesa.a.j.k@gmail.com>
Date: Tue, 23 Jul 2024 02:06:00 +0300
Subject: [PATCH] Change `Control.block ()` to raise `Sys_error` when forced to
 return

It is technically possible to finish the computation of a fiber from outside of
the fiber when using the low level Picos interface so it is not strictly
impossible for the `Trigger.await` inside `Control.block ()` to return `None`.
---
 lib/picos_structured/control.ml           |  4 ++--
 lib/picos_structured/picos_structured.mli |  6 +++++-
 test/test_structured.ml                   | 20 ++++++++++++++++++++
 3 files changed, 27 insertions(+), 3 deletions(-)

diff --git a/lib/picos_structured/control.ml b/lib/picos_structured/control.ml
index 568bf25b..a9c2fee8 100644
--- a/lib/picos_structured/control.ml
+++ b/lib/picos_structured/control.ml
@@ -1,6 +1,6 @@
 open Picos
 
-let[@inline never] impossible () = failwith "impossible"
+let[@inline never] finished () = raise (Sys_error "computation finished")
 let[@inline never] forbidden () = invalid_arg "cancelation forbidden"
 
 exception Terminate
@@ -59,7 +59,7 @@ let block () =
   let fiber = Fiber.current () in
   if Fiber.has_forbidden fiber then forbidden ();
   match Trigger.await (Trigger.create ()) with
-  | None -> impossible ()
+  | None -> finished ()
   | Some exn_bt -> Exn_bt.raise exn_bt
 
 let protect thunk = Fiber.forbid (Fiber.current ()) thunk
diff --git a/lib/picos_structured/picos_structured.mli b/lib/picos_structured/picos_structured.mli
index 3cad4f31..3203d8c4 100644
--- a/lib/picos_structured/picos_structured.mli
+++ b/lib/picos_structured/picos_structured.mli
@@ -166,7 +166,11 @@ module Control : sig
       the cancelation exception will be raised.
 
       @raise Invalid_argument in case propagation of cancelation has been
-        {{!protect} forbidden}. *)
+        {{!protect} forbidden}.
+
+      @raise Sys_error in case the underlying computation of the fiber is forced
+        to return during [block].  This is only possible when the fiber has been
+        spawned through another library. *)
 
   val terminate_after : ?callstack:int -> seconds:float -> (unit -> 'a) -> 'a
   (** [terminate_after ~seconds thunk] arranges to terminate the execution of
diff --git a/test/test_structured.ml b/test/test_structured.ml
index f72656e5..a3871e7f 100644
--- a/test/test_structured.ml
+++ b/test/test_structured.ml
@@ -102,6 +102,24 @@ let test_block_raises () =
   | () -> assert false
   | exception Invalid_argument _ -> ()
 
+let test_block_raises_sys_error () =
+  Test_scheduler.run @@ fun () ->
+  let open Picos in
+  let success = ref false in
+  let finished = Trigger.create () in
+  let computation = Computation.create () in
+  let main () =
+    begin
+      try Control.block () with Sys_error _ -> success := true
+    end;
+    Trigger.signal finished
+  in
+  Fiber.spawn ~forbid:false computation [ main ];
+  Control.sleep ~seconds:0.1;
+  Computation.finish computation;
+  Trigger.await finished |> ignore;
+  assert !success
+
 let test_termination_nests () =
   Test_scheduler.run ~max_domains:3 @@ fun () ->
   let mutex = Mutex.create () in
@@ -270,6 +288,8 @@ let () =
           test_cancelation_awaits_children;
         Alcotest.test_case "block raises when forbidden" `Quick
           test_block_raises;
+        Alcotest.test_case "block raises Sys_error when fiber finishes" `Quick
+          test_block_raises_sys_error;
         Alcotest.test_case "termination nests" `Quick test_termination_nests;
         Alcotest.test_case "promise cancelation does not terminate" `Quick
           test_promise_cancelation_does_not_terminate;