diff --git a/.github/workflows/build.yml b/.github/workflows/build.yml index 365d78a5bd..c7cfd20d93 100644 --- a/.github/workflows/build.yml +++ b/.github/workflows/build.yml @@ -57,6 +57,11 @@ jobs: skip-effects: false skip-test: false skip-doc: false + - os: ubuntu-latest + ocaml-compiler: "5.1" + skip-effects: false + skip-test: false + skip-doc: true # Note this OCaml compiler is bytecode only - os: ubuntu-latest ocaml-compiler: "ocaml-variants.5.2.0+options,ocaml-option-32bit" diff --git a/CHANGES.md b/CHANGES.md index d4d59a036f..77f1fc32fa 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -6,7 +6,10 @@ * Merged Wasm_of_ocaml (#1724) * Lib: removed no longer relevant Js.optdef type annotations (#1769) * Misc: drop support for IE -* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in better performance when no effect handler is installed +* Effects: add an optional feature of "dynamic switching" between CPS + and direct style, resulting in better performance when + no effect handler is installed +* Compiler/Runtime: Make resuming a continuation more efficient in js (#1765) ## Bug fixes * Fix small bug in global data flow analysis (#1768) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 6caf2ebb94..3d1debdeb3 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -613,11 +613,34 @@ let cps_block ~st ~k ~orig_pc block = in let rewrite_last_instr (x : Var.t) (e : expr) : (k:Var.t -> instr list * last) option = - let perform_effect ~effect_ ~continuation = + let perform_effect ~effect_ continuation_and_tail = Some (fun ~k -> let e = - Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; Pv k ]) + match Config.target () with + | `JavaScript -> ( + match continuation_and_tail with + | None -> Prim (Extern "caml_perform_effect", [ Pv effect_; Pv k ]) + | Some (continuation, tail) -> + Prim + ( Extern "caml_reperform_effect" + , [ Pv effect_; continuation; tail; Pv k ] )) + | `Wasm -> ( + (* temporary until we finish the change to the wasmoo + runtime *) + match continuation_and_tail with + | None -> + Prim + ( Extern "caml_perform_effect" + , [ Pv effect_ + ; Pc (Int Targetint.zero) + ; Pc (Int Targetint.zero) + ; Pv k + ] ) + | Some (continuation, tail) -> + Prim + ( Extern "caml_perform_effect" + , [ Pv effect_; continuation; tail; Pv k ] )) in let x = Var.fresh () in [ Let (x, e) ], Return x) @@ -628,22 +651,22 @@ let cps_block ~st ~k ~orig_pc block = (fun ~k -> let exact = exact || call_exact st.flow_info f (List.length args) in tail_call ~st ~exact ~in_cps:true ~check:true ~f (args @ [ k ])) - | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> + | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg; tail ]) -> Some (fun ~k -> let k' = Var.fresh_n "cont" in tail_call ~st - ~instrs:[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; Pv k ])) ] + ~instrs: + [ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; tail; Pv k ])) ] ~exact:(call_exact st.flow_info f 1) ~in_cps:true ~check:true ~f [ arg; k' ]) - | Prim (Extern "%perform", [ Pv effect_ ]) -> - perform_effect ~effect_ ~continuation:(Pc (Int Targetint.zero)) - | Prim (Extern "%reperform", [ Pv effect_; continuation ]) -> - perform_effect ~effect_ ~continuation + | Prim (Extern "%perform", [ Pv effect_ ]) -> perform_effect ~effect_ None + | Prim (Extern "%reperform", [ Pv effect_; continuation; tail ]) -> + perform_effect ~effect_ (Some (continuation, tail)) | _ -> None in @@ -712,14 +735,14 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = ; Let (cps_c, Closure (cps_params, cps_cont)) ; Let (x, Prim (Extern "caml_cps_closure", [ Pv direct_c; Pv cps_c ])) ] - | Let (x, Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ])) -> - [ Let (x, Prim (Extern "caml_resume", [ Pv f; Pv arg; Pv stack ])) ] - | Let (x, Prim (Extern "%perform", [ Pv effect_ ])) -> + | Let (x, Prim (Extern "%resume", [ stack; f; arg; tail ])) -> + [ Let (x, Prim (Extern "caml_resume", [ f; arg; stack; tail ])) ] + | Let (x, Prim (Extern "%perform", [ effect_ ])) -> (* In direct-style code, we just raise [Effect.Unhandled]. *) - [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] - | Let (x, Prim (Extern "%reperform", [ Pv effect_; Pv _continuation ])) -> + [ Let (x, Prim (Extern "caml_raise_unhandled", [ effect_ ])) ] + | Let (x, Prim (Extern "%reperform", [ effect_; _continuation; _tail ])) -> (* Similar to previous case *) - [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] + [ Let (x, Prim (Extern "caml_raise_unhandled", [ effect_ ])) ] | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> (* We just need to call [f] in direct style. *) let unit = Var.fresh_n "unit" in diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 9c982b6441..33ce57f9d2 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -2368,7 +2368,6 @@ and compile infos pc state (instrs : instr list) = let func = State.peek 0 state in let arg = State.peek 1 state in let x, state = State.fresh_var state in - if debug_parser () then Format.printf @@ -2381,23 +2380,30 @@ and compile infos pc state (instrs : instr list) = func Var.print arg; - let state = + let state, tail = match Ocaml_version.compare Ocaml_version.current [ 5; 2 ] < 0 with - | true -> State.pop 2 state - | false -> State.pop 3 state + | true -> State.pop 2 state, Pc (Int (Targetint.of_int_exn 0)) + | false -> + let tail = State.peek 2 state in + State.pop 3 state, Pv tail in - compile infos (pc + 1) state - (Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg ])) :: instrs) + (Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg; tail ])) :: instrs) | RESUMETERM -> let stack = State.accu state in let func = State.peek 0 state in let arg = State.peek 1 state in let x, state = State.fresh_var state in - + let tail = + match Ocaml_version.compare Ocaml_version.current [ 5; 2 ] < 0 with + | true -> Pc (Int (Targetint.of_int_exn 0)) + | false -> + let tail = State.peek 2 state in + Pv tail + in if debug_parser () then Format.printf @@ -2408,7 +2414,7 @@ and compile infos pc state (instrs : instr list) = func Var.print arg; - ( Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg ])) :: instrs + ( Let (x, Prim (Extern "%resume", [ Pv stack; Pv func; Pv arg; tail ])) :: instrs , Return x , state ) | PERFORM -> @@ -2425,13 +2431,13 @@ and compile infos pc state (instrs : instr list) = | REPERFORMTERM -> let eff = State.accu state in let stack = State.peek 0 state in - (* We don't need [State.peek 1 state] *) + let tail = State.peek 1 state in let state = State.pop 2 state in let x, state = State.fresh_var state in if debug_parser () then Format.printf "return reperform(%a, %a)@." Var.print eff Var.print stack; - ( Let (x, Prim (Extern "%reperform", [ Pv eff; Pv stack ])) :: instrs + ( Let (x, Prim (Extern "%reperform", [ Pv eff; Pv stack; Pv tail ])) :: instrs , Return x , state ) | EVENT | BREAK | FIRST_UNIMPLEMENTED_OP -> assert false) diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index 79dccf4286..7fd3b0483f 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -35,9 +35,6 @@ caml_bigstring_blit_string_to_ba caml_bigstring_memcmp caml_hash_mix_bigstring -From +effect.js: -jsoo_effect_not_supported - From +fs.js: caml_ba_map_file caml_ba_map_file_bytecode diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index 072c9a3757..7ed561d2ff 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -144,9 +144,6 @@ caml_bigstring_blit_string_to_ba caml_bigstring_memcmp caml_hash_mix_bigstring -From +effect.js: -jsoo_effect_not_supported - From +fs.js: caml_ba_map_file caml_ba_map_file_bytecode diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index 507d923f0c..8c229d44dd 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -109,9 +109,6 @@ caml_bigstring_blit_string_to_ba caml_bigstring_memcmp caml_hash_mix_bigstring -From +effect.js: -jsoo_effect_not_supported - From +fs.js: caml_ba_map_file caml_ba_map_file_bytecode diff --git a/compiler/tests-full/stdlib.cma.expected.js b/compiler/tests-full/stdlib.cma.expected.js index a314cd8eeb..72a730b576 100644 --- a/compiler/tests-full/stdlib.cma.expected.js +++ b/compiler/tests-full/stdlib.cma.expected.js @@ -36136,8 +36136,8 @@ /*<>*/ return 0; var x = /*<>*/ param[2], - _i_ = /*<>*/ caml_call1(Stdlib_Printexc[26], x), - msg = /*<>*/ caml_call2(Stdlib_Printf[4], _a_, _i_); + _o_ = /*<>*/ caml_call1(Stdlib_Printexc[26], x), + msg = /*<>*/ caml_call2(Stdlib_Printf[4], _a_, _o_); /*<>*/ return [0, msg]; /*<>*/ } /*<>*/ caml_call1(Stdlib_Printexc[9], printer); @@ -36155,22 +36155,28 @@ "Effect.Continuation_already_resumed", Continuation_already_resumed); function continue$0(k, v){ - var _h_ = /*<>*/ caml_continuation_use_noexc(k); - function _g_(x){ + var + _l_ = /*<>*/ k[2], + _n_ = caml_continuation_use_noexc(k); + function _m_(x){ /*<>*/ return x; /*<>*/ } /*<>*/ return jsoo_effect_not_supported() /*<>*/ ; } function discontinue(k, e){ - var _f_ = /*<>*/ caml_continuation_use_noexc(k); - function _e_(e){ + var + _i_ = /*<>*/ k[2], + _k_ = caml_continuation_use_noexc(k); + function _j_(e){ /*<>*/ throw caml_maybe_attach_backtrace(e, 1); /*<>*/ } /*<>*/ return jsoo_effect_not_supported() /*<>*/ ; } function discontinue_with_backtrace(k, e, bt){ - var _d_ = /*<>*/ caml_continuation_use_noexc(k); - function _c_(e){ + var + _f_ = /*<>*/ k[2], + _h_ = caml_continuation_use_noexc(k); + function _g_(e){ /*<>*/ caml_restore_raw_backtrace(e, bt); throw caml_maybe_attach_backtrace(e, 0); /*<>*/ } @@ -36187,8 +36193,9 @@ } var s = - /*<>*/ caml_alloc_stack(handler[1], handler[2], effc); - /*<>*/ return jsoo_effect_not_supported() /*<>*/ ; + /*<>*/ caml_alloc_stack(handler[1], handler[2], effc), + _e_ = /*<>*/ 0; + return jsoo_effect_not_supported() /*<>*/ ; } function try_with(comp, arg, handler){ function effc(eff, k, last_fiber){ @@ -36208,8 +36215,9 @@ function(e){ /*<>*/ throw caml_maybe_attach_backtrace(e, 1); /*<>*/ }, - effc); - /*<>*/ return jsoo_effect_not_supported() /*<>*/ ; + effc), + _d_ = /*<>*/ 0; + return jsoo_effect_not_supported() /*<>*/ ; } var Deep = @@ -36243,7 +36251,7 @@ var s = /*<>*/ caml_alloc_stack(error, error, effc); /*<>*/ try{ /*<>*/ jsoo_effect_not_supported(); - var _b_ = /*<>*/ 0; + var _b_ = /*<>*/ 0, _c_ = 0; } catch(exn$0){ var exn = /*<>*/ caml_wrap_exception(exn$0); @@ -36263,6 +36271,7 @@ /*<>*/ return caml_call1(f, k) /*<>*/ ; } var + last_fiber = /*<>*/ k[2], stack = /*<>*/ runtime.caml_continuation_use_and_update_handler_noexc (k, handler[1], handler[2], effc); diff --git a/compiler/tests-jsoo/lib-effects/deep_state.ml b/compiler/tests-jsoo/lib-effects/deep_state.ml new file mode 100644 index 0000000000..7cfc4394a4 --- /dev/null +++ b/compiler/tests-jsoo/lib-effects/deep_state.ml @@ -0,0 +1,73 @@ +(* deep_state.ml *) + +open Effect +open Effect.Shallow + +module type State = sig + type a + + type _ Effect.t += Get : a Effect.t + + type _ Effect.t += Set : a -> unit Effect.t +end + +module Make (S : State) = struct + let rec loop : type x y. S.a -> (x, y) continuation -> x -> y = + fun s k x -> + continue_with + k + x + { retc = (fun y -> y) + ; exnc = raise + ; effc = + (fun (type b) (e : b Effect.t) -> + match e with + | S.Get -> Some (fun (k : (b, _) continuation) -> loop s k s) + | S.Set s -> Some (fun (k : (b, _) continuation) -> loop s k ()) + | _ -> None) + } + + let handle (s : S.a) (f : unit -> 'a) : 'a = loop s (fiber f) () + + let get () = perform S.Get + + let set v = perform (S.Set v) +end + +module IntState = struct + type a = int + + type _ Effect.t += Get : int Effect.t + + type _ Effect.t += Set : int -> unit Effect.t +end + +module StringState = struct + type a = string + + type _ Effect.t += Get : string Effect.t + + type _ Effect.t += Set : string -> unit Effect.t +end + +let main () = + let depth = int_of_string Sys.argv.(1) in + let ops = int_of_string Sys.argv.(2) in + Printf.printf "Running deepstate: depth=%d ops=%d\n" depth ops; + let module SS = Make (StringState) in + let rec setup_deep_state n () = + if n = 0 + then + for _ = 1 to ops do + (* SS.set (SS.get () ^ "_" ^ (string_of_int i)) *) + SS.set (SS.get ()) + done + (* print_endline @@ SS.get() *) + else + let module IS = Make (IntState) in + IS.handle 0 @@ setup_deep_state (n - 1) + in + + SS.handle "Hello, world!" @@ setup_deep_state depth + +let _ = main () diff --git a/compiler/tests-jsoo/lib-effects/dune b/compiler/tests-jsoo/lib-effects/dune index b5b58f0f3e..66df040883 100644 --- a/compiler/tests-jsoo/lib-effects/dune +++ b/compiler/tests-jsoo/lib-effects/dune @@ -15,7 +15,8 @@ \ assume_no_perform assume_no_perform_unhandled - assume_no_perform_nested_handler)) + assume_no_perform_nested_handler + deep_state)) (preprocess (pps ppx_expect))) @@ -37,3 +38,10 @@ 0 (run node %{test})))) (modes js wasm)) + +(executable + (name deep_state) + (enabled_if + (>= %{ocaml_version} 5)) + (modules deep_state) + (modes js)) diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 6432547c3c..9efe5359ca 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -7,10 +7,12 @@ a triple of handlers, which are invoked when the fiber terminates The low-level continuation of the topmost fiber (which is currently executing) is passed from function to function as an additional argument. Its stack of exception handlers is stored in -[caml_exn_stack]. Exception handlers are pushed into this stack when -entering a [try ... with ...] and popped on exit. Then, handlers and -the remaining fibers are stored in [caml_fiber_stack]. To install an -effect handler, we push a new fiber into the execution context. +[caml_current_stack.x]. +Exception handlers are pushed into this stack +when entering a [try ... with ...] and popped on exit. +Handlers are stored in [caml_current_stack.h] +and the remaining fibers are stored in [caml_current_stack.e]. +To install an effect handler, we push a new fiber into the execution context. We have basically the following type for reified continuations (type [continuation] in module [Effect] of the standard library): @@ -43,113 +45,143 @@ The handlers are CPS-transformed functions: they actually take an additional parameter which is the current low-level continuation. */ -//Provides: caml_exn_stack +//Provides: caml_current_stack //If: effects -// This is an OCaml list of exception handlers -var caml_exn_stack = 0; +// This has the shape {k, x, h, e} where +// - h is a triple of handlers (see effect.ml) +// - k is the low level continuation +// - x is the exception stack +// - e is the fiber stack of the parent fiber. +var caml_current_stack = { k: 0, x: 0, h: 0, e: 0 }; //Provides: caml_push_trap -//Requires: caml_exn_stack +//Requires: caml_current_stack //If: effects function caml_push_trap(handler) { - caml_exn_stack = [0, handler, caml_exn_stack]; + caml_current_stack.x = { h: handler, t: caml_current_stack.x }; } //Provides: caml_pop_trap -//Requires: caml_exn_stack +//Requires: caml_current_stack //If: effects function caml_pop_trap() { - if (!caml_exn_stack) + if (!caml_current_stack.x) return function (x) { throw x; }; - var h = caml_exn_stack[1]; - caml_exn_stack = caml_exn_stack[2]; + var h = caml_current_stack.x.h; + caml_current_stack.x = caml_current_stack.x.t; return h; } //Provides: caml_raise_unhandled -//Requires: caml_named_value, caml_raise_with_arg, caml_raise_constant, caml_string_of_jsbytes, caml_fresh_oo_id +//Requires: caml_make_unhandled_effect_exn //If: effects +//Version: >= 5.0 function caml_raise_unhandled(eff) { - var exn = caml_named_value("Effect.Unhandled"); - if (exn) caml_raise_with_arg(exn, eff); - else { - exn = [ - 248, - caml_string_of_jsbytes("Effect.Unhandled"), - caml_fresh_oo_id(0), - ]; - caml_raise_constant(exn); - } + var exn = caml_make_unhandled_effect_exn(eff); + throw exn; } -//Provides: caml_uncaught_effect_handler -//Requires: caml_resume_stack, caml_raise_unhandled -//If: effects -function caml_uncaught_effect_handler(eff, k, ms, cont) { - // Resumes the continuation k by raising exception Unhandled. - caml_resume_stack(k[1], ms); - caml_raise_unhandled(eff); -} - -//Provides: caml_fiber_stack -//If: effects -// This has the shape {h, r:{k, x, e}} where h is a triple of handlers -// (see effect.js) and k, x and e are the saved continuation, -// exception stack and fiber stack of the parent fiber. -var caml_fiber_stack; - //Provides:caml_resume_stack -//Requires: caml_named_value, caml_raise_constant, caml_exn_stack, caml_fiber_stack +//Requires: caml_named_value, caml_raise_constant +//Requires: caml_pop_fiber, caml_current_stack //If: effects -function caml_resume_stack(stack, k) { +//Version: >= 5.0 +function caml_resume_stack(stack, last, k) { if (!stack) caml_raise_constant( caml_named_value("Effect.Continuation_already_resumed"), ); - // Update the execution context with the stack of fibers in [stack] in - // order to resume the continuation - do { - caml_fiber_stack = { - h: stack[3], - r: { k: k, x: caml_exn_stack, e: caml_fiber_stack }, - }; - k = stack[1]; - caml_exn_stack = stack[2]; - stack = stack[4]; - } while (stack); - return k; + if (last === 0) { + last = stack; + // Pre OCaml 5.2, last/cont[2] was not populated. + while (last.e !== 0) last = last.e; + } + caml_current_stack.k = k; + last.e = caml_current_stack; + caml_current_stack = stack; + return stack.k; } //Provides: caml_pop_fiber -//Requires: caml_exn_stack, caml_fiber_stack +//Requires: caml_current_stack //If: effects +//Version: >= 5.0 function caml_pop_fiber() { // Move to the parent fiber, returning the parent's low-level continuation - var rem = caml_fiber_stack.r; - caml_exn_stack = rem.x; - caml_fiber_stack = rem.e; - return rem.k; + var c = caml_current_stack.e; + caml_current_stack.e = 0; + caml_current_stack = c; + return c.k; +} + +//Provides: caml_make_unhandled_effect_exn +//Requires: caml_named_value, caml_string_of_jsbytes, caml_fresh_oo_id +//If: effects +//Version: >= 5.0 +function caml_make_unhandled_effect_exn(eff) { + var exn = caml_named_value("Effect.Unhandled"); + if (exn) exn = [0, exn, eff]; + else { + exn = [ + 248, + caml_string_of_jsbytes("Effect.Unhandled"), + caml_fresh_oo_id(0), + ]; + } + return exn; } //Provides: caml_perform_effect -//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack, caml_get_cps_fun +//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return +//Requires: caml_make_unhandled_effect_exn, caml_current_stack +//Requires: caml_get_cps_fun +//If: effects +//Version: >= 5.0 +function caml_perform_effect(eff, k0) { + if (caml_current_stack.e === 0) { + var exn = caml_make_unhandled_effect_exn(eff); + throw exn; + } + // Get current effect handler + var handler = caml_current_stack.h[3]; + var last_fiber = caml_current_stack; + last_fiber.k = k0; + var cont = [245 /*continuation*/, last_fiber, 0]; + // Move to parent fiber and execute the effect handler there + // The handler is defined in Stdlib.Effect, so we know that the arity matches + var k1 = caml_pop_fiber(); + return caml_stack_check_depth() + ? caml_get_cps_fun(handler)(eff, cont, last_fiber, k1) + : caml_trampoline_return(handler, [eff, cont, last_fiber, k1]); +} + +//Provides: caml_reperform_effect +//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return +//Requires: caml_make_unhandled_effect_exn, caml_current_stack +//Requires: caml_resume_stack, caml_continuation_use_noexc +//Requires: caml_get_cps_fun //If: effects -function caml_perform_effect(eff, cont, k0) { - // Allocate a continuation if we don't already have one - if (!cont) cont = [245 /*continuation*/, 0]; +//Version: >= 5.0 +function caml_reperform_effect(eff, cont, last, k0) { + if (caml_current_stack.e === 0) { + var exn = caml_make_unhandled_effect_exn(eff); + var stack = caml_continuation_use_noexc(cont); + caml_resume_stack(stack, last, k0); + throw exn; + } // Get current effect handler - var handler = caml_fiber_stack.h[3]; - // Cons the current fiber onto the continuation: - // cont := Cons (k, exn_stack, handlers, !cont) - cont[1] = [0, k0, caml_exn_stack, caml_fiber_stack.h, cont[1]]; + var handler = caml_current_stack.h[3]; + var last_fiber = caml_current_stack; + last_fiber.k = k0; + last.e = last_fiber; // Move to parent fiber and execute the effect handler there // The handler is defined in Stdlib.Effect, so we know that the arity matches var k1 = caml_pop_fiber(); return caml_stack_check_depth() - ? caml_get_cps_fun(handler)(eff, cont, k1, k1) - : caml_trampoline_return(handler, [eff, cont, k1, k1], 0); + ? caml_get_cps_fun(handler)(eff, cont, last_fiber, k1) + : caml_trampoline_return(handler, [eff, cont, last_fiber, k1]); } //Provides: caml_get_cps_fun @@ -167,26 +199,34 @@ function caml_get_cps_fun(f) { } //Provides: caml_alloc_stack -//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_gen_cps +//Requires: caml_pop_fiber, caml_call_gen, caml_stack_check_depth, caml_trampoline_return +//Requires: caml_call_gen_cps, caml_current_stack //If: effects //Version: >= 5.0 +function caml_alloc_stack_call(f, x) { + var args = [x, caml_pop_fiber()]; + return caml_stack_check_depth() + ? caml_call_gen_cps(f, args) + : caml_trampoline_return(f, args, 0); +} +function caml_alloc_stack_hval(x) { + // Call [hv] in the parent fiber + var f = caml_current_stack.h[1]; + return caml_alloc_stack_call(f, x); +} +function caml_alloc_stack_hexn(e) { + // Call [hx] in the parent fiber + var f = caml_current_stack.h[2]; + return caml_alloc_stack_call(f, e); +} function caml_alloc_stack(hv, hx, hf) { - function call(i, x) { - var f = caml_fiber_stack.h[i]; - var args = [x, caml_pop_fiber()]; - return caml_stack_check_depth() - ? caml_call_gen_cps(f, args) - : caml_trampoline_return(f, args, 0); - } - function hval(x) { - // Call [hv] in the parent fiber - return call(1, x); - } - function hexn(e) { - // Call [hx] in the parent fiber - return call(2, e); - } - return [0, hval, [0, hexn, 0], [0, hv, hx, hf], 0]; + var handlers = [0, hv, hx, hf]; + return { + k: caml_alloc_stack_hval, + x: { h: caml_alloc_stack_hexn, t: 0 }, + h: handlers, + e: 0, + }; } //Provides: caml_alloc_stack @@ -214,7 +254,16 @@ function caml_continuation_use_and_update_handler_noexc( heff, ) { var stack = caml_continuation_use_noexc(cont); - stack[3] = [0, hval, hexn, heff]; + if (stack === 0) return stack; + var last = cont[2]; + if (last === 0) { + last = stack; + // Pre OCaml 5.2, last/cont[2] was not populated. + while (last.e !== 0) last = last.e; + } + last.h[1] = hval; + last.h[2] = hexn; + last.h[3] = heff; return stack; } @@ -251,25 +300,24 @@ function caml_ml_condition_signal(t) { //Provides: jsoo_effect_not_supported //Requires: caml_failwith //!If: effects +//Version: >= 5.0 function jsoo_effect_not_supported() { caml_failwith("Effect handlers are not supported"); } //Provides: caml_resume -//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler, caml_resume_stack +//Requires:caml_stack_depth, caml_call_gen_cps, caml_current_stack, caml_wrap_exception, caml_resume_stack //If: effects //If: doubletranslate -function caml_resume(f, arg, stack) { +//Version: >= 5.0 +function caml_resume(f, arg, stack, last) { var saved_stack_depth = caml_stack_depth; - var saved_exn_stack = caml_exn_stack; - var saved_fiber_stack = caml_fiber_stack; + var saved_current_stack = caml_current_stack; try { - caml_exn_stack = 0; - caml_fiber_stack = { - h: [0, 0, 0, { cps: caml_uncaught_effect_handler }], - r: { k: 0, x: 0, e: 0 }, - }; - var k = caml_resume_stack(stack, (x) => x); + caml_current_stack = { k: 0, x: 0, h: 0, e: 0 }; + var k = caml_resume_stack(stack, last, function (x) { + return x; + }); /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ var res = { joo_tramp: f, joo_args: [arg, k], joo_direct: 0 }; do { @@ -282,9 +330,9 @@ function caml_resume(f, arg, stack) { : caml_call_gen_cps(res.joo_tramp, res.joo_args); } catch (e) { /* Handle exception coming from JavaScript or from the runtime. */ - if (!caml_exn_stack.length) throw e; - var handler = caml_exn_stack[1]; - caml_exn_stack = caml_exn_stack[2]; + if (!caml_current_stack.x) throw e; + var handler = caml_current_stack.x.h; + caml_current_stack.x = caml_current_stack.x.t; res = { joo_tramp: handler, joo_args: [caml_wrap_exception(e)], @@ -295,8 +343,7 @@ function caml_resume(f, arg, stack) { return res; } finally { caml_stack_depth = saved_stack_depth; - caml_exn_stack = saved_exn_stack; - caml_fiber_stack = saved_fiber_stack; + caml_current_stack = saved_current_stack; } } diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 79c5d9e868..97aeaa96e4 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -84,17 +84,13 @@ var caml_callback = caml_call_gen; //Provides: caml_callback //If: effects //If: !doubletranslate -//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler +//Requires: caml_stack_depth, caml_call_gen, caml_wrap_exception +//Requires: caml_current_stack function caml_callback(f, args) { var saved_stack_depth = caml_stack_depth; - var saved_exn_stack = caml_exn_stack; - var saved_fiber_stack = caml_fiber_stack; + var saved_current_stack = caml_current_stack; try { - caml_exn_stack = 0; - caml_fiber_stack = { - h: [0, 0, 0, caml_uncaught_effect_handler], - r: { k: 0, x: 0, e: 0 }, - }; + caml_current_stack = { k: 0, x: 0, h: 0, e: 0 }; var res = { joo_tramp: f, joo_args: args.concat(function (x) { @@ -107,16 +103,15 @@ function caml_callback(f, args) { res = caml_call_gen(res.joo_tramp, res.joo_args); } catch (e) { /* Handle exception coming from JavaScript or from the runtime. */ - if (!caml_exn_stack) throw e; - var handler = caml_exn_stack[1]; - caml_exn_stack = caml_exn_stack[2]; + if (!caml_current_stack.x) throw e; + var handler = caml_current_stack.x.h; + caml_current_stack.x = caml_current_stack.x.t; res = { joo_tramp: handler, joo_args: [caml_wrap_exception(e)] }; } } while (res && res.joo_args); } finally { caml_stack_depth = saved_stack_depth; - caml_exn_stack = saved_exn_stack; - caml_fiber_stack = saved_fiber_stack; + caml_current_stack = saved_current_stack; } return res; } diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index a0e83f2302..859d45843e 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -129,7 +129,7 @@ function caml_call_gen(f, args) { var caml_call_gen_cps = caml_call_gen; //Provides: caml_call_gen_tuple (const, shallow) -//Requires: caml_fiber_stack, caml_cps_closure +//Requires: caml_cps_closure //If: effects //If: doubletranslate //Weakdef diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index c8932c2d9b..6850051a7f 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -221,7 +221,7 @@ (data $already_resumed "Effect.Continuation_already_resumed") (func (export "%resume") - (param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) + (param $stack (ref eq)) (param $f (ref eq)) (param $v (ref eq)) (param $tail (ref eq)) (result (ref eq)) (local $k (ref $cont)) (local $pair (ref $pair)) @@ -300,7 +300,7 @@ (struct.get $cont $cont_func (local.get $k1)))) (func $reperform (export "%reperform") - (param $eff (ref eq)) (param $cont (ref eq)) + (param $eff (ref eq)) (param $cont (ref eq)) (param $tail (ref eq)) (result (ref eq)) (return_call $capture_continuation (ref.func $do_perform) @@ -315,7 +315,8 @@ (local.get $eff) (ref.i31 (i32.const 0))))) (return_call $reperform (local.get $eff) (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) - (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))) + (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))) + (ref.i31 (i32.const 0)))) ;; Allocate a stack @@ -623,7 +624,7 @@ (struct.get $cps_fiber $cont (local.get $top))) (func $caml_resume_stack (export "caml_resume_stack") - (param $vstack (ref eq)) (param $k (ref eq)) (result (ref eq)) + (param $vstack (ref eq)) (param $last (ref eq)) (param $k (ref eq)) (result (ref eq)) (local $stack (ref $cps_fiber)) (drop (block $already_resumed (result (ref eq)) (local.set $stack @@ -653,7 +654,7 @@ (ref.i31 (i32.const 0))) (func (export "caml_perform_effect") - (param $eff (ref eq)) (param $vcont (ref eq)) (param $k0 (ref eq)) + (param $eff (ref eq)) (param $vcont (ref eq)) (param $last (ref eq)) (param $k0 (ref eq)) (result (ref eq)) (local $handlers (ref $handlers)) (local $handler (ref eq)) (local $k1 (ref eq)) @@ -736,6 +737,7 @@ (call $caml_resume_stack (array.get $block (ref.cast (ref $block) (local.get $k)) (i32.const 1)) + (ref.i31 (i32.const 0)) (local.get $ms))) (call $raise_unhandled (local.get $eff) (ref.i31 (i32.const 0))))