Function assume_no_perform makes perform fail for all effect implemen…

…tations

compiler/lib/effects.ml

@@ -169,8 +169,7 @@ let empty_body b =
 (****)
 
 let effect_primitive_or_application = function
-  | Prim (Extern ("%resume" | "%perform" | "%reperform" | "caml_assume_no_perform"), _)
-  | Apply _ -> true
+  | Prim (Extern ("%resume" | "%perform" | "%reperform"), _) | Apply _ -> true
   | Block (_, _, _, _)
   | Field (_, _, _)
   | Closure (_, _)
@@ -595,11 +594,9 @@ let rewrite_instr ~st (instr : instr) : instr =
 
 let cps_instr ~st (instr : instr) : instr list =
   match instr with
-  | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) ->
-      (* The case when double translation is disabled should be taken care of by a prior
-         pass *)
-      assert (double_translate ());
-      (* We just need to call [f] in direct style. *)
+  | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) when double_translate () ->
+      (* When double translation is enabled, we just call [f] in direct style.
+         Otherwise, the runtime primitive is used. *)
       let unit = Var.fresh_n "unit" in
       let exact = Global_flow.exact_call st.flow_info f 1 in
       [ Let (unit, Constant (Int Targetint.zero))
@@ -636,24 +633,6 @@ let cps_block ~st ~k ~orig_pc block =
                  && 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 "caml_assume_no_perform", [ Pv f ]) when not (double_translate ()) ->
-        assert (Var.Set.mem x st.cps_needed);
-        (* Translated like the [Apply] case, with a unit argument *)
-        Some
-          (fun ~k ->
-            let exact =
-              Var.idx f < Var.Tbl.length st.flow_info.info_approximation
-              && Global_flow.exact_call st.flow_info f 1
-            in
-            let unit = Var.fresh_n "unit" in
-            tail_call
-              ~st
-              ~instrs:[ Let (unit, Constant (Int Targetint.zero)) ]
-              ~exact
-              ~in_cps:true
-              ~check:true
-              ~f
-              [ unit; k ])
     | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) ->
         Some
           (fun ~k ->
@@ -752,12 +731,6 @@ let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block =
           let unit_val = Int Targetint.zero in
           let exact = Global_flow.exact_call st.flow_info f 1 in
           [ Let (unit, Constant unit_val); Let (x, Apply { exact; f; args = [ unit ] }) ]
-      | Let (_, Prim (Extern "caml_assume_no_perform", args)) ->
-          invalid_arg
-          @@ Format.sprintf
-               "Internal primitive `caml_assume_no_perform` takes exactly 1 argument (%d \
-                given)"
-               (List.length args)
       | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr
         -> [ instr ]
     in

compiler/lib/partial_cps_analysis.ml

@@ -96,15 +96,6 @@ let block_deps ~info ~vars ~tail_deps ~deps ~blocks ~fun_name pc =
               (* If a function contains effect primitives, it must be
                  in CPS *)
               add_dep deps f x)
-      | Let (x, Prim (Extern "caml_assume_no_perform", _)) -> (
-          add_var vars x;
-          match fun_name with
-          | None -> ()
-          | Some f ->
-              add_var vars f;
-              (* If a function contains effect primitives, it must be
-                 in CPS *)
-              add_dep deps f x)
       | Let (x, Closure _) -> add_var vars x
       | Let (_, (Prim _ | Block _ | Constant _ | Field _ | Special _))
       | Event _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ())
@@ -159,10 +150,6 @@ let cps_needed ~info ~in_mutual_recursion ~rev_deps st x =
   | Expr (Prim (Extern ("%perform" | "%reperform" | "%resume"), _)) ->
       (* Effects primitives are in CPS *)
       true
-  | Expr (Prim (Extern "caml_assume_no_perform", _)) ->
-      (* This primitive calls its function argument in direct style when double translation
-         is enabled. Otherwise, it simply applies its argument to unit. *)
-      not (Config.Flag.double_translation ())
   | Expr (Prim _ | Block _ | Constant _ | Field _ | Special _) | Phi _ -> false
 
 module SCC = Strongly_connected_components.Make (struct

compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml

@@ -4,10 +4,11 @@ open Effect.Deep
 
 type _ Effect.t += Dummy : unit t
 
-let f () =
+let must_raise () =
   try_with
     (fun () ->
       Js_of_ocaml.Js.Effect.assume_no_perform (fun () ->
+        (* Should raise [Effect.Unhandled] despite the installed handler *)
         perform Dummy
       )
     )
@@ -21,9 +22,5 @@ let f () =
 
 let () =
   try
-    (* When double translation is not enabled, [f] should not raise *)
-    f (); print_endline "ok"
-  with Effect.Unhandled Dummy -> (
-    print_endline "failed";
-    exit 2
-  )
+    must_raise (); print_endline "failed"; exit 2
+  with Effect.Unhandled Dummy -> print_endline "ok"

compiler/tests-ocaml/lib-effects/double-translation/dune

@@ -26,53 +26,7 @@
 
 (copy_files ../*.expected)
 
-(copy_files ../cmphash.ml)
-
-(copy_files ../marshal.ml)
-
-(copy_files ../effects.ml)
-
-(copy_files ../evenodd.ml)
-
-(copy_files ../manylive.ml)
-
-(copy_files ../overflow.ml)
-
-(copy_files ../partial.ml)
-
-(copy_files ../reperform.ml)
-
-(copy_files ../sched.ml)
-
-(copy_files ../shallow_state_io.ml)
-
-(copy_files ../shallow_state.ml)
-
-(copy_files ../test10.ml)
-
-(copy_files ../test11.ml)
-
-(copy_files ../test1.ml)
-
-(copy_files ../test2.ml)
-
-(copy_files ../test3.ml)
-
-(copy_files ../test4.ml)
-
-(copy_files ../test5.ml)
-
-(copy_files ../test6.ml)
-
-(copy_files ../test_lazy.ml)
-
-(copy_files ../used_cont.ml)
-
-(copy_files ../unhandled_unlinked.ml)
-
-(copy_files ../assume_no_perform.ml)
-
-(copy_files ../assume_no_perform_nested_handler.ml)
+(copy_files# ../*.ml)
 
 (tests
  (build_if

runtime/js/effect.js

@@ -305,3 +305,11 @@ function caml_cps_closure(direct_f, cps_f) {
   direct_f.cps = cps_f;
   return direct_f;
 }
+
+//Provides: caml_assume_no_perform
+//Requires: caml_callback
+//If: effects
+//If: !doubletranslate
+function caml_assume_no_perform (f) {
+  return caml_callback(f, [0]);
+}

runtime/wasm/effect.wat

@@ -306,7 +306,13 @@
          (ref.func $do_perform)
          (struct.new $pair (local.get $eff) (local.get $cont))))
 
+   (global $effect_allowed (mut i32) (i32.const 1))
+
    (func (export "%perform") (param $eff (ref eq)) (result (ref eq))
+      (if (i32.eqz (global.get $effect_allowed))
+         (then
+            (return_call $raise_unhandled
+               (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)))))
@@ -737,5 +743,23 @@
       (global.set $caml_trampoline_ref (ref.func $caml_trampoline)))
 
    (func (export "caml_assume_no_perform") (param $f (ref eq)) (result (ref eq))
-      (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0))))
+      (local $saved_effect_allowed i32)
+      (local $res (ref eq))
+      (local $exn (ref eq))
+      (local.set $saved_effect_allowed (global.get $effect_allowed))
+      (global.set $effect_allowed (i32.const 0))
+      (local.set $res
+         (try (result (ref eq))
+            (do
+               (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0))))
+            (catch $ocaml_exception
+               (local.set $exn (pop (ref eq)))
+               (global.set $effect_allowed (local.get $saved_effect_allowed))
+               (throw $ocaml_exception (local.get $exn)))
+            (catch $javascript_exception
+               (local.set $exn (call $caml_wrap_exception (pop externref)))
+               (global.set $effect_allowed (local.get $saved_effect_allowed))
+               (throw $ocaml_exception (local.get $exn)))))
+      (global.set $effect_allowed (local.get $saved_effect_allowed))
+      (local.get $res))
 )