Effects: double translation of functions and

... dynamic switching between direct-style and CPS code. (ocsigen#1461)

CHANGES.md

@@ -29,6 +29,7 @@
 * Runtime: precompute constants used in `caml_lxm_next` (#1730)
 * Runtime: cleanup runtime
 * Runtime: add support for OCaml 5.3
+* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in better performance when no effect handler is installed
 
 ## Bug fixes
 * Runtime: fix parsing of unsigned integers (0u2147483648) (#1633, #1666)

compiler/lib/build_info.ml

@@ -56,6 +56,7 @@ let create kind =
   in
   [ "use-js-string", string_of_bool (Config.Flag.use_js_string ())
   ; "effects", string_of_bool (Config.Flag.effects ())
+  ; "doubletranslate", string_of_bool (Config.Flag.double_translation ())
   ; "version", version
   ; "kind", string_of_kind kind
   ]
@@ -126,9 +127,10 @@ let merge fname1 info1 fname2 info2 =
         match k, v1, v2 with
         | "kind", v1, v2 ->
             if Option.equal String.equal v1 v2 then v1 else Some (string_of_kind `Unknown)
-        | ("effects" | "use-js-string" | "version"), Some v1, Some v2
+        | ("effects" | "doubletranslate" | "use-js-string" | "version"), Some v1, Some v2
           when String.equal v1 v2 -> Some v1
-        | (("effects" | "use-js-string" | "version") as key), v1, v2 ->
+        | (("effects" | "doubletranslate" | "use-js-string" | "version") as key), v1, v2
+          ->
             raise
               (Incompatible_build_info { key; first = fname1, v1; second = fname2, v2 })
         | _, Some v1, Some v2 when String.equal v1 v2 -> Some v1
@@ -143,6 +145,7 @@ let configure t =
   StringMap.iter
     (fun k v ->
       match k with
-      | "use-js-string" | "effects" -> Config.Flag.set k (bool_of_string v)
+      | "use-js-string" | "effects" | "doubletranslate" ->
+          Config.Flag.set k (bool_of_string v)
       | _ -> ())
     t

compiler/lib/code.ml

@@ -112,6 +112,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val make_set : size -> 'a DataSet.t t
@@ -227,6 +229,8 @@ end = struct
 
     let set t x v = t.(x) <- v
 
+    let length t = Array.length t
+
     let make () v = Array.make (count ()) v
 
     let make_set () = Array.make (count ()) DataSet.Empty

compiler/lib/code.mli

@@ -105,6 +105,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val make_set : size -> 'a DataSet.t t

compiler/lib/config.ml

@@ -70,6 +70,8 @@ module Flag = struct
 
   let effects = o ~name:"effects" ~default:false
 
+  let double_translation = o ~name:"doubletranslate" ~default:false
+
   let staticeval = o ~name:"staticeval" ~default:true
 
   let share_constant = o ~name:"share" ~default:true

compiler/lib/config.mli

@@ -41,6 +41,8 @@ module Flag : sig
 
   val effects : unit -> bool
 
+  val double_translation : unit -> bool
+
   val genprim : unit -> bool
 
   val strictmode : unit -> bool

compiler/lib/driver.ml

@@ -112,11 +112,13 @@ let effects ~deadcode_sentinal p =
         Deadcode.f p
       else p, live_vars
     in
-    p |> Effects.f ~flow_info:info ~live_vars +> map_fst Lambda_lifting.f)
+    let p, trampolined_calls, in_cps = Effects.f ~flow_info:info ~live_vars p in
+    let p = if Config.Flag.double_translation () then p else Lambda_lifting.f p in
+    p, trampolined_calls, in_cps)
   else
     ( p
     , (Code.Var.Set.empty : Effects.trampolined_calls)
-    , (Code.Var.Set.empty : Effects.in_cps) )
+    , (Code.Var.Set.empty : Code.Var.Set.t) )
 
 let exact_calls profile ~deadcode_sentinal p =
   if not (Config.Flag.effects ())
@@ -202,14 +204,15 @@ let generate
     ~exported_runtime
     ~wrap_with_fun
     ~warn_on_unhandled_effect
-    { program; variable_uses; trampolined_calls; deadcode_sentinal; in_cps = _ } =
+    { program; variable_uses; trampolined_calls; deadcode_sentinal; in_cps } =
   if times () then Format.eprintf "Start Generation...@.";
   let should_export = should_export wrap_with_fun in
   Generate.f
     program
     ~exported_runtime
     ~live_vars:variable_uses
     ~trampolined_calls
+    ~in_cps
     ~should_export
     ~warn_on_unhandled_effect
     ~deadcode_sentinal