diff --git a/src/dune b/src/dune index ef116a05..d9b0d84a 100644 --- a/src/dune +++ b/src/dune @@ -9,10 +9,15 @@ (action (with-stdout-to %{targets} (run ./gen/gen.exe --ocaml %{ocaml_version} --atomic)))) - + (rule (targets domain_.ml) (action (with-stdout-to %{targets} (run ./gen/gen.exe --ocaml %{ocaml_version} --domain)))) - + +(rule + (targets suspend_.ml) + (action + (with-stdout-to %{targets} + (run ./gen/gen.exe --ocaml %{ocaml_version} --suspend)))) diff --git a/src/gen/gen.ml b/src/gen/gen.ml index e7a85e89..cb65b5d4 100644 --- a/src/gen/gen.ml +++ b/src/gen/gen.ml @@ -72,16 +72,56 @@ let spawn : _ -> t = Domain.spawn let relax = Domain.cpu_relax |} +let suspend_pre_5 = + {| +open Suspend_types_ +let suspend _ = failwith "Thread suspension is only available on OCaml >= 5.0" +let with_suspend ~run:_ f : unit = f() +|} + +let suspend_post_5 = + {| +open Suspend_types_ + +type _ Effect.t += + | Suspend : suspension_handler -> unit Effect.t + +let[@inline] suspend h = Effect.perform (Suspend h) + +let with_suspend ~run (f: unit -> unit) : unit = + let module E = Effect.Deep in + + (* effect handler *) + let effc + : type e. e Effect.t -> ((e, unit) E.continuation -> unit) option + = function + | Suspend h -> + Some (fun k -> + let k' = function + | Ok () -> E.continue k () + | Error (exn, bt) -> + E.discontinue_with_backtrace k exn bt + in + h.handle run k' + ) + | _ -> None + in + + E.try_with f () {E.effc} +|} + let p_version s = Scanf.sscanf s "%d.%d" (fun x y -> x, y) let () = let atomic = ref false in let domain = ref false in + let suspend = ref false in let ocaml = ref Sys.ocaml_version in Arg.parse [ "--atomic", Arg.Set atomic, " atomic"; "--domain", Arg.Set domain, " domain"; + "--suspend", Arg.Set suspend, " suspend"; "--ocaml", Arg.Set_string ocaml, " set ocaml version"; ] ignore ""; @@ -104,4 +144,12 @@ let () = domain_post_5 in print_endline code + ) else if !suspend then ( + let code = + if (major, minor) < (5, 0) then + suspend_pre_5 + else + suspend_post_5 + in + print_endline code ) diff --git a/src/suspend_.mli b/src/suspend_.mli new file mode 100644 index 00000000..39d6b9ed --- /dev/null +++ b/src/suspend_.mli @@ -0,0 +1,15 @@ +(** (Private) suspending tasks using Effects. + + This module is an implementation detail of Moonpool and should + not be used outside of it. *) + +open Suspend_types_ + +val suspend : suspension_handler -> unit +(** [suspend h] calls [h] with the current continuation [k]. + The suspension handler, [h], can decide to register [k] somewhere, + so it's called later. *) + +val with_suspend : run:runner -> (unit -> unit) -> unit +(** [with_suspend ~run f] runs [f()] in an environment where [suspend] + will work. It passes [run] to suspension handlers. *) diff --git a/src/suspend_types_.ml b/src/suspend_types_.ml new file mode 100644 index 00000000..765d8fe7 --- /dev/null +++ b/src/suspend_types_.ml @@ -0,0 +1,13 @@ +(** (Private) types for {!Suspend_}. + + This module is an implementation detail of Moonpool and should + not be used outside of it. *) + +type suspension = (unit, exn * Printexc.raw_backtrace) result -> unit +(** A suspended computation *) + +type runner = { run: (unit -> unit) -> unit } [@@unboxed] +(** A task runner (typically, {!Pool.t}) *) + +type suspension_handler = { handle: runner -> suspension -> unit } [@@unboxed] +(** The handler that knows what to do with the suspended computation *)