Skip to content

Commit

Permalink
Change Control.block () to raise Sys_error when forced to return
Browse files Browse the repository at this point in the history
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`.
  • Loading branch information
polytypic committed Jul 29, 2024
1 parent 74a8ff7 commit bc0a57c
Show file tree
Hide file tree
Showing 3 changed files with 27 additions and 3 deletions.
4 changes: 2 additions & 2 deletions lib/picos_structured/control.ml
Original file line number Diff line number Diff line change
@@ -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
Expand Down Expand Up @@ -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
Expand Down
6 changes: 5 additions & 1 deletion lib/picos_structured/picos_structured.mli
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down
20 changes: 20 additions & 0 deletions test/test_structured.ml
Original file line number Diff line number Diff line change
Expand Up @@ -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
Expand Down Expand Up @@ -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;
Expand Down

0 comments on commit bc0a57c

Please sign in to comment.