From 8fa2eb8861e7e08081e35088bead438c7f9df38c Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 11 Jun 2024 15:08:11 +0200 Subject: [PATCH] Add caml_assume_no_effects primitive Passing a function [f] as argument of `caml_assume_no_effects` guarantees that, when compiling with `--enable doubletranslate`, the direct-style version of [f] is called, which is faster than the CPS version. As a consequence, performing an effect in a transitive callee of [f] will raise `Effect.Unhandled`, regardless of any effect handlers installed before the call to `caml_assume_no_effects`, unless a new effect handler was installed in the meantime. Usage: ``` external assume_no_effects : (unit -> 'a) -> 'a = "caml_assume_no_effects" ... caml_assume_no_effects (fun () -> (* Will be called in direct style... *)) ... ``` When double translation is disabled, `caml_assume_no_effects` simply acts like `fun f -> f ()`. --- compiler/lib/effects.ml | 62 ++++++++++++++++++++++++++++ compiler/lib/partial_cps_analysis.ml | 13 ++++++ 2 files changed, 75 insertions(+) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 5343f86c32..21b6140795 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -723,7 +723,37 @@ let cps_instr ~st (instr : instr) : instr list = (* Nothing to do for single-version functions. *) [ instr ] | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + (* Applications of CPS functions and effect primitives require more work + (allocating a continuation and/or modifying end-of-block branches) and + are handled in a specialized function below. *) assert false + | Let (x, Prim (Extern "caml_assume_no_effects", [ Pv f ])) -> + if double_translate () + then + (* We just need to call [f] in direct style. *) + let unit = Var.fresh_n "unit" in + let exact = Global_flow.exact_call st.flow_info f 1 in + [ Let (unit, Constant (Int 0l)); Let (x, Apply { exact; f; args = [ unit ] }) ] + else ( + (* The "needs CPS" case should have been taken care of by another, specialized + function below. *) + assert (not (Var.Set.mem x st.cps_needed)); + (* Translated like the [Apply] case, with a unit argument *) + assert ( + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and does not require CPS *) + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f 1); + let unit = Var.fresh_n "unit" in + [ Let (unit, Constant (Int 0l)) + ; Let (x, Apply { f; args = [ unit ]; exact = true }) + ]) + | Let (_, Prim (Extern "caml_assume_no_effects", args)) -> + invalid_arg + @@ Format.sprintf + "Internal primitive `caml_assume_no_effects` takes exactly 1 argument (%d \ + given)" + (List.length args) | _ -> [ instr ] let cps_block ~st ~k ~lifter_functions ~orig_pc block = @@ -757,6 +787,26 @@ let cps_block ~st ~k ~lifter_functions ~orig_pc block = || Global_flow.exact_call st.flow_info f (List.length args) in tail_call ~st ~exact ~check:true ~f (args @ [ k ]) loc) + | Prim (Extern "caml_assume_no_effects", [ Pv f ]) + when (not (double_translate ())) && Var.Set.mem x st.cps_needed -> + (* Translated like the [Apply] case, with a unit argument *) + Some + (fun ~k -> + let exact = + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and is 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 0l)), noloc ] + ~exact + ~check:true + ~f + [ unit; k ] + loc) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> Some (fun ~k -> @@ -923,6 +973,18 @@ let rewrite_direct_block , Prim (Extern "caml_perform_effect", [ Pv effect; Pv continuation; Pc k ]) ) ] + | Let (x, Prim (Extern "caml_assume_no_effects", [ Pv f ])) -> + (* We just need to call [f] in direct style. *) + let unit = Var.fresh_n "unit" in + let unit_val = Int 0l 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_effects", args)) -> + invalid_arg + @@ Format.sprintf + "Internal primitive `caml_assume_no_effects` takes exactly 1 argument (%d \ + given)" + (List.length args) | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _) as instr -> [ instr ] in diff --git a/compiler/lib/partial_cps_analysis.ml b/compiler/lib/partial_cps_analysis.ml index e2424fac1e..10fd9ae0cf 100644 --- a/compiler/lib/partial_cps_analysis.ml +++ b/compiler/lib/partial_cps_analysis.ml @@ -87,6 +87,15 @@ 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_effects", _)) -> ( + 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 _)) | Assign _ | Set_field _ | Offset_ref _ | Array_set _ -> ()) @@ -141,6 +150,10 @@ 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_effects", _)) -> + (* 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