Merge pull request #34 from c-cube/simon/fix-cancellation-issue-2024-…

…10-03

fix fiber: use a single fut/computation in fibers

examples/discuss1.ml

@@ -0,0 +1,27 @@
+(** Example from https://discuss.ocaml.org/t/confused-about-moonpool-cancellation/15381 *)
+
+let ( let@ ) = ( @@ )
+
+let () =
+  let@ () = Trace_tef.with_setup () in
+  let@ _ = Moonpool_fib.main in
+
+  (* let@ runner = Moonpool.Ws_pool.with_ () in *)
+  let@ runner = Moonpool.Background_thread.with_ () in
+
+  (* Pretend this is some long-running read loop *)
+  for i = 1 to 10 do
+    Printf.printf "MAIN LOOP %d\n%!" i;
+    Moonpool_fib.check_if_cancelled ();
+    let _ : _ Moonpool_fib.t =
+      Moonpool_fib.spawn ~on:runner ~protect:false (fun () ->
+          Printf.printf "RUN FIBER %d\n%!" i;
+          Moonpool_fib.check_if_cancelled ();
+          Format.printf "FIBER %d NOT CANCELLED YET@." i;
+          failwith "BOOM")
+    in
+    Moonpool_fib.yield ();
+    (* Thread.delay 0.2; *)
+    (* Thread.delay 0.0001; *)
+    ()
+  done

examples/dune

@@ -0,0 +1,12 @@
+(executables
+ (names discuss1)
+ (enabled_if
+  (>= %{ocaml_version} 5.0))
+ ;(package moonpool)
+ (libraries
+  moonpool
+  moonpool.fib
+  trace
+  trace-tef
+  ;tracy-client.trace
+  ))

src/fib/fiber.ml

@@ -57,9 +57,8 @@ end
 
 include Private_
 
-let create_ ~pfiber ~runner () : 'a t =
+let create_ ~pfiber ~runner ~res () : 'a t =
   let id = Handle.generate_fresh () in
-  let res, _ = Fut.make () in
   {
     state =
       A.make
@@ -254,8 +253,8 @@ let add_child_ ~protect (self : _ t) (child : _ t) =
   done
 
 let spawn_ ~parent ~runner (f : unit -> 'a) : 'a t =
-  let comp = Picos.Computation.create () in
-  let pfiber = PF.create ~forbid:false comp in
+  let res, _ = Fut.make () in
+  let pfiber = PF.create ~forbid:false (Fut.Private_.as_computation res) in
 
   (* copy local hmap from parent, if present *)
   Option.iter
@@ -265,7 +264,7 @@ let spawn_ ~parent ~runner (f : unit -> 'a) : 'a t =
   (match parent with
   | Some p when is_closed p -> failwith "spawn: nursery is closed"
   | _ -> ());
-  let fib = create_ ~pfiber ~runner () in
+  let fib = create_ ~pfiber ~runner ~res () in
 
   let run () =
     (* make sure the fiber is accessible from inside itself *)