CR

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)
@@ -48,7 +49,6 @@
 * Toplevel: no longer set globals for toplevel initialization
 * Runtime: precompute constants used in `caml_lxm_next` (#1730)
 * Runtime: cleanup runtime
-* 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-wasm/generate.ml

@@ -21,7 +21,7 @@ open Code
 module W = Wasm_ast
 open Code_generation
 
-let effects () = Option.is_some (Config.effects ())
+let effects_cps () = Option.is_some (Config.effects ())
 
 module Generate (Target : Target_sig.S) = struct
   open Target
@@ -239,9 +239,9 @@ module Generate (Target : Target_sig.S) = struct
     | Constant c -> Constant.translate c
     | Special (Alias_prim _) -> assert false
     | Prim (Extern "caml_alloc_dummy_function", [ _; Pc (Int arity) ]) ->
-        Closure.dummy ~cps:(effects ()) ~arity:(Targetint.to_int_exn arity)
+        Closure.dummy ~cps:(effects_cps ()) ~arity:(Targetint.to_int_exn arity)
     | Prim (Extern "caml_alloc_dummy_infix", _) ->
-        Closure.dummy ~cps:(effects ()) ~arity:1
+        Closure.dummy ~cps:(effects_cps ()) ~arity:1
     | Prim (Extern "caml_get_global", [ Pc (String name) ]) ->
         let* x =
           let* context = get_context in
@@ -1178,7 +1178,9 @@ let init () =
     ]
   in
   Primitive.register "caml_array_of_uniform_array" `Mutable None None;
-  let l = if effects () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l else l in
+  let l =
+    if effects_cps () then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l else l
+  in
   List.iter ~f:(fun (nm, nm') -> Primitive.alias nm nm') l
 
 (* Make sure we can use [br_table] for switches *)
@@ -1220,7 +1222,7 @@ let fix_switch_branches p =
 let start () = make_context ~value_type:Gc_target.Value.value
 
 let f ~context ~unit_name p ~live_vars ~in_cps ~deadcode_sentinal ~debug =
-  let p = if effects () then fix_switch_branches p else p in
+  let p = if effects_cps () then fix_switch_branches p else p in
   let module G = Generate (Gc_target) in
   G.f ~context ~unit_name ~live_vars ~in_cps ~deadcode_sentinal ~debug p
 

compiler/lib/config.mli

@@ -40,7 +40,6 @@ module Flag : sig
 
   val staticeval : unit -> bool
 
-  (* Deprecated in favor of toplevel function [effects] below *)
   val effects : unit -> bool
 
   val genprim : unit -> bool

compiler/lib/driver.ml

@@ -99,7 +99,7 @@ let map_fst f (x, y, z) = f x, y, z
 
 let effects ~deadcode_sentinal p =
   match Config.effects () with
-  | Some _ ->
+  | Some (_ as effects) ->
       if debug () then Format.eprintf "Effects...@.";
       let p, live_vars = Deadcode.f p in
       let p = Effects.remove_empty_blocks ~live_vars p in
@@ -115,31 +115,30 @@ let effects ~deadcode_sentinal p =
       p
       |> Effects.f ~flow_info:info ~live_vars
       |> map_fst
-           (match Config.effects () with
-           | Some Double_translation -> Fun.id
-           | Some Cps -> Lambda_lifting.f
-           | None -> assert false)
+           (match effects with
+           | Double_translation -> Fun.id
+           | Cps -> Lambda_lifting.f)
   | None ->
       ( p
       , (Code.Var.Set.empty : Effects.trampolined_calls)
       , (Code.Var.Set.empty : Effects.in_cps) )
 
 let exact_calls profile ~deadcode_sentinal p =
-  if Option.is_none (Config.effects ())
-  then
-    let fast =
-      match profile with
-      | O3 -> false
-      | O1 | O2 -> true
-    in
-    let info = Global_flow.f ~fast p in
-    let p =
-      if Config.Flag.globaldeadcode () && Config.Flag.deadcode ()
-      then Global_deadcode.f p ~deadcode_sentinal info
-      else p
-    in
-    Specialize.f ~function_arity:(fun f -> Global_flow.function_arity info f) p
-  else p
+  match Config.effects () with
+  | None ->
+      let fast =
+        match profile with
+        | O3 -> false
+        | O1 | O2 -> true
+      in
+      let info = Global_flow.f ~fast p in
+      let p =
+        if Config.Flag.globaldeadcode () && Config.Flag.deadcode ()
+        then Global_deadcode.f p ~deadcode_sentinal info
+        else p
+      in
+      Specialize.f ~function_arity:(fun f -> Global_flow.function_arity info f) p
+  | Some _ -> p
 
 let print p =
   if debug () then Code.Print.program (fun _ _ -> "") p;

compiler/lib/inline.ml

@@ -330,9 +330,9 @@ let times = Debug.find "times"
 
 let f p live_vars =
   let first_class_primitives =
-    match Config.target () with
-    | `JavaScript -> Option.is_none (Config.effects ())
-    | `Wasm -> false
+    match Config.target (), Config.effects () with
+    | `JavaScript, None -> true
+    | `JavaScript, Some _ | `Wasm, _ -> false
   in
   Code.invariant p;
   let t = Timer.make () in

compiler/lib/js_output.ml

@@ -2099,8 +2099,10 @@ let program ?(accept_unnamed_var = false) ?(source_map = false) f p =
     let accept_unnamed_var = accept_unnamed_var
   end) in
   PP.set_needed_space_function f need_space;
-  if Option.is_some (Config.effects ())
-  then PP.set_adjust_indentation_function f (fun n -> n mod 40);
+  (match Config.effects () with
+  | Some Cps | Some Double_translation ->
+      PP.set_adjust_indentation_function f (fun n -> n mod 40)
+  | None -> ());
   PP.start_group f 0;
   O.program f p;
   PP.end_group f;

compiler/lib/unit_info.ml

@@ -53,7 +53,9 @@ let of_cmo (cmo : Cmo_format.compilation_unit) =
   let requires = StringSet.of_list (Cmo_format.requires cmo) in
   let requires = StringSet.diff requires provides in
   let effects_without_cps =
-    Option.is_none (Config.effects ())
+    (match Config.effects () with
+    | None -> true
+    | Some (Cps | Double_translation) -> false)
     && List.exists (Cmo_format.primitives cmo) ~f:(function
          | "%resume" | "%reperform" | "%perform" -> true
          | _ -> false)

compiler/tests-compiler/direct_calls.ml

@@ -102,7 +102,7 @@ let%expect_test "direct calls without --effects=cps" =
 let%expect_test "direct calls with --effects=cps" =
   let code =
     compile_and_parse
-      ~effects:true
+      ~effects:Js_of_ocaml_compiler.Config.Cps
       {|
          (* Arity of the argument of a function / direct call *)
          let test1 () =

compiler/tests-compiler/double-translation/direct_calls.ml

@@ -21,8 +21,7 @@ open Util
 let%expect_test "direct calls with --effects=double-translation" =
   let code =
     compile_and_parse
-      ~effects:true
-      ~doubletranslate:true
+      ~effects:Js_of_ocaml_compiler.Config.Double_translation
       {|
          (* Arity of the argument of a function / direct call *)
          let test1 () =

compiler/tests-compiler/double-translation/effects_continuations.ml

@@ -22,8 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
-      ~doubletranslate:true
+      ~effects:Js_of_ocaml_compiler.Config.Double_translation
       {|
          let list_rev = List.rev
          (* Avoid to expose the offset of stdlib modules *)

compiler/tests-compiler/double-translation/effects_exceptions.ml

@@ -22,8 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
-      ~doubletranslate:true
+      ~effects:Js_of_ocaml_compiler.Config.Double_translation
       {|
          let exceptions s =
            (* Compiled using 'try ... catch',

compiler/tests-compiler/double-translation/effects_toplevel.ml

@@ -22,8 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
-      ~doubletranslate:true
+      ~effects:Js_of_ocaml_compiler.Config.Double_translation
       {|
          (* Function calls at toplevel outside of loops do not use
             [caml_callback] when double translation is enabled. *)

compiler/tests-compiler/effects.ml

@@ -22,7 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let program =
     compile_and_parse
-      ~effects:true
+      ~effects:Js_of_ocaml_compiler.Config.Cps
       {|
 
 open Effect

compiler/tests-compiler/effects_continuations.ml

@@ -22,7 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
+      ~effects:Js_of_ocaml_compiler.Config.Cps
       {|
 
          let list_rev = List.rev

compiler/tests-compiler/effects_exceptions.ml

@@ -22,7 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
+      ~effects:Js_of_ocaml_compiler.Config.Cps
       {|
          let exceptions s =
            (* Compiled using 'try ... catch',

compiler/tests-compiler/effects_toplevel.ml

@@ -22,7 +22,7 @@ open Util
 let%expect_test "test-compiler/lib-effects/test1.ml" =
   let code =
     compile_and_parse
-      ~effects:true
+      ~effects:Js_of_ocaml_compiler.Config.Cps
       {|
          (* Function calls at toplevel outside of loops use
             [caml_callback]. *)

compiler/tests-compiler/es6.ml

@@ -10,7 +10,7 @@ let f x =
     |}
   in
   let flags = [ "--enable"; "es6" ] in
-  let program = Util.compile_and_parse ~effects:false ~pretty:true ~flags prog in
+  let program = Util.compile_and_parse ?effects:None ~pretty:true ~flags prog in
   Util.print_program program;
   [%expect
     {|
@@ -24,7 +24,7 @@ let f x =
        return;})
      (globalThis);
     //end |}];
-  let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags prog in
+  let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags prog in
   Util.print_program program;
   [%expect
     {|
@@ -46,7 +46,7 @@ let rec odd n' = function
     |}
   in
   let flags = [ "--enable"; "es6" ] in
-  let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags prog in
+  let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags prog in
   Util.print_program program;
   [%expect
     {|
@@ -67,7 +67,7 @@ let rec odd n' = function
        return;})
      (globalThis);
     //end |}];
-  let program = Util.compile_and_parse ~effects:false ~pretty:false ~flags:[] prog in
+  let program = Util.compile_and_parse ?effects:None ~pretty:false ~flags:[] prog in
   Util.print_program program;
   [%expect
     {|

compiler/tests-compiler/lambda_lifting.ml

@@ -14,9 +14,11 @@ Printf.printf "%d\n" (f 3)
   let flags =
     [ "--no-inline"; "--set=lifting-threshold=1"; "--set=lifting-baseline=0" ]
   in
-  Util.compile_and_run ~effects:true ~flags prog;
+  Util.compile_and_run ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog;
   [%expect {|15 |}];
-  let program = Util.compile_and_parse ~effects:true ~flags prog in
+  let program =
+    Util.compile_and_parse ~effects:Js_of_ocaml_compiler.Config.Cps ~flags prog
+  in
   Util.print_program program;
   [%expect
     {|

compiler/tests-compiler/util/util.ml

@@ -290,22 +290,20 @@ let extract_sourcemap file =
 let compile_to_javascript
     ?(flags = [])
     ?(use_js_string = false)
-    ?(effects = false)
-    ?(doubletranslate = false)
+    ?effects
     ~pretty
     ~sourcemap
     file =
-  assert ((not doubletranslate) || effects);
   let out_file = swap_extention file ~ext:"js" in
   let extra_args =
     List.flatten
       [ (if pretty then [ "--pretty" ] else [])
       ; (if sourcemap then [ "--sourcemap" ] else [])
-      ; (if effects && doubletranslate
-         then [ "--effects=double-translation" ]
-         else if effects
-         then [ "--effects=cps" ]
-         else [])
+      ; (match effects with
+        | Some Js_of_ocaml_compiler.Config.Double_translation ->
+            [ "--effects=double-translation" ]
+        | Some Cps -> [ "--effects=cps" ]
+        | None -> [])
       ; (if use_js_string
          then [ "--enable=use-js-string" ]
          else [ "--disable=use-js-string" ])
@@ -358,15 +356,13 @@ let compile_bc_to_javascript
 let compile_cmo_to_javascript
     ?(flags = [])
     ?effects
-    ?doubletranslate
     ?use_js_string
     ?(pretty = true)
     ?(sourcemap = true)
     file =
   Filetype.path_of_cmo_file file
   |> compile_to_javascript
        ?effects
-       ?doubletranslate
        ?use_js_string
        ~flags:([ "--disable"; "header" ] @ flags)
        ~pretty
@@ -632,26 +628,13 @@ let compile_and_parse_whole_program
       |> compile_bc_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug
       |> parse_js)
 
-let compile_and_parse
-    ?(debug = true)
-    ?pretty
-    ?flags
-    ?effects
-    ?doubletranslate
-    ?use_js_string
-    s =
+let compile_and_parse ?(debug = true) ?pretty ?flags ?effects ?use_js_string s =
   with_temp_dir ~f:(fun () ->
       s
       |> Filetype.ocaml_text_of_string
       |> Filetype.write_ocaml ~name:"test.ml"
       |> compile_ocaml_to_cmo ~debug
-      |> compile_cmo_to_javascript
-           ?pretty
-           ?flags
-           ?effects
-           ?doubletranslate
-           ?use_js_string
-           ~sourcemap:debug
+      |> compile_cmo_to_javascript ?pretty ?flags ?effects ?use_js_string ~sourcemap:debug
       |> parse_js)
 
 let normalize_path s =