Effects: double translation of functions and

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

CHANGES.md

@@ -1,3 +1,8 @@
+# dev (2024-??) - ??
+
+## Features/Changes
+* Effects: add an optional feature of "dynamic switching" between CPS and direct style, resulting in better performance when no effect handler is installed
+
 # 5.8.2 (2024-05-26) - Luc
 
 ## Bug fixes

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
   ]
@@ -122,9 +123,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
@@ -139,6 +141,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

@@ -106,6 +106,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit
@@ -212,6 +214,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 iter f t =

compiler/lib/code.mli

@@ -99,6 +99,8 @@ module Var : sig
 
     val set : 'a t -> key -> 'a -> unit
 
+    val length : 'a t -> int
+
     val make : size -> 'a -> 'a t
 
     val iter : (key -> 'a -> unit) -> 'a t -> unit

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

@@ -87,7 +87,7 @@ let phi p =
 
 let ( +> ) f g x = g (f x)
 
-let map_fst f (x, y) = f x, y
+let map_triple_fst f (x, y, z) = f x, y, z
 
 let effects ~deadcode_sentinal p =
   if Config.Flag.effects ()
@@ -104,9 +104,14 @@ let effects ~deadcode_sentinal p =
         Deadcode.f p
       else p, live_vars
     in
-    let p, cps = p |> Effects.f ~flow_info:info ~live_vars +> map_fst Lambda_lifting.f in
-    p, cps)
-  else p, (Code.Var.Set.empty : Effects.cps_calls)
+    p
+    |> Effects.f ~flow_info:info ~live_vars
+       +> map_triple_fst
+            (if Config.Flag.double_translation () then Fun.id else Lambda_lifting.f))
+  else
+    ( p
+    , (Code.Var.Set.empty : Effects.cps_calls)
+    , (Code.Var.Set.empty : Effects.single_version_closures) )
 
 let exact_calls profile ~deadcode_sentinal p =
   if not (Config.Flag.effects ())
@@ -193,14 +198,15 @@ let generate
     ~wrap_with_fun
     ~warn_on_unhandled_effect
     ~deadcode_sentinal
-    ((p, live_vars), cps_calls) =
+    ((p, live_vars), cps_calls, single_version_closures) =
   if times () then Format.eprintf "Start Generation...@.";
   let should_export = should_export wrap_with_fun in
   Generate.f
     p
     ~exported_runtime
     ~live_vars
     ~cps_calls
+    ~single_version_closures
     ~should_export
     ~warn_on_unhandled_effect
     ~deadcode_sentinal
@@ -671,8 +677,14 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p =
        | O3 -> o3)
     +> exact_calls ~deadcode_sentinal profile
     +> effects ~deadcode_sentinal
-    +> map_fst (if Config.Flag.effects () then fun x -> x else Generate_closure.f)
-    +> map_fst deadcode'
+    +> fun (p, cps_calls, single_version_closures) ->
+    let p, single_version_closures =
+      if Config.Flag.effects ()
+      then p, single_version_closures
+      else Generate_closure.f p, single_version_closures
+    in
+    let p = deadcode' p in
+    p, cps_calls, single_version_closures
   in
   let emit =
     generate