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

@@ -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

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