Effects: double translation of functions and dynamic switching between direct-style and CPS code

CHANGES.md

@@ -6,6 +6,7 @@
 * Merged Wasm_of_ocaml (#1724)
 * Lib: removed no longer relevant Js.optdef type annotations (#1769)
 * Misc: drop support for IE
+* 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
 * Fix small bug in global data flow analysis (#1768)

README.md

@@ -92,7 +92,8 @@ optimized:
   [More](http://ocsigen.org/js_of_ocaml/dev/manual/tailcall) about tail call
   optimization.
 
-Effect handlers are supported with the `--enable=effects` flag.
+Effect handlers are supported with the `--effects={cps,double-translation}`
+flag.
 
 ## Data representation
 

README_wasm_of_ocaml.md

@@ -13,8 +13,8 @@ In particular, the output code requires the following [Wasm extensions](https://
 
 OCaml 5.x code using effect handlers can be compiled in two different ways:
 One can enable the CPS transformation from `js_of_ocaml` by passing the
-`--enable=effects` flag. Without the flag `wasm_of_ocaml` will instead emit code
-utilizing
+`--effects=cps` flag. Without the flag `wasm_of_ocaml` will instead default to
+`--effects=jspi` and emit code utilizing
 - [the JavaScript-Promise Integration extension](https://github.com/WebAssembly/js-promise-integration/blob/main/proposals/js-promise-integration/Overview.md)
 
 

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -39,6 +39,16 @@ let trim_trailing_dir_sep s =
 
 let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep
 
+let normalize_effects effects common =
+  (* For backward compatibility, consider that [--enable effects] alone means
+       [--effects cps] *)
+  match effects with
+  | None ->
+      if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable
+      then Some Config.Cps
+      else None
+  | Some _ -> effects
+
 type t =
   { common : Jsoo_cmdline.Arg.t
   ; (* compile option *)
@@ -65,6 +75,7 @@ type t =
   ; fs_output : string option
   ; fs_external : bool
   ; keep_unit_names : bool
+  ; effects : Config.effects_backend option
   }
 
 let wrap_with_fun_conv =
@@ -253,6 +264,18 @@ let options =
       & opt (some string) None
       & info [ "ofs" ] ~docs:filesystem_section ~docv:"FILE" ~doc)
   in
+  let effects =
+    let doc =
+      "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \
+       or $(b,double-translation). Effects won't be supported if unspecified."
+    in
+    Arg.(
+      value
+      & opt
+          (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ]))
+          None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -279,7 +302,8 @@ let options =
       output_file
       input_file
       js_files
-      keep_unit_names =
+      keep_unit_names
+      effects =
     let inline_source_content = not sourcemap_don't_inline_content in
     let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
     let runtime_files = js_files in
@@ -318,6 +342,7 @@ let options =
     let params : (string * string) list = List.flatten set_param in
     let static_env : (string * string) list = List.flatten set_env in
     let include_dirs = normalize_include_dirs include_dirs in
+    let effects = normalize_effects effects common in
     `Ok
       { common
       ; params
@@ -341,6 +366,7 @@ let options =
       ; bytecode
       ; source_map
       ; keep_unit_names
+      ; effects
       }
   in
   let t =
@@ -371,7 +397,8 @@ let options =
       $ output_file
       $ input_file
       $ js_files
-      $ keep_unit_names)
+      $ keep_unit_names
+      $ effects)
   in
   Term.ret t
 
@@ -496,6 +523,18 @@ let options_runtime_only =
       & opt (some string) None
       & info [ "ofs" ] ~docs:filesystem_section ~docv:"FILE" ~doc)
   in
+  let effects =
+    let doc =
+      "Select an implementation of effect handlers. [$(docv)] should be one of $(b,cps) \
+       or $(b,double-translation). Effects are not allowed by default."
+    in
+    Arg.(
+      value
+      & opt
+          (some (enum [ "cps", Config.Cps; "double-translation", Double_translation ]))
+          None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       toplevel
@@ -515,7 +554,8 @@ let options_runtime_only =
       sourcemap_root
       target_env
       output_file
-      js_files =
+      js_files
+      effects =
     let inline_source_content = not sourcemap_don't_inline_content in
     let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
     let runtime_files = js_files in
@@ -544,6 +584,7 @@ let options_runtime_only =
     let params : (string * string) list = List.flatten set_param in
     let static_env : (string * string) list = List.flatten set_env in
     let include_dirs = normalize_include_dirs include_dirs in
+    let effects = normalize_effects effects common in
     `Ok
       { common
       ; params
@@ -567,6 +608,7 @@ let options_runtime_only =
       ; bytecode = `None
       ; source_map
       ; keep_unit_names = false
+      ; effects
       }
   in
   let t =
@@ -590,6 +632,7 @@ let options_runtime_only =
       $ sourcemap_root
       $ target_env
       $ output_file
-      $ js_files)
+      $ js_files
+      $ effects)
   in
   Term.ret t

compiler/bin-js_of_ocaml/cmd_arg.mli

@@ -49,6 +49,7 @@ type t =
   ; fs_output : string option
   ; fs_external : bool
   ; keep_unit_names : bool
+  ; effects : Config.effects_backend option
   }
 
 val options : t Cmdliner.Term.t

compiler/bin-js_of_ocaml/compile.ml

@@ -153,6 +153,7 @@ let run
     ; export_file
     ; keep_unit_names
     ; include_runtime
+    ; effects
     } =
   let source_map_base = Option.map ~f:snd source_map in
   let source_map =
@@ -165,6 +166,7 @@ let run
   let custom_header = common.Jsoo_cmdline.Arg.custom_header in
   Config.set_target `JavaScript;
   Jsoo_cmdline.Arg.eval common;
+  Config.set_effects_backend effects;
   Linker.reset ();
   (match output_file with
   | `Stdout, _ -> ()

compiler/bin-wasm_of_ocaml/cmd_arg.ml

@@ -38,6 +38,16 @@ let trim_trailing_dir_sep s =
 
 let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep
 
+let normalize_effects effects common =
+  (* For backward compatibility, consider that [--enable effects] alone means [--effects cps] *)
+  match effects with
+  | None ->
+      if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable
+      then Some Config.Cps
+      else None
+  | Some Config.Cps -> Some Config.Cps
+  | Some _ -> failwith "Unexpected effects backend"
+
 type t =
   { common : Jsoo_cmdline.Arg.t
   ; (* compile option *)
@@ -51,6 +61,7 @@ type t =
   ; sourcemap_don't_inline_content : bool
   ; params : (string * string) list
   ; include_dirs : string list
+  ; effects : Config.effects_backend option
   }
 
 let options =
@@ -103,6 +114,16 @@ let options =
     let doc = "Add [$(docv)] to the list of include directories." in
     Arg.(value & opt_all string [] & info [ "I" ] ~docv:"DIR" ~doc)
   in
+  let effects =
+    let doc =
+      "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \
+       (the default) or $(b,cps)."
+    in
+    Arg.(
+      value
+      & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -115,7 +136,8 @@ let options =
       sourcemap_root
       output_file
       input_file
-      runtime_files =
+      runtime_files
+      effects =
     let chop_extension s = try Filename.chop_extension s with Invalid_argument _ -> s in
     let output_file =
       let ext =
@@ -133,6 +155,7 @@ let options =
     let params : (string * string) list = List.flatten set_param in
     let enable_source_maps = (not no_sourcemap) && sourcemap in
     let include_dirs = normalize_include_dirs include_dirs in
+    let effects = normalize_effects effects common in
     `Ok
       { common
       ; params
@@ -145,6 +168,7 @@ let options =
       ; enable_source_maps
       ; sourcemap_root
       ; sourcemap_don't_inline_content
+      ; effects
       }
   in
   let t =
@@ -161,7 +185,8 @@ let options =
       $ sourcemap_root
       $ output_file
       $ input_file
-      $ runtime_files)
+      $ runtime_files
+      $ effects)
   in
   Term.ret t
 
@@ -204,6 +229,16 @@ let options_runtime_only =
       & opt_all (list (pair ~sep:'=' (enum all) string)) []
       & info [ "set" ] ~docv:"PARAM=VALUE" ~doc)
   in
+  let effects =
+    let doc =
+      "Select an implementation of effect handlers. [$(docv)] should be one of $(b,jspi) \
+       (the default) or $(b,cps)."
+    in
+    Arg.(
+      value
+      & opt (enum [ "jspi", None; "cps", Some Config.Cps ]) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -213,10 +248,12 @@ let options_runtime_only =
       sourcemap_don't_inline_content
       sourcemap_root
       output_file
-      runtime_files =
+      runtime_files
+      effects =
     let params : (string * string) list = List.flatten set_param in
     let enable_source_maps = (not no_sourcemap) && sourcemap in
     let include_dirs = normalize_include_dirs include_dirs in
+    let effects = normalize_effects effects common in
     `Ok
       { common
       ; params
@@ -229,6 +266,7 @@ let options_runtime_only =
       ; enable_source_maps
       ; sourcemap_root
       ; sourcemap_don't_inline_content
+      ; effects
       }
   in
   let t =
@@ -242,6 +280,7 @@ let options_runtime_only =
       $ sourcemap_don't_inline_content
       $ sourcemap_root
       $ output_file
-      $ runtime_files)
+      $ runtime_files
+      $ effects)
   in
   Term.ret t

compiler/bin-wasm_of_ocaml/cmd_arg.mli

@@ -31,6 +31,7 @@ type t =
   ; sourcemap_don't_inline_content : bool
   ; params : (string * string) list
   ; include_dirs : string list
+  ; effects : Config.effects_backend option
   }
 
 val options : t Cmdliner.Term.t

compiler/bin-wasm_of_ocaml/compile.ml

@@ -269,9 +269,11 @@ let run
     ; include_dirs
     ; sourcemap_root
     ; sourcemap_don't_inline_content
+    ; effects
     } =
   Config.set_target `Wasm;
   Jsoo_cmdline.Arg.eval common;
+  Config.set_effects_backend effects;
   Generate.init ();
   let output_file = fst output_file in
   if debug_mem () then Debug.start_profiling output_file;

compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml

@@ -39,7 +39,11 @@ let () =
   | Sys.(Native | Bytecode | Other _) -> failwith "Expected backend `js_of_ocaml`");
   let global = J.pure_js_expr "globalThis" in
   Config.Flag.set "use-js-string" (Jsoo_runtime.Sys.Config.use_js_string ());
-  Config.Flag.set "effects" (Jsoo_runtime.Sys.Config.effects ());
+  Config.set_effects_backend
+    (match Jsoo_runtime.Sys.Config.effects () with
+    | None -> None
+    | Some Jsoo_runtime.Sys.Config.Cps -> Some Config.Cps
+    | Some Jsoo_runtime.Sys.Config.Double_translation -> Some Config.Double_translation);
   Linker.reset ();
   (* this needs to stay synchronized with toplevel.js *)
   let toplevel_compile (s : string) (debug : Instruct.debug_event list array) :

compiler/lib-runtime-files/gen/gen.ml

@@ -48,7 +48,11 @@ let rec list_product l =
       let tail = list_product xs in
       List.concat_map values ~f:(fun v -> List.map tail ~f:(fun l -> (key, v) :: l))
 
-let bool = [ true; false ]
+let bool = [ `Bool true; `Bool false ]
+
+let effects_backends =
+  let open Js_of_ocaml_compiler.Config in
+  [ `Effects None; `Effects (Some Cps); `Effects (Some Double_translation) ]
 
 let () =
   Js_of_ocaml_compiler.Config.set_target `JavaScript;
@@ -60,11 +64,15 @@ let () =
       let fragments =
         List.map rest ~f:(fun f -> f, Js_of_ocaml_compiler.Linker.Fragment.parse_file f)
       in
-      let variants = list_product [ "use-js-string", bool; "effects", bool ] in
+      let variants =
+        list_product [ "use-js-string", bool; "effects", effects_backends ]
+      in
       (* load all files to make sure they are valid *)
       List.iter variants ~f:(fun setup ->
-          List.iter setup ~f:(fun (name, b) ->
-              Js_of_ocaml_compiler.Config.Flag.set name b);
+          List.iter setup ~f:(fun (name, v) ->
+              match v with
+              | `Bool b -> Js_of_ocaml_compiler.Config.Flag.set name b
+              | `Effects b -> Js_of_ocaml_compiler.Config.set_effects_backend b);
           List.iter Js_of_ocaml_compiler.Target_env.all ~f:(fun target_env ->
               Js_of_ocaml_compiler.Linker.reset ();
               List.iter fragments ~f:(fun (filename, frags) ->

compiler/lib-wasm/gc_target.ml

@@ -1706,7 +1706,7 @@ let post_process_function_body = Initialize_locals.f
 let entry_point ~toplevel_fun =
   let code =
     let* () =
-      if Config.Flag.effects ()
+      if Option.is_some (Config.effects ())
       then
         let* f =
           register_import