another improvement

Author: hhugo

compiler/lib/effects.ml

@@ -543,11 +543,34 @@ let cps_block ~st ~k pc block =
   in
 
   let rewrite_instr x e =
-    let perform_effect ~effect_ ~continuation ~tail =
+    let perform_effect ~effect_ continuation_and_tail =
       Some
         (fun ~k ->
           let e =
-            Prim (Extern "caml_perform_effect", [ Pv effect_; continuation; tail; 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)
@@ -573,13 +596,9 @@ let cps_block ~st ~k pc block =
               ~check:true
               ~f
               [ arg; k' ])
-    | Prim (Extern "%perform", [ Pv effect_ ]) ->
-        perform_effect
-          ~effect_
-          ~continuation:(Pc (Int Targetint.zero))
-          ~tail:(Pc (Int Targetint.zero))
+    | Prim (Extern "%perform", [ Pv effect_ ]) -> perform_effect ~effect_ None
     | Prim (Extern "%reperform", [ Pv effect_; continuation; tail ]) ->
-        perform_effect ~effect_ ~continuation ~tail
+        perform_effect ~effect_ (Some (continuation, tail))
     | _ -> None
   in
 

runtime/js/effect.js

@@ -134,18 +134,12 @@ function caml_make_unhandled_effect_exn(eff) {
 //Provides: caml_perform_effect
 //Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_fiber_stack
 //Requires: caml_make_unhandled_effect_exn, caml_current_stack
-//Requires: caml_resume_stack, caml_continuation_use_noexc
 //If: effects
 //Version: >= 5.0
-function caml_perform_effect(eff, cont, last, k0) {
+function caml_perform_effect(eff, k0) {
   if (caml_fiber_stack === 0) {
     var exn = caml_make_unhandled_effect_exn(eff);
-    if (!cont) throw exn;
-    else {
-      var stack = caml_continuation_use_noexc(cont);
-      caml_resume_stack(stack, last, k0);
-      throw exn;
-    }
+    throw exn;
   }
   // Get current effect handler
   var handler = caml_current_stack.h[3];
@@ -155,13 +149,34 @@ function caml_perform_effect(eff, cont, last, 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();
-  if (!cont) {
-    //Perform
-    cont = [245 /*continuation*/, last_fiber, 0];
-  } else {
-    //Reperform
-    last.e = last_fiber;
+  var cont = [245 /*continuation*/, last_fiber, 0];
+  return caml_stack_check_depth()
+    ? 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, caml_fiber_stack
+//Requires: caml_make_unhandled_effect_exn, caml_current_stack
+//Requires: caml_resume_stack, caml_continuation_use_noexc
+//If: effects
+//Version: >= 5.0
+function caml_reperform_effect(eff, cont, last, k0) {
+  if (caml_fiber_stack === 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_current_stack.h[3];
+  var last_fiber = caml_current_stack;
+  last_fiber.k = k0;
+  last_fiber.e = 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();
+  last.e = last_fiber;
   return caml_stack_check_depth()
     ? handler(eff, cont, last_fiber, k1)
     : caml_trampoline_return(handler, [eff, cont, last_fiber, k1]);