diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index f7bd176c4f..c6adef9810 100644 --- a/compiler/lib/effects.ml +++ b/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 diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml index b0f68a0c36..f639e4b067 100644 --- a/compiler/lib/partial_cps_analysis.ml +++ b/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 diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml index a647cbe951..c81d984806 100644 --- a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml +++ b/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" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml deleted file mode 100644 index c81d984806..0000000000 --- a/compiler/tests-ocaml/lib-effects/double-translation/assume_no_perform_unhandled.ml +++ /dev/null @@ -1,26 +0,0 @@ -open Printf -open Effect -open Effect.Deep - -type _ Effect.t += Dummy : unit t - -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 - ) - ) - () - { effc = - (fun (type a) (e : a Effect.t) -> - match e with - | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) - | _ -> None) - } - -let () = - try - must_raise (); print_endline "failed"; exit 2 - with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune index 4312dc4c3e..7ca77f3d60 100644 --- a/compiler/tests-ocaml/lib-effects/double-translation/dune +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -25,54 +25,7 @@ (compilation_mode whole_program)))) (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 diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 8156b4f4a9..d9cdd26fe6 100644 --- a/runtime/js/effect.js +++ b/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]); +} diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index 6e69aa6296..5bc8678f2a 100644 --- a/runtime/wasm/effect.wat +++ b/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)) )