Compiler: prepare compiler for 1658

hhugo · hhugo · commit 93c0a04135cb · 2024-12-12T13:49:48.000+01:00
diff --git 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
@@ -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
@@ -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
@@ -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
@@ -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))))
 
