diff --git a/examples/discuss1.ml b/examples/discuss1.ml new file mode 100644 index 00000000..7554335e --- /dev/null +++ b/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 diff --git a/examples/dune b/examples/dune new file mode 100644 index 00000000..185cd1f9 --- /dev/null +++ b/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 + )) diff --git a/src/fib/fiber.ml b/src/fib/fiber.ml index d9f16b1e..4af7c798 100644 --- a/src/fib/fiber.ml +++ b/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 *)