From 93c0a04135cbbdb78d4e3e668f3a2cde1e6b7aea Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 10 Dec 2024 13:58:13 +0100 Subject: [PATCH] Compiler: prepare compiler for 1658 --- compiler/lib/effects.ml | 18 +++++++++++------- compiler/lib/parse_bytecode.ml | 26 ++++++++++++++++---------- runtime/js/effect.js | 11 ++++++----- runtime/js/jslib.js | 4 ++-- runtime/wasm/effect.wat | 12 +++++++----- 5 files changed, 42 insertions(+), 29 deletions(-) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 5c3438ab00..b271392889 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -543,11 +543,11 @@ let cps_block ~st ~k pc block = in let rewrite_instr x e = - let perform_effect ~effect_ ~continuation = + let perform_effect ~effect_ ~continuation ~tail = Some (fun ~k -> let e = - Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; Pv k ]) + Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; tail; Pv k ]) in let x = Var.fresh () in [ Let (x, e) ], Return x) @@ -560,22 +560,26 @@ let cps_block ~st ~k pc block = exact || Global_flow.exact_call 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:(Global_flow.exact_call 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 + perform_effect + ~effect_ + ~continuation:(Pc (Int Targetint.zero)) + ~tail:(Pc (Int Targetint.zero)) + | Prim (Extern "%reperform", [ Pv effect_; continuation; tail ]) -> + perform_effect ~effect_ ~continuation ~tail | _ -> None 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/runtime/js/effect.js b/runtime/js/effect.js index 3856e76bf4..d4855ff43d 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -78,7 +78,7 @@ var caml_fiber_stack; //Provides:caml_resume_stack //Requires: caml_named_value, caml_raise_constant, caml_exn_stack, caml_fiber_stack //If: effects -function caml_resume_stack(stack, k) { +function caml_resume_stack(stack, last, k) { if (!stack) caml_raise_constant( caml_named_value("Effect.Continuation_already_resumed"), @@ -111,9 +111,9 @@ function caml_pop_fiber() { //Provides: caml_perform_effect //Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack //If: effects -function caml_perform_effect(eff, cont, k0) { +function caml_perform_effect(eff, cont, last, k0) { // Allocate a continuation if we don't already have one - if (!cont) cont = [245 /*continuation*/, 0]; + if (!cont) cont = [245 /*continuation*/, 0, 0]; // Get current effect handler var handler = caml_fiber_stack.h[3]; // Cons the current fiber onto the continuation: @@ -122,9 +122,10 @@ function caml_perform_effect(eff, cont, k0) { // 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(); + var last_fiber = "last_fiber"; // FIXME return caml_stack_check_depth() - ? handler(eff, cont, k1, k1) - : caml_trampoline_return(handler, [eff, cont, k1, k1]); + ? handler(eff, cont, last_fiber, k1) + : caml_trampoline_return(handler, [eff, cont, last_fiber, k1]); } //Provides: caml_alloc_stack diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 03fbdbefe9..8943b05a88 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -86,9 +86,9 @@ var caml_callback = caml_call_gen; //Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_resume_stack, caml_fresh_oo_id, caml_named_value, caml_raise_with_arg, caml_string_of_jsbytes //Requires: caml_raise_constant function caml_callback(f, args) { - function uncaught_effect_handler(eff, k, ms) { + function uncaught_effect_handler(eff, k, last, ms) { // Resumes the continuation k by raising exception Unhandled. - caml_resume_stack(k[1], ms); + caml_resume_stack(k[1], last, ms); var exn = caml_named_value("Effect.Unhandled"); if (exn) caml_raise_with_arg(exn, eff); else { diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index dbc41b3c76..3ff4449ad6 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -218,7 +218,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)) @@ -297,7 +297,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) @@ -306,7 +306,8 @@ (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) (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 @@ -614,7 +615,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 @@ -644,7 +645,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)) @@ -727,6 +728,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))))