Effects: double translation of functions and dynamic switching between direct-style and CPS code (#1461)

* Effects: double translation of functions and

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

* Add caml_assume_no_effects primitive and tests

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 ()`.

This primitive is exposed via `Js_of_ocaml.Js.Effect.assume_no_perform`.

* CR: Fix non-raised Unhandled with assume_no_perform

* CR: Commit suggestion for compiler/lib/driver.ml

Co-authored-by: Jérôme Vouillon <[email protected]>

* Fix runtime deps, add missing test

* Runtime format

* Factorize substitution logic

* CR: make caml_callback an alias of caml_call_gen...

... when double translation is enabled.

* Promote tests

* CR: Fix caml_trampoline_cps and rename it to caml_resume

* CR: First fixes to Lambda_lifting_simple

* Simplify and clarify Lambda_lifting_simple

* Format runtime

* Fix bug: functions inside CPS functions were not lambda-lifted

* Runtime: fix caml_uncaught_effect_handler

We can use a single definition for the CPS transformation and the double
translation. The definition for the CPS transformation was wrong, since
it did not take a continuation as parameter.

* Runtime: the trampoline now distinguish direct and CPS calls

* Fix unregistered test and add one for nested handler

* Uses 'tests' dune stanza

* Reformat dune files and remove leftover files

* CR: Fixes in Lambda_lifting_simple

* CR: remove unnecessary conditionals in Effects

* CR: Remove duplicate instruction

* CR: Apply suggested simplifications

* Add test for lambda-lifting of mutually recursive functions

* CR

* Revert addition of no longer necessary Freevars functions

* Add wasm mode to double translation tests

* CR: Add missing Wasm stubs

* Revert "Add wasm mode to double translation tests"

This reverts commit d3cc1b7.

* Update dune.inc

* CR

* CR

* Use copy_file rather than duplicate tests

* Update comment

* Simplify function rewrite_instr

* Function assume_no_perform makes perform fail for all effect implementations

* CR: Add --effects option

* Fix Dynlink and limit use of --enable=effects

* Reformat

* CR

* CR

* CR: add missing bound check

* CR: Simplification in compiler/lib/effects.ml

Co-authored-by: Jérôme Vouillon <[email protected]>

* CR: simplify closure allocation

* Javascript runtime: stop using 'arguments'

* Fix too early effects backend setting

Co-authored-by: Jérôme Vouillon <[email protected]>

* Fix uses of `--enable=effects` in lib-wasm/

* Move assume_no_perform to Jsoo_runtime

* Fix: move C primitive

* CR

* CR: rephrase comment

Co-authored-by: hhugo <[email protected]>

* CR: Move effects backend choice logic

* CR: simplify

* Docs: document double translation better

Only document the use of `--enable effects` for now, as only this option
is correctly handled by Dune, and document possible caching issues with
`--effects=double-translation`.

* Fix warning

* Fix another warning

* Update manual/effects.wiki

Co-authored-by: Jérôme Vouillon <[email protected]>

* CR: revert some changes in docs

Co-authored-by: Jérôme Vouillon <[email protected]>

* Don't set effects_backend in _cmd_arg_ modules

* Fix compilation

* CR

* CR: add CONFIG macro

* Re-export Jsoo_runtime from the js_of_ocaml library

* Fix spurious free var warning over CONFIG macro

* CR: Update compiler/lib/driver.ml

Co-authored-by: hhugo <[email protected]>

* Remove duplicate effects flag

* CR: more explicit type for effects backend

* CR: doc phrasing

* CR: revert obsolete change

* Fix assertion

* CR: comment to justify constant

* reformat

* Fixes

* Fix assert failure

* reformat

* CR: Create Js_of_ocaml.Effect_js

* CR: move new tests to tests-jsoo/lib-effects

* Fix warnings in tests

---------

Co-authored-by: Jérôme Vouillon <[email protected]>
Co-authored-by: hhugo <[email protected]>

Author: 3 people

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/build_fs.ml

@@ -62,6 +62,7 @@ function jsoo_create_file_extern(name,content){
 |}
   in
   Config.set_target `JavaScript;
+  Config.set_effects_backend `Disabled;
   let fragments = Linker.Fragment.parse_string code in
   Linker.load_fragments ~target_env:Isomorphic ~filename:"<dummy>" fragments;
   Linker.check_deps ();

compiler/bin-js_of_ocaml/check_runtime.ml

@@ -44,6 +44,7 @@ let print_groups output l =
 
 let f (runtime_files, bytecode, target_env) =
   Config.set_target `JavaScript;
+  Config.set_effects_backend `Disabled;
   Linker.reset ();
   let runtime_files, builtin =
     List.partition_map runtime_files ~f:(fun name ->

compiler/bin-js_of_ocaml/cmd_arg.ml

@@ -39,6 +39,17 @@ let trim_trailing_dir_sep s =
 
 let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep
 
+let normalize_effects (effects : [ `Cps | `Double_translation ] option) common :
+    Config.effects_backend =
+  match effects with
+  | None ->
+      (* For backward compatibility, consider that [--enable effects] alone means
+         [--effects cps] *)
+      if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable
+      then `Cps
+      else `Disabled
+  | Some ((`Cps | `Double_translation) as e) -> (e :> Config.effects_backend)
+
 type t =
   { common : Jsoo_cmdline.Arg.t
   ; (* compile option *)
@@ -65,6 +76,7 @@ type t =
   ; fs_output : string option
   ; fs_external : bool
   ; keep_unit_names : bool
+  ; effects : Config.effects_backend
   }
 
 let wrap_with_fun_conv =
@@ -253,6 +265,16 @@ 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", `Cps; "double-translation", `Double_translation ])) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -279,7 +301,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 +341,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 +365,7 @@ let options =
       ; bytecode
       ; source_map
       ; keep_unit_names
+      ; effects
       }
   in
   let t =
@@ -371,7 +396,8 @@ let options =
       $ output_file
       $ input_file
       $ js_files
-      $ keep_unit_names)
+      $ keep_unit_names
+      $ effects)
   in
   Term.ret t
 
@@ -496,6 +522,16 @@ 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 won't be supported if unspecified."
+    in
+    Arg.(
+      value
+      & opt (some (enum [ "cps", `Cps; "double-translation", `Double_translation ])) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       toplevel
@@ -515,7 +551,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 +581,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 +605,7 @@ let options_runtime_only =
       ; bytecode = `None
       ; source_map
       ; keep_unit_names = false
+      ; effects
       }
   in
   let t =
@@ -590,6 +629,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
   }
 
 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,15 @@ let trim_trailing_dir_sep s =
 
 let normalize_include_dirs dirs = List.map dirs ~f:trim_trailing_dir_sep
 
+let normalize_effects (effects : [ `Cps | `Jspi ] option) common : Config.effects_backend
+    =
+  match effects with
+  | None ->
+      (* For backward compatibility, consider that [--enable effects] alone means
+        [--effects cps] *)
+      if List.mem "effects" ~set:common.Jsoo_cmdline.Arg.optim.enable then `Cps else `Jspi
+  | Some ((`Cps | `Jspi) as e) -> e
+
 type t =
   { common : Jsoo_cmdline.Arg.t
   ; (* compile option *)
@@ -51,6 +60,7 @@ type t =
   ; sourcemap_don't_inline_content : bool
   ; params : (string * string) list
   ; include_dirs : string list
+  ; effects : Config.effects_backend
   }
 
 let options =
@@ -103,6 +113,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 (some (enum [ "jspi", `Jspi; "cps", `Cps ])) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -115,7 +135,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 +154,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 +167,7 @@ let options =
       ; enable_source_maps
       ; sourcemap_root
       ; sourcemap_don't_inline_content
+      ; effects
       }
   in
   let t =
@@ -161,7 +184,8 @@ let options =
       $ sourcemap_root
       $ output_file
       $ input_file
-      $ runtime_files)
+      $ runtime_files
+      $ effects)
   in
   Term.ret t
 
@@ -204,6 +228,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 (some (enum [ "jspi", `Jspi; "cps", `Cps ])) None
+      & info [ "effects" ] ~docv:"KIND" ~doc)
+  in
   let build_t
       common
       set_param
@@ -213,10 +247,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 +265,7 @@ let options_runtime_only =
       ; enable_source_maps
       ; sourcemap_root
       ; sourcemap_don't_inline_content
+      ; effects
       }
   in
   let t =
@@ -242,6 +279,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
   }
 
 val options : t Cmdliner.Term.t