diff --git a/CHANGES.md b/CHANGES.md index c8ab3043b8..d4d59a036f 100644 --- a/CHANGES.md +++ b/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) diff --git a/README.md b/README.md index a52ac2582c..c51dc4ddd8 100644 --- a/README.md +++ b/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 diff --git a/README_wasm_of_ocaml.md b/README_wasm_of_ocaml.md index 256ff4045b..b50568ed72 100644 --- a/README_wasm_of_ocaml.md +++ b/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) diff --git a/compiler/bin-js_of_ocaml/cmd_arg.ml b/compiler/bin-js_of_ocaml/cmd_arg.ml index c294be23a1..2d75b44278 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.ml +++ b/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 diff --git a/compiler/bin-js_of_ocaml/cmd_arg.mli b/compiler/bin-js_of_ocaml/cmd_arg.mli index ec756685b5..35006290bf 100644 --- a/compiler/bin-js_of_ocaml/cmd_arg.mli +++ b/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 diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index b87036c1a6..5e96635cd2 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/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, _ -> () diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.ml b/compiler/bin-wasm_of_ocaml/cmd_arg.ml index 5b6c86b399..f2a6eee653 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.ml +++ b/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 diff --git a/compiler/bin-wasm_of_ocaml/cmd_arg.mli b/compiler/bin-wasm_of_ocaml/cmd_arg.mli index 74d38c76fc..4fa4035113 100644 --- a/compiler/bin-wasm_of_ocaml/cmd_arg.mli +++ b/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 diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 9957756643..c54ca4e1fb 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/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; diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 1bc2bc2f5a..fa8ba93360 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/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) : diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index 06845810c7..b21f4002c7 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/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) -> diff --git a/compiler/lib-wasm/gc_target.ml b/compiler/lib-wasm/gc_target.ml index f2e6b7eccd..f7bdc62f61 100644 --- a/compiler/lib-wasm/gc_target.ml +++ b/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 diff --git a/compiler/lib-wasm/generate.ml b/compiler/lib-wasm/generate.ml index d5e590dff2..b7b3613f72 100644 --- a/compiler/lib-wasm/generate.ml +++ b/compiler/lib-wasm/generate.ml @@ -21,6 +21,8 @@ open Code module W = Wasm_ast open Code_generation +let effects_cps () = Option.is_some (Config.effects ()) + module Generate (Target : Target_sig.S) = struct open Target @@ -237,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:(Config.Flag.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:(Config.Flag.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 @@ -1177,9 +1179,7 @@ let init () = in Primitive.register "caml_array_of_uniform_array" `Mutable None None; let l = - if Config.Flag.effects () - then ("caml_alloc_stack", "caml_cps_alloc_stack") :: l - else 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 @@ -1222,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 Config.Flag.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 diff --git a/compiler/lib/build_info.ml b/compiler/lib/build_info.ml index 9802c9eb81..efd0425058 100644 --- a/compiler/lib/build_info.ml +++ b/compiler/lib/build_info.ml @@ -36,6 +36,17 @@ let string_of_kind = function | `Cma -> "cma" | `Unknown -> "unknown" +let string_of_effects_backend = function + | None -> "none" + | Some Config.Cps -> "cps" + | Some Config.Double_translation -> "double-translation" + +let effects_backend_of_string = function + | "none" -> None + | "cps" -> Some Config.Cps + | "double-translation" -> Some Double_translation + | _ -> invalid_arg "effects_backend_of_string" + let kind_of_string s = match List.find_opt all ~f:(fun k -> String.equal s (string_of_kind k)) with | None -> `Unknown @@ -55,7 +66,7 @@ let create kind = | v -> Printf.sprintf "%s+%s" Compiler_version.s v in [ "use-js-string", string_of_bool (Config.Flag.use_js_string ()) - ; "effects", string_of_bool (Config.Flag.effects ()) + ; "effects", string_of_effects_backend (Config.effects ()) ; "version", version ; "kind", string_of_kind kind ] @@ -143,6 +154,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" -> Config.Flag.set k (bool_of_string v) + | "effects" -> Config.set_effects_backend (effects_backend_of_string v) | _ -> ()) t diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index a260794262..05249533e8 100644 --- a/compiler/lib/code.ml +++ b/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 diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index deb487987f..e39038a8bc 100644 --- a/compiler/lib/code.mli +++ b/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 diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 29f39a1f02..6f25f2485a 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -195,3 +195,13 @@ let set_target (t : [ `JavaScript | `Wasm ]) = | `JavaScript -> Targetint.set_num_bits 32 | `Wasm -> Targetint.set_num_bits 31); target_ := (t :> [ `JavaScript | `Wasm | `None ]) + +type effects_backend = + | Cps + | Double_translation + +let effects_ : effects_backend option ref = ref None + +let effects () = !effects_ + +let set_effects_backend backend = effects_ := backend diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index 4954602b1b..81df2c6ebd 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -16,6 +16,7 @@ * along with this program; if not, write to the Free Software * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) + module Flag : sig val available : unit -> string list @@ -115,3 +116,11 @@ end val target : unit -> [ `JavaScript | `Wasm ] val set_target : [ `JavaScript | `Wasm ] -> unit + +type effects_backend = + | Cps + | Double_translation + +val effects : unit -> effects_backend option + +val set_effects_backend : effects_backend option -> unit diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index b0580bef14..82a603eaa4 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -98,42 +98,47 @@ let ( +> ) f g x = g (f x) let map_fst f (x, y, z) = f x, y, z let effects ~deadcode_sentinal p = - if Config.Flag.effects () - then ( - if debug () then Format.eprintf "Effects...@."; - let p, live_vars = Deadcode.f p in - let p = Effects.remove_empty_blocks ~live_vars p in - let p, live_vars = Deadcode.f p in - let info = Global_flow.f ~fast:false p in - let p, live_vars = - if Config.Flag.globaldeadcode () - then - let p = Global_deadcode.f p ~deadcode_sentinal info in - Deadcode.f p - else p, live_vars - in - p |> Effects.f ~flow_info:info ~live_vars +> map_fst Lambda_lifting.f) - else - ( p - , (Code.Var.Set.empty : Effects.trampolined_calls) - , (Code.Var.Set.empty : Effects.in_cps) ) + match Config.effects () with + | 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 + let p, live_vars = Deadcode.f p in + let info = Global_flow.f ~fast:false p in + let p, live_vars = + if Config.Flag.globaldeadcode () + then + let p = Global_deadcode.f p ~deadcode_sentinal info in + Deadcode.f p + else p, live_vars + in + p + |> Effects.f ~flow_info:info ~live_vars + |> map_fst + (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 not (Config.Flag.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; @@ -202,7 +207,7 @@ 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 @@ -210,6 +215,7 @@ let generate ~exported_runtime ~live_vars:variable_uses ~trampolined_calls + ~in_cps ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal @@ -691,9 +697,9 @@ let optimize ~profile p = +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal +> map_fst - (match Config.target (), Config.Flag.effects () with - | `JavaScript, false -> Generate_closure.f - | `JavaScript, true | `Wasm, _ -> Fun.id) + (match Config.target (), Config.effects () with + | `JavaScript, None -> Generate_closure.f + | `JavaScript, Some _ | `Wasm, _ -> Fun.id) +> map_fst deadcode' in if times () then Format.eprintf "Start Optimizing...@."; diff --git a/compiler/lib/duplicate.ml b/compiler/lib/duplicate.ml index c4e6242355..683bba7d4b 100644 --- a/compiler/lib/duplicate.ml +++ b/compiler/lib/duplicate.ml @@ -19,53 +19,6 @@ open! Stdlib open Code -let subst_cont m s (pc, arg) = Addr.Map.find pc m, List.map arg ~f:(fun x -> s x) - -let expr s e = - match e with - | Constant _ -> e - | Apply { f; args; exact } -> - Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } - | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) - | Field (x, n, field_type) -> Field (s x, n, field_type) - | Closure _ -> failwith "Inlining/Duplicating closure is currenly not supported" - | Special x -> Special x - | Prim (p, l) -> - Prim - ( p - , List.map l ~f:(function - | Pv x -> Pv (s x) - | Pc _ as x -> x) ) - -let instr s i = - match i with - | Let (x, e) -> Let (s x, expr s e) - | Assign (x, y) -> Assign (s x, s y) - | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) - | Offset_ref (x, n) -> Offset_ref (s x, n) - | Array_set (x, y, z) -> Array_set (s x, s y, s z) - | Event _ -> i - -let instrs s l = List.map l ~f:(fun i -> instr s i) - -let last m s l = - match l with - | Stop -> l - | Branch cont -> Branch (subst_cont m s cont) - | Pushtrap (cont1, x, cont2) -> - Pushtrap (subst_cont m s cont1, s x, subst_cont m s cont2) - | Return x -> Return (s x) - | Raise (x, k) -> Raise (s x, k) - | Cond (x, cont1, cont2) -> Cond (s x, subst_cont m s cont1, subst_cont m s cont2) - | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont m s cont)) - | Poptrap cont -> Poptrap (subst_cont m s cont) - -let block m s block = - { params = List.map ~f:s block.params - ; body = instrs s block.body - ; branch = last m s block.branch - } - let closure p ~bound_vars ~f ~params ~cont:(pc, args) = let s = Subst.from_map @@ -84,7 +37,7 @@ let closure p ~bound_vars ~f ~params ~cont:(pc, args) = { fold = Code.fold_children } (fun pc blocks -> let b = Addr.Map.find pc blocks in - let b = block m s b in + let b = Subst.Including_Binders.And_Continuations.block m s b in Addr.Map.add (Addr.Map.find pc m) b blocks) pc p.blocks diff --git a/compiler/lib/duplicate.mli b/compiler/lib/duplicate.mli index 94ce7b7588..3ebbea1866 100644 --- a/compiler/lib/duplicate.mli +++ b/compiler/lib/duplicate.mli @@ -23,3 +23,9 @@ val closure : -> params:Code.Var.t list -> cont:int * Code.Var.t list -> Code.program * Code.Var.t * Code.Var.t list * (int * Code.Var.t list) +(** Given a program and a closure [f] -- defined by its name, parameters, and its + continuation --, return a program in which the body of [f] has been updated with fresh + variable names to replace elements of [bound_vars]. Also returns the new name of [f] + (fresh if [f] is in [bound_vars]), and the similarly substituted parameter list and + continuation. + *) diff --git a/compiler/lib/effects.ml b/compiler/lib/effects.ml index 5c3438ab00..10d7dc2910 100644 --- a/compiler/lib/effects.ml +++ b/compiler/lib/effects.ml @@ -38,6 +38,15 @@ open Code let debug = Debug.find "effects" +let double_translate () = + match Config.effects () with + | None -> assert false + | Some Cps -> false + | Some Double_translation -> true + +let debug_print fmt = + if debug () then Format.(eprintf (fmt ^^ "%!")) else Format.(ifprintf err_formatter fmt) + let get_edges g src = try Hashtbl.find g src with Not_found -> Addr.Set.empty let add_edge g src dst = Hashtbl.replace g src (Addr.Set.add dst (get_edges g src)) @@ -104,12 +113,6 @@ let dominator_tree g = l); dom -(* pc dominates pc' *) -let rec dominates g idom pc pc' = - pc = pc' - || Hashtbl.find g.block_order pc < Hashtbl.find g.block_order pc' - && dominates g idom pc (Hashtbl.find idom pc') - (* pc has at least two forward edges moving into it *) let is_merge_node g pc = let s = try Hashtbl.find g.preds pc with Not_found -> assert false in @@ -163,6 +166,15 @@ let empty_body b = (****) +let effect_primitive_or_application = function + | Prim (Extern ("%resume" | "%perform" | "%reperform"), _) | Apply _ -> true + | Block (_, _, _, _) + | Field (_, _, _) + | Closure (_, _) + | Constant _ + | Prim (_, _) + | Special _ -> false + (* We establish the list of blocks that needs to be CPS-transformed. We also mark blocks that correspond to function continuations or @@ -199,10 +211,8 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start = (match block.branch with | Branch (dst, _) -> ( match last_instr block.body with - | Some - (Let - (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _)))) - when Var.Set.mem x cps_needed -> + | Some (Let (x, e)) + when effect_primitive_or_application e && Var.Set.mem x cps_needed -> (* The block after a function application that needs to be turned to CPS or an effect primitive needs to be transformed. *) @@ -241,7 +251,9 @@ let compute_needed_transformations ~cfg ~idom ~cps_needed ~blocks ~start = dominator of the block. [closure_of_jump] provides the name of the function correspoding to each block. [closures_of_alloc_site] provides the list of functions which should be defined in a given - block. Exception handlers are dealt with separately. + block. In case of double translation, the keys are the addresses of the + original (direct-style) blocks. Exception handlers are dealt with + separately. *) type jump_closures = { closure_of_jump : Var.t Addr.Map.t @@ -273,12 +285,13 @@ type trampolined_calls = Var.Set.t type in_cps = Var.Set.t type st = - { mutable new_blocks : Code.block Addr.Map.t * Code.Addr.t + { mutable new_blocks : Code.block Addr.Map.t + ; mutable free_pc : Code.Addr.t ; blocks : Code.block Addr.Map.t ; cfg : control_flow_graph - ; idom : (int, int) Hashtbl.t ; jc : jump_closures - ; closure_info : (Addr.t, Var.t * Code.cont) Hashtbl.t + ; closure_info : (Addr.t, Var.t list * (Addr.t * Var.t list)) Hashtbl.t + (* Associates a function's address with its CPS parameters and CPS continuation *) ; cps_needed : Var.Set.t ; blocks_to_transform : Addr.Set.t ; is_continuation : (Addr.t, [ `Param of Var.t | `Loop ]) Hashtbl.t @@ -286,19 +299,38 @@ type st = ; block_order : (Addr.t, int) Hashtbl.t ; live_vars : Deadcode.variable_uses ; flow_info : Global_flow.info - ; trampolined_calls : trampolined_calls ref - ; in_cps : in_cps ref + ; trampolined_calls : trampolined_calls ref (* Call sites that require trampolining *) + ; in_cps : in_cps ref (* Call sites whose callee must have a CPS component *) + ; cps_pc_of_direct : (int, int) Hashtbl.t + (* Mapping from direct-style to CPS addresses of functions (used when + double translation is enabled) *) } let add_block st block = - let blocks, free_pc = st.new_blocks in - st.new_blocks <- Addr.Map.add free_pc block blocks, free_pc + 1; + let free_pc = st.free_pc in + st.new_blocks <- Addr.Map.add free_pc block st.new_blocks; + st.free_pc <- free_pc + 1; free_pc +(* Provide the address of the CPS translation of a block *) +let mk_cps_pc_of_direct ~st pc = + if double_translate () + then ( + try Hashtbl.find st.cps_pc_of_direct pc + with Not_found -> + let free_pc = st.free_pc in + st.free_pc <- free_pc + 1; + Hashtbl.add st.cps_pc_of_direct pc free_pc; + free_pc) + else pc + +let cps_cont_of_direct ~st (pc, args) = mk_cps_pc_of_direct ~st pc, args + let closure_of_pc ~st pc = try Addr.Map.find pc st.jc.closure_of_jump with Not_found -> assert false let allocate_closure ~st ~params ~body ~branch = + debug_print "@[allocate_closure ~branch:(%a)@,@]" Code.Print.last branch; let block = { params = []; body; branch } in let pc = add_block st block in let name = Var.fresh () in @@ -313,7 +345,7 @@ let tail_call ~st ?(instrs = []) ~exact ~in_cps ~check ~f args = let cps_branch ~st ~src (pc, args) = match Addr.Set.mem pc st.blocks_to_transform with - | false -> [], Branch (pc, args) + | false -> [], Branch (mk_cps_pc_of_direct ~st pc, args) | true -> let args, instrs = if List.is_empty args && Hashtbl.mem st.is_continuation pc @@ -338,7 +370,7 @@ let cps_branch ~st ~src (pc, args) = let cps_jump_cont ~st ~src ((pc, _) as cont) = match Addr.Set.mem pc st.blocks_to_transform with - | false -> cont + | false -> cps_cont_of_direct ~st cont | true -> let call_block = let body, branch = cps_branch ~st ~src cont in @@ -346,7 +378,11 @@ let cps_jump_cont ~st ~src ((pc, _) as cont) = in call_block, [] -let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = +let allocate_continuation ~st ~alloc_jump_closures ~split_closures src_pc x direct_cont = + debug_print + "@[allocate_continuation ~src_pc:%d ~cont:(%d,@ _)@,@]" + src_pc + (fst direct_cont); (* We need to allocate an additional closure if [cont] does not correspond to a continuation that binds [x]. This closure binds the return value [x], allocates @@ -355,19 +391,19 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = closure to bind [x] if it is used in the loop body. In other cases, we can just pass the closure corresponding to the next block. *) - let pc', args = cont in + let direct_pc, args = direct_cont in if (match args with | [] -> true | [ x' ] -> Var.equal x x' | _ -> false) && - match Hashtbl.find st.is_continuation pc' with + match Hashtbl.find st.is_continuation direct_pc with | `Param _ -> true | `Loop -> st.live_vars.(Var.idx x) = List.length args - then alloc_jump_closures, closure_of_pc ~st pc' + then alloc_jump_closures, closure_of_pc ~st direct_pc else - let body, branch = cps_branch ~st ~src:pc cont in + let body, branch = cps_branch ~st ~src:src_pc direct_cont in let inner_closures, outer_closures = (* For [Pushtrap], we need to separate the closures corresponding to the exception handler body (that may make @@ -375,13 +411,13 @@ let allocate_continuation ~st ~alloc_jump_closures ~split_closures pc x cont = of the exception handler. *) if not split_closures then alloc_jump_closures, [] - else if is_merge_node st.cfg pc' + else if is_merge_node st.cfg direct_pc then [], alloc_jump_closures else List.partition ~f:(fun i -> match i with - | Let (_, Closure (_, (pc'', []))) -> dominates st.cfg st.idom pc' pc'' + | Let (_, Closure (_, (pc'', []))) -> pc'' = mk_cps_pc_of_direct ~st direct_pc | _ -> assert false) alloc_jump_closures in @@ -394,7 +430,7 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = match last with | Return x -> assert (List.is_empty alloc_jump_closures); - (* Is the number of successive 'returns' is unbounded is CPS, it + (* If the number of successive 'returns' is unbounded in CPS, it means that we have an unbounded of calls in direct style (even with tail call optimization) *) tail_call ~st ~exact:true ~in_cps:false ~check:false ~f:k [ x ] @@ -454,7 +490,11 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = | Pushtrap (body_cont, exn, ((handler_pc, _) as handler_cont)) -> ( assert (Hashtbl.mem st.is_continuation handler_pc); match Addr.Set.mem handler_pc st.blocks_to_transform with - | false -> alloc_jump_closures, last + | false -> + let body_cont = cps_cont_of_direct ~st body_cont in + let handler_cont = cps_cont_of_direct ~st handler_cont in + let last = Pushtrap (body_cont, exn, handler_cont) in + alloc_jump_closures, last | true -> let constr_cont, exn_handler = allocate_continuation @@ -482,14 +522,17 @@ let cps_last ~st ~alloc_jump_closures pc (last : last) ~k : instr list * last = @ (Let (exn_handler, Prim (Extern "caml_pop_trap", [])) :: body) , branch )) -let cps_instr ~st (instr : instr) : instr = +let rewrite_instr ~st (instr : instr) : instr = match instr with - | Let (x, Closure (params, (pc, _))) when Var.Set.mem x st.cps_needed -> + | Let (x, Closure (_, (pc, _))) when Var.Set.mem x st.cps_needed -> + (* When CPS-transforming with double translation enabled, there are no closures in + code that requires transforming, due to lambda lifiting. *) + assert (not (double_translate ())); (* Add the continuation parameter, and change the initial block if needed *) - let k, cont = Hashtbl.find st.closure_info pc in + let cps_params, cps_cont = Hashtbl.find st.closure_info pc in st.in_cps := Var.Set.add x !(st.in_cps); - Let (x, Closure (params @ [ k ], cont)) + Let (x, Closure (cps_params, cps_cont)) | Let (x, Prim (Extern "caml_alloc_dummy_function", [ size; arity ])) -> ( match arity with | Pc (Int a) -> @@ -502,15 +545,41 @@ let cps_instr ~st (instr : instr) : instr = | Let (x, Apply { f; args; _ }) when not (Var.Set.mem x st.cps_needed) -> (* At the moment, we turn into CPS any function not called with the right number of parameter *) - assert (Global_flow.exact_call st.flow_info f (List.length args)); + assert ( + (* If this function is unknown to the global flow analysis, then it was + introduced by the lambda lifting and we don't have exactness info any more. *) + Var.idx f >= Var.Tbl.length st.flow_info.info_approximation + || Global_flow.exact_call st.flow_info f (List.length args)); Let (x, Apply { f; args; exact = true }) - | Let (_, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + | Let (_, e) when effect_primitive_or_application e -> + (* For the CPS target, applications of CPS functions and effect primitives require + more work (allocating a continuation and/or modifying end-of-block branches) and + are handled in a specialized function. *) assert false | _ -> instr -let cps_block ~st ~k pc block = +let call_exact flow_info (f : Var.t) nargs : bool = + (* If [f] is unknown to the global flow analysis, then it was introduced by + the lambda lifting and we don't have exactness about it. *) + Var.idx f < Var.Tbl.length flow_info.Global_flow.info_approximation + && Global_flow.exact_call flow_info f nargs + +let cps_instr ~st (instr : instr) : instr list = + match instr with + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) when double_translate () -> + (* When double translation is enabled, we just call [f] in direct style. + Otherwise, the runtime primitive is used. *) + let unit = Var.fresh_n "unit" in + [ Let (unit, Constant (Int Targetint.zero)) + ; Let (x, Apply { exact = call_exact st.flow_info f 1; f; args = [ unit ] }) + ] + | _ -> [ rewrite_instr ~st instr ] + +let cps_block ~st ~k ~orig_pc block = + debug_print "cps_block %d\n" orig_pc; + debug_print "cps pc evaluates to %d\n" (mk_cps_pc_of_direct ~st orig_pc); let alloc_jump_closures = - match Addr.Map.find pc st.jc.closures_of_alloc_site with + match Addr.Map.find orig_pc st.jc.closures_of_alloc_site with | to_allocate -> List.map to_allocate ~f:(fun (cname, jump_pc) -> let params = @@ -538,11 +607,12 @@ let cps_block ~st ~k pc block = [ x ] else jump_block.params in - Let (cname, Closure (params, (jump_pc, [])))) + let cps_jump_pc = mk_cps_pc_of_direct ~st jump_pc in + Let (cname, Closure (params, (cps_jump_pc, [])))) | exception Not_found -> [] in - let rewrite_instr x e = + let rewrite_last_instr (x : Var.t) (e : expr) : (k:Var.t -> instr list * last) option = let perform_effect ~effect_ ~continuation = Some (fun ~k -> @@ -556,9 +626,7 @@ let cps_block ~st ~k pc block = | Apply { f; args; exact } when Var.Set.mem x st.cps_needed -> Some (fun ~k -> - let exact = - exact || Global_flow.exact_call st.flow_info f (List.length args) - in + let exact = exact || call_exact st.flow_info f (List.length args) in tail_call ~st ~exact ~in_cps:true ~check:true ~f (args @ [ k ])) | Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ]) -> Some @@ -567,7 +635,7 @@ let cps_block ~st ~k pc block = tail_call ~st ~instrs:[ Let (k', Prim (Extern "caml_resume_stack", [ Pv stack; Pv k ])) ] - ~exact:(Global_flow.exact_call st.flow_info f 1) + ~exact:(call_exact st.flow_info f 1) ~in_cps:true ~check:true ~f @@ -582,19 +650,19 @@ let cps_block ~st ~k pc block = let rewritten_block = match block_split_last block.body, block.branch with | Some (body_prefix, Let (x, e)), Return ret -> - Option.map (rewrite_instr x e) ~f:(fun f -> + Option.map (rewrite_last_instr x e) ~f:(fun f -> assert (List.is_empty alloc_jump_closures); assert (Var.equal x ret); let instrs, branch = f ~k in body_prefix, instrs, branch) | Some (body_prefix, Let (x, e)), Branch cont -> - Option.map (rewrite_instr x e) ~f:(fun f -> + Option.map (rewrite_last_instr x e) ~f:(fun f -> let constr_cont, k' = allocate_continuation ~st ~alloc_jump_closures ~split_closures:false - pc + orig_pc x cont in @@ -608,26 +676,96 @@ let cps_block ~st ~k pc block = let body, last = match rewritten_block with | Some (body_prefix, last_instrs, last) -> - List.map body_prefix ~f:(fun i -> cps_instr ~st i) @ last_instrs, last + let body_prefix = + List.map body_prefix ~f:(fun i -> cps_instr ~st i) |> List.concat + in + body_prefix @ last_instrs, last | None -> - let last_instrs, last = cps_last ~st ~alloc_jump_closures pc block.branch ~k in - let body = List.map block.body ~f:(fun i -> cps_instr ~st i) @ last_instrs in - body, last + let last_instrs, last = + cps_last ~st ~alloc_jump_closures orig_pc block.branch ~k + in + let body = List.map block.body ~f:(fun i -> cps_instr ~st i) |> List.concat in + body @ last_instrs, last in - { params = (if Addr.Set.mem pc st.blocks_to_transform then [] else block.params) + { params = (if Addr.Set.mem orig_pc st.blocks_to_transform then [] else block.params) ; body ; branch = last } +(* If double-translating, modify all function applications and closure + creations to take into account the fact that some closures must now have a + CPS version. Also rewrite the effect primitives to switch to the CPS version + of functions (for resume) or fail (for perform). + If not double-translating, then just add continuation arguments to function + definitions, and mark as exact all non-CPS calls. *) +let rewrite_direct_block ~st ~cps_needed ~closure_info ~pc block = + debug_print "@[rewrite_direct_block %d@,@]" pc; + if double_translate () + then + let rewrite_instr = function + | Let (x, Closure (params, ((pc, _) as cont))) when Var.Set.mem x cps_needed -> + let direct_c = Var.fork x in + let cps_c = Var.fork x in + let cps_params, cps_cont = Hashtbl.find closure_info pc in + [ Let (direct_c, Closure (params, cont)) + ; Let (cps_c, Closure (cps_params, cps_cont)) + ; Let (x, Prim (Extern "caml_cps_closure", [ Pv direct_c; Pv cps_c ])) + ] + | Let (x, Prim (Extern "%resume", [ Pv stack; Pv f; Pv arg ])) -> + [ Let (x, Prim (Extern "caml_resume", [ Pv f; Pv arg; Pv stack ])) ] + | Let (x, Prim (Extern "%perform", [ Pv effect_ ])) -> + (* In direct-style code, we just raise [Effect.Unhandled]. *) + [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] + | Let (x, Prim (Extern "%reperform", [ Pv effect_; Pv _continuation ])) -> + (* Similar to previous case *) + [ Let (x, Prim (Extern "caml_raise_unhandled", [ Pv effect_ ])) ] + | Let (x, Prim (Extern "caml_assume_no_perform", [ Pv f ])) -> + (* We just need to call [f] in direct style. *) + let unit = Var.fresh_n "unit" in + let unit_val = Int Targetint.zero in + let exact = call_exact st.flow_info f 1 in + [ Let (unit, Constant unit_val); Let (x, Apply { exact; f; args = [ unit ] }) ] + | (Let _ | Assign _ | Set_field _ | Offset_ref _ | Array_set _ | Event _) as instr + -> [ instr ] + in + let body = List.concat_map block.body ~f:(fun i -> rewrite_instr i) in + { block with body } + else { block with body = List.map ~f:(rewrite_instr ~st) block.body } + +(* Apply a substitution in a set of blocks, including to bound variables *) +let subst_bound_in_blocks blocks s = + Addr.Map.mapi + (fun pc block -> + if debug () + then ( + debug_print "@[block before first subst: @,"; + Code.Print.block (fun _ _ -> "") pc block; + debug_print "@]"); + let res = Subst.Including_Binders.block s block in + if debug () + then ( + debug_print "@[block after first subst: @,"; + Code.Print.block (fun _ _ -> "") pc res; + debug_print "@]"); + res) + blocks + +let subst_add_fresh array v = array.(Var.idx v) <- Var.fork v + let cps_transform ~live_vars ~flow_info ~cps_needed p = let closure_info = Hashtbl.create 16 in let trampolined_calls = ref Var.Set.empty in let in_cps = ref Var.Set.empty in + let cps_pc_of_direct = Hashtbl.create 512 in + let cloned_vars = Array.init (Var.count ()) ~f:Var.of_idx in + let cloned_subst = Subst.from_array cloned_vars in let p = Code.fold_closures_innermost_first p - (fun name_opt _ (start, args) ({ blocks; free_pc; _ } as p) -> + (fun name_opt params (start, args) ({ Code.blocks; free_pc; _ } as p) -> + Option.iter name_opt ~f:(fun v -> + debug_print "@[cname = %s@,@]" @@ Var.to_string v); (* We speculatively add a block at the beginning of the function. In case of tail-recursion optimization, the function implementing the loop body may have to be placed @@ -646,9 +784,10 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = match name_opt with | Some name -> Var.Set.mem name cps_needed | None -> - (* We are handling the toplevel code. There may remain - some CPS calls at toplevel. *) - true + (* We need to handle the CPS calls that are at toplevel, except + if we double-translate (in which case they are like all other + CPS calls from direct code). *) + not (double_translate ()) in let blocks_to_transform, matching_exn_handler, is_continuation = if should_compute_needed_transformations @@ -664,15 +803,17 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = let closure_jc = jump_closures blocks_to_transform idom in let start, args, blocks, free_pc = (* Insert an initial block if needed. *) - if Addr.Map.mem start' closure_jc.closures_of_alloc_site + if + should_compute_needed_transformations + && Addr.Map.mem start' closure_jc.closures_of_alloc_site then start', [], blocks', free_pc + 1 else start, args, blocks, free_pc in let st = - { new_blocks = Addr.Map.empty, free_pc + { new_blocks = Addr.Map.empty + ; free_pc ; blocks ; cfg - ; idom ; jc = closure_jc ; closure_info ; cps_needed @@ -684,16 +825,18 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = ; live_vars ; trampolined_calls ; in_cps + ; cps_pc_of_direct } in let function_needs_cps = match name_opt with | Some _ -> should_compute_needed_transformations | None -> - (* We are handling the toplevel code. If it performs no - CPS call, we can leave it in direct style and we - don't need to wrap it within a [caml_callback]. *) - not (Addr.Set.is_empty blocks_to_transform) + (* Toplevel code: if we double-translate, no need to handle it + specially: CPS calls in it are like all other CPS calls from + direct code. Otherwise, it needs to wrapped within a + [caml_callback], but only if it performs CPS calls. *) + not (double_translate () || Addr.Set.is_empty blocks_to_transform) in if debug () then ( @@ -711,52 +854,116 @@ let cps_transform ~live_vars ~flow_info ~cps_needed p = blocks ()); let blocks = + (* For every block in the closure, + 1. CPS-translate it if needed. If we double-translate, add its CPS + translation to the block map at a fresh address. Otherwise, + just replace the original block. + 2. If we double-translate, keep the direct-style block but modify function + definitions to add the CPS version where needed, and turn uses of %resume + and %perform into switchings to CPS. *) let transform_block = - if function_needs_cps + if function_needs_cps && double_translate () + then ( + let k = Var.fresh_n "cont" in + let cps_start = mk_cps_pc_of_direct ~st start in + List.iter ~f:(subst_add_fresh cloned_vars) params; + let params' = List.map ~f:cloned_subst params in + let cps_args = List.map ~f:cloned_subst args in + Hashtbl.add + st.closure_info + initial_start + (params' @ [ k ], (cps_start, cps_args)); + fun pc block -> + let cps_block = cps_block ~st ~k ~orig_pc:pc block in + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~pc + block + , Some cps_block )) + else if function_needs_cps && not (double_translate ()) then ( let k = Var.fresh_n "cont" in - Hashtbl.add closure_info initial_start (k, (start, args)); - fun pc block -> cps_block ~st ~k pc block) + Hashtbl.add st.closure_info initial_start (params @ [ k ], (start, args)); + fun pc block -> cps_block ~st ~k ~orig_pc:pc block, None) else - fun _ block -> - { block with body = List.map block.body ~f:(fun i -> cps_instr ~st i) } + fun pc block -> + ( rewrite_direct_block + ~st + ~cps_needed + ~closure_info:st.closure_info + ~pc + block + , None ) in Code.traverse { fold = Code.fold_children } (fun pc blocks -> - Addr.Map.add pc (transform_block pc (Addr.Map.find pc blocks)) blocks) + let block, cps_block_opt = transform_block pc (Addr.Map.find pc blocks) in + let blocks = Addr.Map.add pc block blocks in + match cps_block_opt with + | None -> blocks + | Some b -> + let cps_pc = mk_cps_pc_of_direct ~st pc in + st.new_blocks <- Addr.Map.add cps_pc b st.new_blocks; + Addr.Map.add cps_pc b blocks) start st.blocks st.blocks in - let new_blocks, free_pc = st.new_blocks in + (* If double-translating, all variables bound in the CPS version will have to be + subst with fresh ones to avoid clashing with the definitions in the original + blocks (the actual substitution is done later). *) + let new_blocks = + if function_needs_cps && double_translate () + then ( + Code.traverse + Code.{ fold = fold_children } + (fun pc () -> + let block = Addr.Map.find pc p.blocks in + Freevars.iter_block_bound_vars + (fun v -> subst_add_fresh cloned_vars v) + block) + initial_start + p.blocks + (); + subst_bound_in_blocks st.new_blocks cloned_subst) + else st.new_blocks + in let blocks = Addr.Map.fold Addr.Map.add new_blocks blocks in - { p with blocks; free_pc }) + { p with blocks; free_pc = st.free_pc }) p in + (* Also apply our substitution to the sets of trampolined calls, and cps call sites *) + trampolined_calls := Var.Set.map cloned_subst !trampolined_calls; + in_cps := Var.Set.map cloned_subst !in_cps; let p = - match Hashtbl.find_opt closure_info p.start with - | None -> p - | Some (k, _) -> - (* Call [caml_callback] to set up the execution context. *) - let new_start = p.free_pc in - let blocks = - let main = Var.fresh () in - let args = Var.fresh () in - let res = Var.fresh () in - Addr.Map.add - new_start - { params = [] - ; body = - [ Let (main, Closure ([ k ], (p.start, []))) - ; Let (args, Prim (Extern "%js_array", [])) - ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) - ] - ; branch = Return res - } - p.blocks - in - { start = new_start; blocks; free_pc = new_start + 1 } + if double_translate () + then p + else + match Hashtbl.find_opt closure_info p.start with + | None -> p + | Some (cps_params, cps_cont) -> + (* Call [caml_callback] to set up the execution context. *) + let new_start = p.free_pc in + let blocks = + let main = Var.fresh () in + let args = Var.fresh () in + let res = Var.fresh () in + Addr.Map.add + new_start + { params = [] + ; body = + [ Let (main, Closure (cps_params, cps_cont)) + ; Let (args, Prim (Extern "%js_array", [])) + ; Let (res, Prim (Extern "caml_callback", [ Pv main; Pv args ])) + ] + ; branch = Return res + } + p.blocks + in + { start = new_start; blocks; free_pc = new_start + 1 } in p, !trampolined_calls, !in_cps @@ -779,7 +986,7 @@ let wrap_call ~cps_needed p x f args accu = ] :: accu ) -let wrap_primitive ~cps_needed p x e accu = +let wrap_primitive ~cps_needed (p : program) x e accu = let f = Var.fresh () in let closure_pc = p.free_pc in ( { p with @@ -849,7 +1056,7 @@ let split_blocks ~cps_needed (p : Code.program) = let split_block pc block p = let is_split_point i r branch = match i with - | Let (x, (Apply _ | Prim (Extern ("%resume" | "%perform" | "%reperform"), _))) -> + | Let (x, e) when effect_primitive_or_application e -> ((not (empty_body r)) || match branch with @@ -943,9 +1150,36 @@ let remove_empty_blocks ~live_vars (p : Code.program) : Code.program = let f ~flow_info ~live_vars p = let t = Timer.make () in let cps_needed = Partial_cps_analysis.f p flow_info in - let p, cps_needed = rewrite_toplevel ~cps_needed p in + let p, cps_needed = + if double_translate () + then ( + let p, liftings = Lambda_lifting_simple.f ~to_lift:cps_needed p in + let cps_needed = + Var.Set.map + (fun f -> try Subst.from_map liftings f with Not_found -> f) + cps_needed + in + if debug () + then ( + debug_print "@]"; + debug_print "@[cps_needed (after lifting) = @["; + Var.Set.iter (fun v -> debug_print "%s,@ " (Var.to_string v)) cps_needed; + debug_print "@]@,@]"; + debug_print "@[After lambda lifting...@,"; + Code.Print.program (fun _ _ -> "") p; + debug_print "@]"); + p, cps_needed) + else + let p, cps_needed = rewrite_toplevel ~cps_needed p in + p, cps_needed + in let p = split_blocks ~cps_needed p in let p, trampolined_calls, in_cps = cps_transform ~live_vars ~flow_info ~cps_needed p in if Debug.find "times" () then Format.eprintf " effects: %a@." Timer.print t; Code.invariant p; + if debug () + then ( + debug_print "@[After CPS transform:@,"; + Code.Print.program (fun _ _ -> "") p; + debug_print "@]"); p, trampolined_calls, in_cps diff --git a/compiler/lib/effects.mli b/compiler/lib/effects.mli index c32df662ee..2468f4cf84 100644 --- a/compiler/lib/effects.mli +++ b/compiler/lib/effects.mli @@ -27,3 +27,14 @@ val f : -> live_vars:Deadcode.variable_uses -> Code.program -> Code.program * trampolined_calls * in_cps +(** Perform a partial CPS transform in order to translate a program that uses effect + handler primitives to a program with only function calls, preserving the semantics. + + In addition, if double translation is enabled, some functions are defined in two + versions (direct-style and CPS) and the generated program switches to CPS versions + when entering the first effect handler, and back to direct style when exiting it. In + addition to this dynamic behavior, the transform performs a static analysis to detect + which functions do not need to be CPS-transformed. As a consequence, some functions + become pairs of functions while others remain in a single version. This functions + returns the set of call sites that require trampolining, as well as the set of call + sites that require the callee to be a pair with a CPS component. *) diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 0a3f8ea295..2d1225c474 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -513,7 +513,7 @@ let f ?skip_param p = } in let s = build_subst info vars in - let p = Subst.program (Subst.from_array s) p in + let p = Subst.Excluding_Binders.program (Subst.from_array s) p in if times () then Format.eprintf " flow analysis 5: %a@." Timer.print t5; if times () then Format.eprintf " flow analysis: %a@." Timer.print t; Code.invariant p; diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 35612ae98c..3509c15e3d 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -56,6 +56,7 @@ type application_description = { arity : int ; exact : bool ; trampolined : bool + ; in_cps : bool } module Share = struct @@ -134,6 +135,7 @@ module Share = struct let get ~trampolined_calls + ~in_cps ?alias_strings ?(alias_prims = false) ?(alias_apply = true) @@ -151,8 +153,12 @@ module Share = struct | Let (_, Constant c) -> get_constant c share | Let (x, Apply { args; exact; _ }) -> let trampolined = Var.Set.mem x trampolined_calls in + let in_cps = Var.Set.mem x in_cps in if (not exact) || trampolined - then add_apply { arity = List.length args; exact; trampolined } share + then + add_apply + { arity = List.length args; exact; trampolined; in_cps } + share else share | Let (_, Special (Alias_prim name)) -> let name = Primitive.resolve name in @@ -244,15 +250,20 @@ module Share = struct try J.EVar (AppMap.find desc t.vars.applies) with Not_found -> let x = - let { arity; exact; trampolined } = desc in + let { arity; exact; trampolined; in_cps } = desc in Var.fresh_n (Printf.sprintf "caml_%scall%d" - (match exact, trampolined with - | true, false -> assert false - | true, true -> "cps_exact_" - | false, false -> "" - | false, true -> "cps_") + (match exact, trampolined, in_cps with + | true, false, false -> assert false (* inlined *) + | true, false, true -> "exact_cps_" + | true, true, false -> "exact_trampoline_" + | false, false, true -> + assert false (* CPS functions are always trampolined *) + | false, false, false -> "" + | false, true, false -> "trampoline_" + | false, true, true -> "trampoline_cps_" + | true, true, true -> "exact_trampoline_cps_") arity) in let v = J.V x in @@ -273,6 +284,7 @@ module Ctx = struct ; deadcode_sentinal : Var.t ; mutated_vars : Code.Var.Set.t Code.Addr.Map.t ; freevars : Code.Var.Set.t Code.Addr.Map.t + ; in_cps : Effects.in_cps } let initial @@ -282,6 +294,7 @@ module Ctx = struct ~deadcode_sentinal ~mutated_vars ~freevars + ~in_cps blocks live trampolined_calls @@ -298,6 +311,7 @@ module Ctx = struct ; deadcode_sentinal ; mutated_vars ; freevars + ; in_cps } end @@ -896,49 +910,72 @@ let parallel_renaming loc back_edge params args continuation queue = (****) -let apply_fun_raw ctx f params exact trampolined loc = - let n = List.length params in - let apply_directly = - (* Make sure we are performing a regular call, not a (slower) - method call *) - match f with - | J.EAccess _ | J.EDot _ -> - J.call (J.dot f (Utf8_string.of_string_exn "call")) (s_var "null" :: params) loc - | _ -> J.call f params loc - in - let apply = - (* We skip the arity check when we know that we have the right - number of parameters, since this test is expensive. *) - if exact - then apply_directly - else - let l = Utf8_string.of_string_exn "l" in +let apply_fun_raw = + let cps_field = Utf8_string.of_string_exn "cps" in + fun ctx f params exact trampolined cps loc -> + let n = List.length params in + let apply_directly f params = + (* Make sure we are performing a regular call, not a (slower) + method call *) + match f with + | J.EAccess _ | J.EDot _ -> + J.call (J.dot f (Utf8_string.of_string_exn "call")) (s_var "null" :: params) loc + | _ -> J.call f params loc + in + let apply = + (* Adapt if [f] is a (direct-style, CPS) closure pair *) + let real_closure = + match Config.effects () with + | Some Double_translation when cps -> + (* Effects enabled, CPS version, not single-version *) + J.EDot (f, J.ANormal, cps_field) + | _ -> f + in + (* We skip the arity check when we know that we have the right + number of parameters, since this test is expensive. *) + if exact + then apply_directly real_closure params + else + let l = Utf8_string.of_string_exn "l" in + J.ECond + ( J.EBin + ( J.EqEqEq + , J.ECond + ( J.EBin (J.Ge, J.dot real_closure l, int 0) + , J.dot real_closure l + , J.EBin + ( J.Eq + , J.dot real_closure l + , J.dot real_closure (Utf8_string.of_string_exn "length") ) ) + , int n ) + , apply_directly real_closure params + , J.call + (* Note: when double translation is enabled, [caml_call_gen*] functions takes a two-version function *) + (runtime_fun + ctx + (match Config.effects () with + | Some Double_translation when cps -> "caml_call_gen_cps" + | _ -> "caml_call_gen")) + [ f; J.array params ] + J.N ) + in + if trampolined + then ( + assert (Option.is_some (Config.effects ())); + (* When supporting effect, we systematically perform tailcall + optimization. To implement it, we check the stack depth and + bounce to a trampoline if needed, to avoid a stack overflow. + The trampoline then performs the call in an shorter stack. *) J.ECond - ( J.EBin - ( J.EqEqEq - , J.ECond - ( J.EBin (J.Ge, J.dot f l, int 0) - , J.dot f l - , J.EBin (J.Eq, J.dot f l, J.dot f (Utf8_string.of_string_exn "length")) - ) - , int n ) - , apply_directly - , J.call (runtime_fun ctx "caml_call_gen") [ f; J.array params ] loc ) - in - if trampolined - then ( - assert (Config.Flag.effects ()); - (* When supporting effect, we systematically perform tailcall - optimization. To implement it, we check the stack depth and - bounce to a trampoline if needed, to avoid a stack overflow. - The trampoline then performs the call in an shorter stack. *) - J.ECond - ( J.call (runtime_fun ctx "caml_stack_check_depth") [] loc - , apply - , J.call (runtime_fun ctx "caml_trampoline_return") [ f; J.array params ] loc )) - else apply - -let generate_apply_fun ctx { arity; exact; trampolined } = + ( J.call (runtime_fun ctx "caml_stack_check_depth") [] loc + , apply + , J.call + (runtime_fun ctx "caml_trampoline_return") + [ f; J.array params; (if cps then zero else one) ] + loc )) + else apply + +let generate_apply_fun ctx { arity; exact; trampolined; in_cps } = let f' = Var.fresh_n "f" in let f = J.V f' in let params = @@ -954,12 +991,12 @@ let generate_apply_fun ctx { arity; exact; trampolined } = , J.fun_ (f :: params) [ ( J.Return_statement - (Some (apply_fun_raw ctx f' params' exact trampolined J.N), J.N) + (Some (apply_fun_raw ctx f' params' exact trampolined in_cps J.N), J.N) , J.N ) ] J.N ) -let apply_fun ctx f params exact trampolined loc = +let apply_fun ctx f params exact trampolined in_cps loc = (* We always go through an intermediate function when doing CPS calls. This function first checks the stack depth to prevent a stack overflow. This makes the code smaller than inlining @@ -967,12 +1004,12 @@ let apply_fun ctx f params exact trampolined loc = since the function should get inlined by the JavaScript engines. *) if Config.Flag.inline_callgen () || (exact && not trampolined) - then apply_fun_raw ctx f params exact trampolined loc + then apply_fun_raw ctx f params exact trampolined in_cps loc else let y = Share.get_apply (generate_apply_fun ctx) - { arity = List.length params; exact; trampolined } + { arity = List.length params; exact; trampolined; in_cps } ctx.Ctx.share in J.call y (f :: params) loc @@ -1189,9 +1226,10 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t let trampolined = Var.Set.mem x ctx.Ctx.trampolined_calls in let args = remove_unused_tail_args ctx exact trampolined args in let* () = info ~need_loc:true mutator_p in + let in_cps = Var.Set.mem x ctx.Ctx.in_cps in let* args = list_map access args in let* f = access f in - return (apply_fun ctx f args exact trampolined loc, []) + return (apply_fun ctx f args exact trampolined in_cps loc, []) | Block (tag, a, array_or_not, _mut) -> let* contents = list_map @@ -1370,12 +1408,12 @@ let rec translate_expr ctx loc x e level : (_ * J.statement_list) Expr_builder.t return e | Extern "caml_alloc_dummy_function", _ -> assert false | Extern ("%resume" | "%perform" | "%reperform"), _ -> - if Config.Flag.effects () then assert false; + assert (Option.is_none (Config.effects ())); if not !(ctx.effect_warning) then ( warn "Warning: your program contains effect handlers; you should probably run \ - js_of_ocaml with option '--enable=effects'@."; + js_of_ocaml with option '--effects=cps'@."; ctx.effect_warning := true); let name = "jsoo_effect_not_supported" in let prim = Share.get_prim (runtime_fun ctx) name ctx.Ctx.share in @@ -1565,7 +1603,8 @@ and translate_instrs_rev (ctx : Ctx.t) loc expr_queue instrs acc_rev muts_map = List.fold_left pcs ~init:(ctx.blocks, Addr.Set.empty) - ~f:(fun (blocks, visited) pc -> Subst.cont' subst pc blocks visited) + ~f:(fun (blocks, visited) pc -> + Subst.Excluding_Binders.cont' subst pc blocks visited) in { ctx with blocks = p } in @@ -2111,12 +2150,13 @@ let f ~exported_runtime ~live_vars ~trampolined_calls + ~in_cps ~should_export ~warn_on_unhandled_effect ~deadcode_sentinal debug = let t' = Timer.make () in - let share = Share.get ~trampolined_calls ~alias_prims:exported_runtime p in + let share = Share.get ~trampolined_calls ~in_cps ~alias_prims:exported_runtime p in let exported_runtime = if exported_runtime then Some (Code.Var.fresh_n "runtime", ref false) else None in @@ -2130,6 +2170,7 @@ let f ~deadcode_sentinal ~mutated_vars ~freevars + ~in_cps p.blocks live_vars trampolined_calls diff --git a/compiler/lib/generate.mli b/compiler/lib/generate.mli index 453cc2f445..cf6d6983ab 100644 --- a/compiler/lib/generate.mli +++ b/compiler/lib/generate.mli @@ -23,6 +23,7 @@ val f : -> exported_runtime:bool -> live_vars:Deadcode.variable_uses -> trampolined_calls:Effects.trampolined_calls + -> in_cps:Effects.in_cps -> should_export:bool -> warn_on_unhandled_effect:bool -> deadcode_sentinal:Code.Var.t diff --git a/compiler/lib/generate_closure.ml b/compiler/lib/generate_closure.ml index a3b4c0eb72..a585ebcfa9 100644 --- a/compiler/lib/generate_closure.ml +++ b/compiler/lib/generate_closure.ml @@ -327,7 +327,7 @@ let f p : Code.program = p let f p = - assert (not (Config.Flag.effects ())); + assert (Option.is_none (Config.effects ())); let open Config.Param in match tailcall_optim () with | TcNone -> p diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index c3d0a642df..abe6154aea 100644 --- a/compiler/lib/inline.ml +++ b/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 -> not (Config.Flag.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 diff --git a/compiler/lib/js_output.ml b/compiler/lib/js_output.ml index d514e457cf..bebd7493fc 100644 --- a/compiler/lib/js_output.ml +++ b/compiler/lib/js_output.ml @@ -2099,7 +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 Config.Flag.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; diff --git a/compiler/lib/lambda_lifting.ml b/compiler/lib/lambda_lifting.ml index b14ef61dd3..e37843c4bd 100644 --- a/compiler/lib/lambda_lifting.ml +++ b/compiler/lib/lambda_lifting.ml @@ -174,7 +174,9 @@ let rec traverse var_depth (program, functions) pc depth limit = free_vars Var.Map.empty in - let program = Subst.cont (Subst.from_map s) pc' program in + let program = + Subst.Excluding_Binders.cont (Subst.from_map s) pc' program + in let f' = try Var.Map.find f s with Not_found -> Var.fork f in let s = Var.Map.bindings (Var.Map.remove f s) in let f'' = Var.fork f in diff --git a/compiler/lib/lambda_lifting_simple.ml b/compiler/lib/lambda_lifting_simple.ml new file mode 100644 index 0000000000..ee52523011 --- /dev/null +++ b/compiler/lib/lambda_lifting_simple.ml @@ -0,0 +1,360 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open! Stdlib +open Code + +let debug = Debug.find "lifting_simple" + +let baseline = 0 (* Depth to which the functions are lifted *) + +let rec compute_depth program pc = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc d -> + let block = Code.Addr.Map.find pc program.blocks in + List.fold_left block.body ~init:d ~f:(fun d i -> + match i with + | Let (_, Closure (_, (pc', _))) -> + let d' = compute_depth program pc' in + max d (d' + 1) + | _ -> d)) + pc + program.blocks + 0 + +let collect_free_vars program var_depth depth pc = + let vars = ref Var.Set.empty in + let rec traverse pc = + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc () -> + let block = Code.Addr.Map.find pc program.blocks in + Freevars.iter_block_free_vars + (fun x -> + let idx = Var.idx x in + if idx < Array.length var_depth + then ( + let d = var_depth.(idx) in + assert (d >= 0); + if d > baseline && d < depth then vars := Var.Set.add x !vars)) + block; + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Closure (_, (pc', _))) -> traverse pc' + | _ -> ())) + pc + program.blocks + () + in + traverse pc; + !vars + +let mark_bound_variables var_depth block depth = + Freevars.iter_block_bound_vars (fun x -> var_depth.(Var.idx x) <- depth) block; + List.iter block.body ~f:(fun i -> + match i with + | Let (_, Closure (params, _)) -> + List.iter params ~f:(fun x -> var_depth.(Var.idx x) <- depth + 1) + | _ -> ()) + +let starts_with_closure = function + | Let (_, Closure _) :: _ -> true + | _ :: _ | [] -> false + +(* Replace closures to lift by lifter applications; returns definitions and names of the + lifter functions (to be defined before the new body). *) +let rec rewrite_blocks + ~to_lift + ~inside_lifted + ~var_depth + ~st:(program, (functions : instr list), lifters) + ~pc + ~depth : _ * _ * Var.t Var.Map.t = + assert (depth > 0); + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc (program, functions, lifters) -> + let block = Code.Addr.Map.find pc program.blocks in + mark_bound_variables var_depth block depth; + let body, (program, functions, lifters) = + rewrite_body + ~to_lift + ~inside_lifted + ~var_depth + ~current_contiguous:[] + ~st:(program, functions, lifters) + ~depth + ~acc_instr:[] + block.body + in + ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } + , functions + , lifters )) + pc + program.blocks + (program, functions, lifters) + +and rewrite_body + ~to_lift + ~inside_lifted + ~depth + ~var_depth + ~current_contiguous + ~acc_instr + ~(st : Code.program * instr list * Var.t Var.Map.t) + body = + (* We lift possibly mutually recursive closures (that are created by contiguous + statements) together. Isolated closures are lambda-lifted normally. *) + match body with + | Let (f, (Closure (_, (pc', _)) as cl)) :: rem + when List.is_empty current_contiguous + && (inside_lifted || Var.Set.mem f to_lift) + && not (starts_with_closure rem) -> + (* We lift an isolated closure *) + if debug () + then Format.eprintf "@[lifting isolated closure %s@,@]" (Var.to_string f); + let program, functions, lifters = + rewrite_blocks + ~to_lift + ~inside_lifted:(Var.Set.mem f to_lift) + ~var_depth + ~st + ~pc:pc' + ~depth:(depth + 1) + in + let free_vars = collect_free_vars program var_depth (depth + 1) pc' in + if debug () + then ( + Format.eprintf "@[free variables:@,"; + free_vars |> Var.Set.iter (fun v -> Format.eprintf "%s,@ " (Var.to_string v)); + Format.eprintf "@]"); + let s = + Var.Set.fold (fun x m -> Var.Map.add x (Var.fork x) m) free_vars Var.Map.empty + in + let program = Subst.Excluding_Binders.cont (Subst.from_map s) pc' program in + let f' = try Var.Map.find f s with Not_found -> Var.fork f in + let s = Var.Map.bindings (Var.Map.remove f s) in + let f'' = Var.fork f in + if debug () + then + Format.eprintf + "LIFT %s (depth:%d free_vars:%d inner_depth:%d)@." + (Code.Var.to_string f'') + depth + (Var.Set.cardinal free_vars) + (compute_depth program pc'); + let pc'' = program.free_pc in + let bl = { params = []; body = [ Let (f', cl) ]; branch = Return f' } in + let program = + { program with free_pc = pc'' + 1; blocks = Addr.Map.add pc'' bl program.blocks } + in + (* Add to returned list of lifter functions definitions *) + let functions = Let (f'', Closure (List.map s ~f:snd, (pc'', []))) :: functions in + let lifters = Var.Map.add f f' lifters in + rewrite_body + ~to_lift + ~inside_lifted + ~current_contiguous:[] + ~st:(program, functions, lifters) + ~var_depth + ~acc_instr: + (* Replace closure with application of the lifter function *) + (Let (f, Apply { f = f''; args = List.map ~f:fst s; exact = true }) :: acc_instr) + ~depth + rem + | Let (cname, Closure (params, (pc', args))) :: rem -> + (* More closure definitions follow: accumulate and lift later *) + let st = + rewrite_blocks + ~to_lift + ~inside_lifted:(Var.Set.mem cname to_lift) + ~var_depth + ~st + ~pc:pc' + ~depth:(depth + 1) + in + rewrite_body + ~to_lift + ~inside_lifted + ~var_depth + ~current_contiguous:((cname, params, pc', args) :: current_contiguous) + ~st + ~acc_instr + ~depth + rem + | _ :: _ | [] -> ( + (* Process the accumulated closure definitions *) + assert ( + match current_contiguous with + | [ (f, _, _, _) ] -> not (Var.Set.mem f to_lift) + | _ -> true); + let st, acc_instr = + match current_contiguous with + | [] -> st, acc_instr + | _ :: _ + when inside_lifted + || List.exists + ~f:(fun (f, _, _, _) -> Var.Set.mem f to_lift) + current_contiguous -> + (* Lift several closures at once *) + let program, functions, lifters = st in + let free_vars = + List.fold_left + current_contiguous + ~f:(fun acc (_, _, pc, _) -> + Var.Set.union acc @@ collect_free_vars program var_depth (depth + 1) pc) + ~init:Var.Set.empty + in + let s = + Var.Set.fold + (fun x m -> Var.Map.add x (Var.fork x) m) + free_vars + Var.Map.empty + in + let program = + List.fold_left + current_contiguous + ~f:(fun program (_, _, pc, _) -> + Subst.Excluding_Binders.cont (Subst.from_map s) pc program) + ~init:program + in + let f's = + List.map current_contiguous ~f:(fun (f, _, _, _) -> + Var.(try Map.find f s with Not_found -> fork f)) + in + let s = + List.fold_left + current_contiguous + ~f:(fun s (f, _, _, _) -> Var.Map.remove f s) + ~init:s + |> Var.Map.bindings + in + let f_tuple = Var.fresh_n "recfuncs" in + (if debug () + then + Format.( + eprintf + "LIFT %a in tuple %s (depth:%d free_vars:%d)@," + (pp_print_list ~pp_sep:pp_print_space pp_print_string) + (List.map ~f:Code.Var.to_string f's) + (Code.Var.to_string f_tuple) + depth + (Var.Set.cardinal free_vars))); + let pc_tuple = program.free_pc in + let lifted_block = + let tuple = Var.fresh_n "tuple" in + { params = [] + ; body = + List.rev_map2 f's current_contiguous ~f:(fun f' (_, params, pc, args) -> + Let (f', Closure (params, (pc, args)))) + @ [ Let (tuple, Block (0, Array.of_list f's, NotArray, Immutable)) ] + ; branch = Return tuple + } + in + let program = + { program with + free_pc = pc_tuple + 1 + ; blocks = Addr.Map.add pc_tuple lifted_block program.blocks + } + in + let functions = + Let (f_tuple, Closure (List.map s ~f:snd, (pc_tuple, []))) :: functions + in + let lifters = + Var.Map.add_seq + (List.to_seq + @@ List.combine + (List.map current_contiguous ~f:(fun (f, _, _, _) -> f)) + f's) + lifters + in + let tuple = Var.fresh_n "tuple" in + let rev_decl = + List.mapi current_contiguous ~f:(fun i (f, _, _, _) -> + Let (f, Field (tuple, i, Non_float))) + in + ( (program, functions, lifters) + , rev_decl + @ Let (tuple, Apply { f = f_tuple; args = List.map ~f:fst s; exact = true }) + :: acc_instr ) + | _ :: _ -> + (* No need to lift the accumulated closures: just keep their definitions + unchanged *) + let rev_decls = + List.map current_contiguous ~f:(fun (f, params, pc, args) -> + Let (f, Closure (params, (pc, args)))) + in + st, rev_decls @ acc_instr + in + match body with + | [] -> List.rev acc_instr, st + | i :: rem -> + rewrite_body + ~to_lift + ~inside_lifted + ~var_depth + ~depth + ~current_contiguous:[] + ~st + ~acc_instr:(i :: acc_instr) + rem) + +let lift ~to_lift ~pc program : program * Var.t Var.Map.t = + let nv = Var.count () in + let var_depth = Array.make nv (-1) in + Code.preorder_traverse + { fold = Code.fold_children } + (fun pc (program, lifter_map) -> + let block = Code.Addr.Map.find pc program.blocks in + mark_bound_variables var_depth block 0; + let program, body, lifter_map' = + List.fold_right + block.body + ~init:(program, [], Var.Map.empty) + ~f:(fun i (program, rem, lifters) -> + match i with + | Let (f, Closure (_, (pc', _))) as i -> + let program, functions, lifters = + rewrite_blocks + ~to_lift + ~inside_lifted:(Var.Set.mem f to_lift) + ~var_depth + ~st:(program, [], lifters) + ~pc:pc' + ~depth:1 + in + program, List.rev_append functions (i :: rem), lifters + | i -> program, i :: rem, lifters) + in + ( { program with blocks = Addr.Map.add pc { block with body } program.blocks } + , Var.Map.union (fun _ _ -> assert false) lifter_map lifter_map' )) + pc + program.blocks + (program, Var.Map.empty) + +let f ~to_lift program = + if debug () + then ( + Format.eprintf "@[Program before lambda lifting:@,"; + Code.Print.program (fun _ _ -> "") program; + Format.eprintf "@]"); + let t = Timer.make () in + let program, liftings = lift ~to_lift ~pc:program.start program in + if Debug.find "times" () then Format.eprintf " lambda lifting: %a@." Timer.print t; + program, liftings diff --git a/compiler/lib/lambda_lifting_simple.mli b/compiler/lib/lambda_lifting_simple.mli new file mode 100644 index 0000000000..ca14ada3b3 --- /dev/null +++ b/compiler/lib/lambda_lifting_simple.mli @@ -0,0 +1,53 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Code + +val f : to_lift:Var.Set.t -> program -> program * Var.t Var.Map.t +(** Lambda-lift all functions of the program that are in [to_lift]. All + functions are lifted to toplevel. Functions that may be + mutually recursive are lifted together. Also yields a map from the original + function names to the names of their lambda-lifted counterparts. E.g. + consider: + + let y = -3 in + (* ... *) + let rec fib n = + match n with + | 0 | 1 -> 1 + | _ -> fib (n-1) + fib (n-2) + y + in + fib 42 + + After lambda-lifting of [fib], it will look like: + + let y = -3 in + (* ... *) + let fib' y = + let rec fib_l n = + match n with + | 0 | 1 -> 1 + | _ -> fib_l (n-1) + fib_l (n-2) + y + in + fib_l + in + let fib = fib' y in + fib 42 + + [fib_l] is the lifted version of [fib], [fib'] is the lifting closure. + *) diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index a3e1976dc1..1605dd8c02 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -343,7 +343,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source warn_effects := true; warn "Warning: your program contains effect handlers; you should \ - probably run js_of_ocaml with option '--enable=effects'@."); + probably run js_of_ocaml with option '--effects=cps'@."); (if mklib then let u = if linkall then { u with force_link = true } else u in diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 416376ec3e..28523910fb 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -135,7 +135,11 @@ module Check = struct let freename = StringSet.diff freename Reserved.keyword in let freename = StringSet.diff freename Reserved.provided in let freename = StringSet.remove Global_constant.global_object freename in - let freename = if has_flags then StringSet.remove "FLAG" freename else freename in + let freename = + if has_flags + then StringSet.(diff freename (of_list [ "FLAG"; "CONFIG" ])) + else freename + in if StringSet.mem Global_constant.old_global_object freename then warn @@ -185,7 +189,12 @@ module Fragment = struct ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty [ "js-string", Config.Flag.use_js_string - ; "effects", Config.Flag.effects + ; ("effects", fun () -> Option.is_some (Config.effects ())) + ; ( "doubletranslate" + , fun () -> + match Config.effects () with + | Some Double_translation -> true + | _ -> false ) ; ( "wasm" , fun () -> match Config.target () with diff --git a/compiler/lib/macro.ml b/compiler/lib/macro.ml index 69e36b6a83..4a2502d21c 100644 --- a/compiler/lib/macro.ml +++ b/compiler/lib/macro.ml @@ -23,6 +23,11 @@ type m = | Replace | Count of int ref +let string_of_effects_backend = function + | None -> "none" + | Some Config.Cps -> "cps" + | Some Config.Double_translation -> "double-translation" + class macro_mapper ~flags = object (m) inherit Js_traverse.map as super @@ -40,6 +45,16 @@ class macro_mapper ~flags = | Count count -> incr count; super#expression x) + | "CONFIG", [ J.Arg (J.EStr (Utf8 "effects")) ] -> ( + match flags with + | Replace -> + let s = string_of_effects_backend (Config.effects ()) in + J.EStr (Utf8_string.of_string_exn s) + | Count count -> + incr count; + super#expression x) + | "CONFIG", [ J.Arg (J.EStr (Utf8 s)) ] -> + failwith ("unsupported CONFIG parameter " ^ s) | "BLOCK", J.Arg (J.ENum tag) :: (_ :: _ as args) when List.for_all args ~f:(function | J.Arg _ -> true diff --git a/compiler/lib/phisimpl.ml b/compiler/lib/phisimpl.ml index 68184e9384..c779215a08 100644 --- a/compiler/lib/phisimpl.ml +++ b/compiler/lib/phisimpl.ml @@ -158,6 +158,6 @@ let f p = if times () then Format.eprintf " phi-simpl. 2: %a@." Timer.print t'; Array.iteri subst ~f:(fun idx y -> if Var.idx y = idx then () else Code.Var.propagate_name (Var.of_idx idx) y); - let p = Subst.program (Subst.from_array subst) p in + let p = Subst.Excluding_Binders.program (Subst.from_array subst) p in if times () then Format.eprintf " phi-simpl.: %a@." Timer.print t; p diff --git a/compiler/lib/subst.ml b/compiler/lib/subst.ml index 11382bc90a..6f82da73e4 100644 --- a/compiler/lib/subst.ml +++ b/compiler/lib/subst.ml @@ -21,81 +21,83 @@ open! Stdlib open Code -let subst_cont s (pc, arg) = pc, List.map arg ~f:(fun x -> s x) - -let expr s e = - match e with - | Constant _ -> e - | Apply { f; args; exact } -> - Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } - | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) - | Field (x, n, typ) -> Field (s x, n, typ) - | Closure (l, pc) -> Closure (l, subst_cont s pc) - | Special _ -> e - | Prim (p, l) -> - Prim - ( p - , List.map l ~f:(fun x -> - match x with - | Pv x -> Pv (s x) - | Pc _ -> x) ) - -let instr s i = - match i with - | Let (x, e) -> Let (x, expr s e) - | Assign (x, y) -> Assign (x, s y) (* x is handled like a parameter *) - | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) - | Offset_ref (x, n) -> Offset_ref (s x, n) - | Array_set (x, y, z) -> Array_set (s x, s y, s z) - | Event _ -> i - -let instrs s l = List.map l ~f:(fun i -> instr s i) - -let last s l = - match l with - | Stop -> l - | Branch cont -> Branch (subst_cont s cont) - | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2) - | Return x -> Return (s x) - | Raise (x, k) -> Raise (s x, k) - | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) - | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont)) - | Poptrap cont -> Poptrap (subst_cont s cont) - -let block s block = - { params = block.params; body = instrs s block.body; branch = last s block.branch } - -let program s p = - let blocks = Addr.Map.map (fun b -> block s b) p.blocks in - { p with blocks } - -let rec cont' s pc blocks visited = - if Addr.Set.mem pc visited - then blocks, visited - else - let visited = Addr.Set.add pc visited in - let b = Addr.Map.find pc blocks in - let b = block s b in - let blocks = Addr.Map.add pc b blocks in - let blocks, visited = - List.fold_left b.body ~init:(blocks, visited) ~f:(fun (blocks, visited) instr -> - match instr with - | Let (_, Closure (_, (pc, _))) -> cont' s pc blocks visited - | _ -> blocks, visited) - in - Code.fold_children - blocks - pc - (fun pc (blocks, visited) -> cont' s pc blocks visited) - (blocks, visited) - -let cont s addr p = - let blocks, _ = cont' s addr p.blocks Addr.Set.empty in - { p with blocks } +let subst_cont s (pc, arg) = pc, List.map arg ~f:s + +module Excluding_Binders = struct + let expr s e = + match e with + | Constant _ -> e + | Apply { f; args; exact } -> + Apply { f = s f; args = List.map args ~f:(fun x -> s x); exact } + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:(fun x -> s x), k, mut) + | Field (x, n, typ) -> Field (s x, n, typ) + | Closure (l, pc) -> Closure (l, subst_cont s pc) + | Special _ -> e + | Prim (p, l) -> + Prim + ( p + , List.map l ~f:(fun x -> + match x with + | Pv x -> Pv (s x) + | Pc _ -> x) ) + + let instr s i = + match i with + | Let (x, e) -> Let (x, expr s e) + | Assign (x, y) -> Assign (x, s y) (* x is handled like a parameter *) + | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + | Event _ -> i + + let instrs s l = List.map l ~f:(fun i -> instr s i) + + let last s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont s cont) + | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, x, subst_cont s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) + | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont s cont)) + | Poptrap cont -> Poptrap (subst_cont s cont) + + let block s block = + { params = block.params; body = instrs s block.body; branch = last s block.branch } + + let program s p = + let blocks = Addr.Map.map (fun b -> block s b) p.blocks in + { p with blocks } + + let rec cont' s pc blocks visited = + if Addr.Set.mem pc visited + then blocks, visited + else + let visited = Addr.Set.add pc visited in + let b = Addr.Map.find pc blocks in + let b = block s b in + let blocks = Addr.Map.add pc b blocks in + let blocks, visited = + List.fold_left b.body ~init:(blocks, visited) ~f:(fun (blocks, visited) instr -> + match instr with + | Let (_, Closure (_, (pc, _))) -> cont' s pc blocks visited + | _ -> blocks, visited) + in + Code.fold_children + blocks + pc + (fun pc (blocks, visited) -> cont' s pc blocks visited) + (blocks, visited) + + let cont s addr p = + let blocks, _ = cont' s addr p.blocks Addr.Set.empty in + { p with blocks } +end (****) -let from_array s x = s.(Var.idx x) +let from_array s x = if Var.idx x < Array.length s then s.(Var.idx x) else x (****) @@ -106,3 +108,73 @@ let rec build_mapping params args = | _ -> assert false let from_map m x = try Var.Map.find x m with Not_found -> x + +(****) + +module Including_Binders = struct + let expr s e = + match e with + | Constant _ -> e + | Apply { f; args; exact } -> Apply { f = s f; args = List.map args ~f:s; exact } + | Block (n, a, k, mut) -> Block (n, Array.map a ~f:s, k, mut) + | Field (x, n, typ) -> Field (s x, n, typ) + | Closure (l, pc) -> Closure (List.map l ~f:s, subst_cont s pc) + | Special _ -> e + | Prim (p, l) -> + Prim + ( p + , List.map l ~f:(fun x -> + match x with + | Pv x -> Pv (s x) + | Pc _ -> x) ) + + let instr s i = + match i with + | Let (x, e) -> Let (s x, expr s e) + | Assign (x, y) -> Assign (s x, s y) + | Set_field (x, n, typ, y) -> Set_field (s x, n, typ, s y) + | Offset_ref (x, n) -> Offset_ref (s x, n) + | Array_set (x, y, z) -> Array_set (s x, s y, s z) + | Event _ -> i + + let instrs s l = List.map l ~f:(fun i -> instr s i) + + let last s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont s cont) + | Pushtrap (cont1, x, cont2) -> Pushtrap (subst_cont s cont1, s x, subst_cont s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont s cont1, subst_cont s cont2) + | Switch (x, conts) -> Switch (s x, Array.map conts ~f:(fun cont -> subst_cont s cont)) + | Poptrap cont -> Poptrap (subst_cont s cont) + + let block s block = + { params = List.map block.params ~f:s + ; body = instrs s block.body + ; branch = last s block.branch + } + + module And_Continuations = struct + let subst_cont m s (pc, arg) = Addr.Map.find pc m, List.map arg ~f:s + + let last m s l = + match l with + | Stop -> l + | Branch cont -> Branch (subst_cont m s cont) + | Pushtrap (cont1, x, cont2) -> + Pushtrap (subst_cont m s cont1, s x, subst_cont m s cont2) + | Return x -> Return (s x) + | Raise (x, k) -> Raise (s x, k) + | Cond (x, cont1, cont2) -> Cond (s x, subst_cont m s cont1, subst_cont m s cont2) + | Switch (x, a1) -> Switch (s x, Array.map a1 ~f:(fun cont -> subst_cont m s cont)) + | Poptrap cont -> Poptrap (subst_cont m s cont) + + let block m s block = + { params = List.map ~f:s block.params + ; body = instrs s block.body + ; branch = last m s block.branch + } + end +end diff --git a/compiler/lib/subst.mli b/compiler/lib/subst.mli index 9ecd43e6a9..a3920f0650 100644 --- a/compiler/lib/subst.mli +++ b/compiler/lib/subst.mli @@ -20,29 +20,52 @@ open Code -val program : (Var.t -> Var.t) -> program -> program +(** The operations of this module substitute variable names that appear in + expressions, except for binders, i.e., names on the right-hand side of a + {!constructor:Code.Let}. *) +module Excluding_Binders : sig + val program : (Var.t -> Var.t) -> program -> program -val expr : (Var.t -> Var.t) -> expr -> expr + val expr : (Var.t -> Var.t) -> expr -> expr -val instr : (Var.t -> Var.t) -> instr -> instr + val instr : (Var.t -> Var.t) -> instr -> instr -val instrs : (Var.t -> Var.t) -> instr list -> instr list + val instrs : (Var.t -> Var.t) -> instr list -> instr list -val block : (Var.t -> Var.t) -> block -> block + val block : (Var.t -> Var.t) -> block -> block -val last : (Var.t -> Var.t) -> last -> last + val last : (Var.t -> Var.t) -> last -> last -val cont : (Var.t -> Var.t) -> int -> program -> program + val cont : (Var.t -> Var.t) -> int -> program -> program -val cont' : - (Var.t -> Var.t) - -> int - -> block Addr.Map.t - -> Addr.Set.t - -> block Addr.Map.t * Addr.Set.t + val cont' : + (Var.t -> Var.t) + -> int + -> block Addr.Map.t + -> Addr.Set.t + -> block Addr.Map.t * Addr.Set.t +end val from_array : Var.t array -> Var.t -> Var.t val build_mapping : Var.t list -> Var.t list -> Var.t Var.Map.t val from_map : Var.t Var.Map.t -> Var.t -> Var.t + +(** The operations of this module also substitute the variables names that + appear on the left-hand-side of a {!constructor:Code.Let}, or as block + parameters, or as closure parameters, or are bound by an exception handler. + *) +module Including_Binders : sig + val instr : (Var.t -> Var.t) -> instr -> instr + + val instrs : (Var.t -> Var.t) -> instr list -> instr list + + val block : (Var.t -> Var.t) -> block -> block + + module And_Continuations : sig + val block : Addr.t Addr.Map.t -> (Var.t -> Var.t) -> block -> block + (** Same as [Including_Binders.block], but also substitutes continuation + addresses. *) + end +end diff --git a/compiler/lib/unit_info.ml b/compiler/lib/unit_info.ml index a3d3112917..69839b9d5e 100644 --- a/compiler/lib/unit_info.ml +++ b/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 = - (not (Config.Flag.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) diff --git a/compiler/tests-check-prim/main.4.14.output b/compiler/tests-check-prim/main.4.14.output index 139954b7ee..79dccf4286 100644 --- a/compiler/tests-check-prim/main.4.14.output +++ b/compiler/tests-check-prim/main.4.14.output @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/main.5.2.output b/compiler/tests-check-prim/main.5.2.output index 3c5ba47eab..c35328f37b 100644 --- a/compiler/tests-check-prim/main.5.2.output +++ b/compiler/tests-check-prim/main.5.2.output @@ -3,6 +3,7 @@ Missing From main.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer diff --git a/compiler/tests-check-prim/unix-Unix.4.14.output b/compiler/tests-check-prim/unix-Unix.4.14.output index 21af5e2974..072c9a3757 100644 --- a/compiler/tests-check-prim/unix-Unix.4.14.output +++ b/compiler/tests-check-prim/unix-Unix.4.14.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/unix-Unix.5.2.output b/compiler/tests-check-prim/unix-Unix.5.2.output index 630bcaf2fd..28d8771404 100644 --- a/compiler/tests-check-prim/unix-Unix.5.2.output +++ b/compiler/tests-check-prim/unix-Unix.5.2.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer diff --git a/compiler/tests-check-prim/unix-Win32.4.14.output b/compiler/tests-check-prim/unix-Win32.4.14.output index f49ad3383a..507d923f0c 100644 --- a/compiler/tests-check-prim/unix-Win32.4.14.output +++ b/compiler/tests-check-prim/unix-Win32.4.14.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_int64_add_native caml_int64_and_native caml_int64_div_native diff --git a/compiler/tests-check-prim/unix-Win32.5.2.output b/compiler/tests-check-prim/unix-Win32.5.2.output index f2c49c3ded..e935be7e8e 100644 --- a/compiler/tests-check-prim/unix-Win32.5.2.output +++ b/compiler/tests-check-prim/unix-Win32.5.2.output @@ -3,6 +3,7 @@ Missing From unix.bc: caml_alloc_dummy_function +caml_assume_no_perform caml_continuation_use caml_drop_continuation caml_int_as_pointer diff --git a/compiler/tests-compiler/direct_calls.ml b/compiler/tests-compiler/direct_calls.ml index e458e83918..8de15dd959 100644 --- a/compiler/tests-compiler/direct_calls.ml +++ b/compiler/tests-compiler/direct_calls.ml @@ -18,7 +18,7 @@ open Util -let%expect_test "direct calls without --enable effects" = +let%expect_test "direct calls without --effects=cps" = let code = compile_and_parse {| @@ -99,10 +99,10 @@ let%expect_test "direct calls without --enable effects" = } //end |}] -let%expect_test "direct calls with --enable effects" = +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 () = @@ -158,40 +158,45 @@ let%expect_test "direct calls with --enable effects" = var raise = caml_pop_trap(), e$0 = caml_maybe_attach_backtrace(e, 0); return raise(e$0); }); - return caml_cps_exact_call2 - (g, x, function(_f_){caml_pop_trap(); return cont();}); + return caml_exact_trampoline_cps_call + (g, x, function(_t_){caml_pop_trap(); return cont();}); } - return caml_cps_exact_call3 + return caml_exact_trampoline_cps_call$0 (f, function(x, cont){return cont();}, 7, - function(_d_){ - return caml_cps_exact_call3 + function(_r_){ + return caml_exact_trampoline_cps_call$0 (f, function(x, cont){ - return caml_cps_call3(Stdlib[28], x, cst_a$0, cont); + return caml_trampoline_cps_call3 + (Stdlib[28], x, cst_a$0, cont); }, cst_a, - function(_e_){return cont(0);}); + function(_s_){return cont(0);}); }); } //end function test3(x, cont){ function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} - var M1 = F(), M2 = F(), _c_ = M2[1].call(null, 2); - return cont([0, M1[1].call(null, 1), _c_]); + var M1 = F(), M2 = F(), _q_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _q_]); } //end function test4(x, cont){ function F(symbol){ - function f(x, cont){return caml_cps_call3(Stdlib_Printf[2], _a_, x, cont);} + function f(x, cont){ + return caml_trampoline_cps_call3(Stdlib_Printf[2], _o_, x, cont); + } return [0, f]; } var M1 = F(), M2 = F(); - return caml_cps_exact_call2 + return caml_exact_trampoline_cps_call (M1[1], 1, - function(_b_){return caml_cps_exact_call2(M2[1], 2, cont);}); + function(_p_){ + return caml_exact_trampoline_cps_call(M2[1], 2, cont); + }); } //end |}] diff --git a/compiler/tests-compiler/double-translation/direct_calls.ml b/compiler/tests-compiler/double-translation/direct_calls.ml new file mode 100644 index 0000000000..c1e03a8582 --- /dev/null +++ b/compiler/tests-compiler/double-translation/direct_calls.ml @@ -0,0 +1,279 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "direct calls with --effects=double-translation" = + let code = + compile_and_parse + ~effects:Js_of_ocaml_compiler.Config.Double_translation + {| + (* Arity of the argument of a function / direct call *) + let test1 () = + let f g x = try g x with e -> raise e in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x *. 2.) 4.) + + (* Arity of the argument of a function / CPS call *) + let test2 () = + let f g x = try g x with e -> raise e in + ignore (f (fun x -> x + 1) 7); + ignore (f (fun x -> x ^ "a") "a") + + (* Arity of functions in a functor / direct call *) + let test3 x = + let module F(_ : sig end) = struct let f x = x + 1 end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + (M1.f 1, M2.f 2) + + (* Arity of functions in a functor / CPS call *) + let test4 x = + let module F(_ : sig end) = + struct let f x = Printf.printf "%d" x end in + let module M1 = F (struct end) in + let module M2 = F (struct end) in + M1.f 1; M2.f 2 + + (* Result of double-translating two mutually recursive functions *) + let test5 () = + let g x = + let rec f y = if y = 0 then 1 else x + h (y - 1) + and h z = if z = 0 then 1 else x + f (z - 1) + in + print_int (f 12 + h 100) + in + ignore (g 42); + ignore (g (-5)); +|} + in + print_program code; + [%expect + {| + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + caml_cps_closure = runtime.caml_cps_closure, + caml_maybe_attach_backtrace = runtime.caml_maybe_attach_backtrace, + caml_pop_trap = runtime.caml_pop_trap, + caml_string_of_jsbytes = runtime.caml_string_of_jsbytes, + caml_wrap_exception = runtime.caml_wrap_exception; + function caml_call1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) === 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_call2(f, a0, a1){ + return (f.l >= 0 ? f.l : f.l = f.length) === 2 + ? f(a0, a1) + : runtime.caml_call_gen(f, [a0, a1]); + } + function caml_trampoline_cps_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? (f.cps.l + >= 0 + ? f.cps.l + : f.cps.l = f.cps.length) + === 2 + ? f.cps.call(null, a0, a1) + : runtime.caml_call_gen_cps(f, [a0, a1]) + : runtime.caml_trampoline_return(f, [a0, a1], 0); + } + function caml_exact_trampoline_cps_call(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? f.cps.call(null, a0, a1) + : runtime.caml_trampoline_return(f, [a0, a1], 0); + } + function caml_trampoline_cps_call3(f, a0, a1, a2){ + return runtime.caml_stack_check_depth() + ? (f.cps.l + >= 0 + ? f.cps.l + : f.cps.l = f.cps.length) + === 3 + ? f.cps.call(null, a0, a1, a2) + : runtime.caml_call_gen_cps(f, [a0, a1, a2]) + : runtime.caml_trampoline_return(f, [a0, a1, a2], 0); + } + function caml_exact_trampoline_cps_call$0(f, a0, a1, a2){ + return runtime.caml_stack_check_depth() + ? f.cps.call(null, a0, a1, a2) + : runtime.caml_trampoline_return(f, [a0, a1, a2], 0); + } + var + dummy = 0, + global_data = runtime.caml_get_global_data(), + _D_ = [0, [4, 0, 0, 0, 0], caml_string_of_jsbytes("%d")], + cst_a$0 = caml_string_of_jsbytes("a"), + cst_a = caml_string_of_jsbytes("a"), + Stdlib = global_data.Stdlib, + Stdlib_Printf = global_data.Stdlib__Printf; + function f$1(){ + function f(g, x){ + try{caml_call1(g, dummy); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + return f; + } + function _d_(){return function(x){};} + function _f_(){return function(x){};} + function test1$0(param){var f = f$1(); f(_d_()); f(_f_()); return 0;} + function test1$1(param, cont){ + var f = f$1(); + f(_d_()); + f(_f_()); + return cont(0); + } + var test1 = caml_cps_closure(test1$0, test1$1); + function f$0(){ + function f$0(g, x){ + try{caml_call1(g, x); return;} + catch(e$0){ + var e = caml_wrap_exception(e$0); + throw caml_maybe_attach_backtrace(e, 0); + } + } + function f$1(g, x, cont){ + runtime.caml_push_trap + (function(e$0){ + var raise = caml_pop_trap(), e = caml_maybe_attach_backtrace(e$0, 0); + return raise(e); + }); + return caml_exact_trampoline_cps_call + (g, x, function(_P_){caml_pop_trap(); return cont();}); + } + var f = caml_cps_closure(f$0, f$1); + return f; + } + function _k_(){ + return caml_cps_closure(function(x){}, function(x, cont){return cont();}); + } + function _m_(){ + return caml_cps_closure + (function(x){return caml_call2(Stdlib[28], x, cst_a$0);}, + function(x, cont){ + return caml_trampoline_cps_call3(Stdlib[28], x, cst_a$0, cont); + }); + } + function test2$0(param){ + var f = f$0(); + f(_k_(), 7); + f(_m_(), cst_a); + return 0; + } + function test2$1(param, cont){ + var f = f$0(); + return caml_exact_trampoline_cps_call$0 + (f, + _k_(), + 7, + function(_N_){ + return caml_exact_trampoline_cps_call$0 + (f, _m_(), cst_a, function(_O_){return cont(0);}); + }); + } + var test2 = caml_cps_closure(test2$0, test2$1); + function F$0(){ + function F(symbol){function f(x){return x + 1 | 0;} return [0, f];} + return F; + } + function test3$0(x){ + var F = F$0(), M1 = F(), M2 = F(), _M_ = caml_call1(M2[1], 2); + return [0, caml_call1(M1[1], 1), _M_]; + } + function test3$1(x, cont){ + var F = F$0(), M1 = F(), M2 = F(), _L_ = M2[1].call(null, 2); + return cont([0, M1[1].call(null, 1), _L_]); + } + var test3 = caml_cps_closure(test3$0, test3$1); + function f(){ + function f$0(x){return caml_call2(Stdlib_Printf[2], _D_, x);} + function f$1(x, cont){ + return caml_trampoline_cps_call3(Stdlib_Printf[2], _D_, x, cont); + } + var f = caml_cps_closure(f$0, f$1); + return f; + } + function F(){function F(symbol){var f$0 = f(); return [0, f$0];} return F;} + function test4$0(x){ + var F$0 = F(), M1 = F$0(), M2 = F$0(); + caml_call1(M1[1], 1); + return caml_call1(M2[1], 2); + } + function test4$1(x, cont){ + var F$0 = F(), M1 = F$0(), M2 = F$0(); + return caml_exact_trampoline_cps_call + (M1[1], + 1, + function(_K_){ + return caml_exact_trampoline_cps_call(M2[1], 2, cont); + }); + } + var test4 = caml_cps_closure(test4$0, test4$1); + function recfuncs(x){ + function f(y){return 0 === y ? 1 : x + h(y - 1 | 0) | 0;} + function h(z){return 0 === z ? 1 : x + f(z - 1 | 0) | 0;} + var tuple = [0, h, f]; + return tuple; + } + function g(){ + function g$0(x){ + var + tuple = recfuncs(x), + f = tuple[2], + h = tuple[1], + _I_ = h(100), + _J_ = f(12) + _I_ | 0; + return caml_call1(Stdlib[44], _J_); + } + function g$1(x, cont){ + var + tuple = recfuncs(x), + f = tuple[2], + h = tuple[1], + _G_ = h(100), + _H_ = f(12) + _G_ | 0; + return caml_trampoline_cps_call2(Stdlib[44], _H_, cont); + } + var g = caml_cps_closure(g$0, g$1); + return g; + } + function test5$0(param){var g$0 = g(); g$0(42); g$0(- 5); return 0;} + function test5$1(param, cont){ + var g$0 = g(); + return caml_exact_trampoline_cps_call + (g$0, + 42, + function(_E_){ + return caml_exact_trampoline_cps_call + (g$0, - 5, function(_F_){return cont(0);}); + }); + } + var + test5 = caml_cps_closure(test5$0, test5$1), + Test = [0, test1, test2, test3, test4, test5]; + runtime.caml_register_global(7, Test, "Test"); + return; + } + (globalThis)); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/dune b/compiler/tests-compiler/double-translation/dune new file mode 100644 index 0000000000..063207b8a9 --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune @@ -0,0 +1,14 @@ +(include dune.inc) + +(rule + (deps + (glob_files *.ml)) + (action + (with-stdout-to + dune.inc.gen + (run ../gen-rules/gen.exe jsoo_compiler_test)))) + +(rule + (alias runtest) + (action + (diff dune.inc dune.inc.gen))) diff --git a/compiler/tests-compiler/double-translation/dune.inc b/compiler/tests-compiler/double-translation/dune.inc new file mode 100644 index 0000000000..1cecd7aa8b --- /dev/null +++ b/compiler/tests-compiler/double-translation/dune.inc @@ -0,0 +1,60 @@ + +(library + ;; compiler/tests-compiler/double-translation/direct_calls.ml + (name direct_calls_47) + (enabled_if true) + (modules direct_calls) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_continuations.ml + (name effects_continuations_47) + (enabled_if true) + (modules effects_continuations) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_exceptions.ml + (name effects_exceptions_47) + (enabled_if true) + (modules effects_exceptions) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + +(library + ;; compiler/tests-compiler/double-translation/effects_toplevel.ml + (name effects_toplevel_47) + (enabled_if true) + (modules effects_toplevel) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) diff --git a/compiler/tests-compiler/double-translation/effects_continuations.ml b/compiler/tests-compiler/double-translation/effects_continuations.ml new file mode 100644 index 0000000000..8c0a12959d --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_continuations.ml @@ -0,0 +1,297 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:Js_of_ocaml_compiler.Config.Double_translation + {| + let list_rev = List.rev + (* Avoid to expose the offset of stdlib modules *) + let () = ignore (list_rev []) + + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + (* Conditional whose result is used *) + let cond1 b = + let ic = if b then open_in "toto" else open_in "titi" in + (ic , 7) + + (* Conditional whose result is not used *) + let cond2 b = + if b then Printf.eprintf "toto" else Printf.eprintf "toto"; + 7 + + (* A dummy argument is used to call the continuation in the + [then] clause *) + let cond3 b = + let x= ref 0 in if b then x := 1 else Printf.eprintf "toto"; + !x + + (* Two continuation functions are created. One to bind [ic] before + entering the loop, and one for the loop. We use a dummy argument + to go back to the begining of the loop if [b] is false *) + let loop1 b = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + while true do + let line = input_line ic in + all := line :: !all; + if b then prerr_endline line + done + + (* There is a single continuation for the loop since the result of + [Printf.eprintf] is ignored. *) + let loop2 () = + let all = ref [] in + let ic = open_in "/static/examples.ml" in + Printf.eprintf "titi"; + while true do + let line = input_line ic in + all := line :: !all; + prerr_endline line + done + + let loop3 () = + let l = list_rev [1;2;3] in + let rec f x = + match x with + | [] -> l + | _ :: r -> f r + in + f l + |} + in + print_double_fun_decl code "exceptions"; + print_double_fun_decl code "cond1"; + print_double_fun_decl code "cond2"; + print_double_fun_decl code "cond3"; + print_double_fun_decl code "loop1"; + print_double_fun_decl code "loop2"; + print_double_fun_decl code "loop3"; + [%expect + {| + function exceptions$0(s){ + try{var _K_ = caml_int_of_string(s), n = _K_;} + catch(_N_){ + var _F_ = caml_wrap_exception(_N_); + if(_F_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_F_, 0); + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _J_ = 7, m = _J_; + } + catch(_M_){ + var _G_ = caml_wrap_exception(_M_); + if(_G_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_G_, 0); + var m = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _I_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]]; + return _I_; + } + catch(_L_){ + var _H_ = caml_wrap_exception(_L_); + if(_H_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_H_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _z_ = caml_int_of_string(s), n = _z_;} + catch(_E_){ + var _A_ = caml_wrap_exception(_E_); + if(_A_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_A_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _x_ = 7, m = _x_; + } + catch(_D_){ + var _y_ = caml_wrap_exception(_D_); + if(_y_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_y_, 0)); + } + var m = 0; + } + runtime.caml_push_trap + (function(_C_){ + if(_C_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_C_, 0)); + }); + if(! caml_string_equal(s, cst)) + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_toto, + function(_B_){caml_pop_trap(); return cont([0, [0, _B_, n, m]]);}); + var _w_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_w_, 1)); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end + function cond1$0(b){ + var + ic = + b ? caml_call1(Stdlib[79], cst_toto$0) : caml_call1(Stdlib[79], cst_titi); + return [0, ic, 7]; + } + //end + function cond1$1(b, cont){ + function _v_(ic){return cont([0, ic, 7]);} + return b + ? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_trampoline_cps_call2(Stdlib[79], cst_titi, _v_); + } + //end + var cond1 = caml_cps_closure(cond1$0, cond1$1); + //end + function cond2$0(b){ + if(b) + caml_call1(Stdlib_Printf[3], _h_); + else + caml_call1(Stdlib_Printf[3], _i_); + return 7; + } + //end + function cond2$1(b, cont){ + function _t_(_u_){return cont(7);} + return b + ? caml_trampoline_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _i_, _t_); + } + //end + var cond2 = caml_cps_closure(cond2$0, cond2$1); + //end + function cond3$0(b){ + var x = [0, 0]; + if(b) x[1] = 1; else caml_call1(Stdlib_Printf[3], _j_); + return x[1]; + } + //end + function cond3$1(b, cont){ + var x = [0, 0]; + function _r_(_s_){return cont(x[1]);} + return b + ? (x[1] = 1, _r_(0)) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _j_, _r_); + } + //end + var cond3 = caml_cps_closure(cond3$0, cond3$1); + //end + function loop1$0(b){ + var ic = caml_call1(Stdlib[79], cst_static_examples_ml); + for(;;){ + var line = caml_call1(Stdlib[83], ic); + if(b) caml_call1(Stdlib[53], line); + } + } + //end + function loop1$1(b, cont){ + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_static_examples_ml, + function(ic){ + function _p_(_q_){ + return caml_trampoline_cps_call2 + (Stdlib[83], + ic, + function(line){ + return b + ? caml_trampoline_cps_call2(Stdlib[53], line, _p_) + : caml_exact_trampoline_call1(_p_, 0); + }); + } + return _p_(0); + }); + } + //end + var loop1 = caml_cps_closure(loop1$0, loop1$1); + //end + function loop2$0(param){ + var ic = caml_call1(Stdlib[79], cst_static_examples_ml$0); + caml_call1(Stdlib_Printf[3], _k_); + for(;;){var line = caml_call1(Stdlib[83], ic); caml_call1(Stdlib[53], line);} + } + //end + function loop2$1(param, cont){ + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_static_examples_ml$0, + function(ic){ + function _n_(_o_){ + return caml_trampoline_cps_call2 + (Stdlib[83], + ic, + function(line){ + return caml_trampoline_cps_call2(Stdlib[53], line, _n_); + }); + } + return caml_trampoline_cps_call2(Stdlib_Printf[3], _k_, _n_); + }); + } + //end + var loop2 = caml_cps_closure(loop2$0, loop2$1); + //end + function loop3$0(param){ + var l = caml_call1(list_rev, _l_), x = l; + for(;;){if(! x) return l; var r = x[2]; x = r;} + } + //end + function loop3$1(param, cont){ + return caml_trampoline_cps_call2 + (list_rev, + _l_, + function(l){ + function _m_(x){ + if(! x) return cont(l); + var r = x[2]; + return caml_exact_trampoline_call1(_m_, r); + } + return _m_(l); + }); + } + //end + var loop3 = caml_cps_closure(loop3$0, loop3$1); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/effects_exceptions.ml b/compiler/tests-compiler/double-translation/effects_exceptions.ml new file mode 100644 index 0000000000..cc2b1038be --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_exceptions.ml @@ -0,0 +1,197 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~effects:Js_of_ocaml_compiler.Config.Double_translation + {| + let exceptions s = + (* Compiled using 'try ... catch', + and 'throw' within the try block *) + let n = try int_of_string s with Failure _ -> 0 in + let m = + try if s = "" then raise Not_found else 7 with Not_found -> 0 in + (* Uses caml_{push,pop}_trap. *) + try + if s = "" then raise Not_found; + Some (open_in "toto", n, m) + with Not_found -> + None + + let handler_is_loop f g l = + try f () + with exn -> + let rec loop l = + match g l with + | `Fallback l' -> loop l' + | `Raise exn -> raise exn + in + loop l + + let handler_is_merge_node g = + let s = try g () with _ -> "" in + s ^ "aaa" + |} + in + print_double_fun_decl code "exceptions"; + [%expect + {| + function exceptions$0(s){ + try{var _B_ = caml_int_of_string(s), n = _B_;} + catch(_E_){ + var _w_ = caml_wrap_exception(_E_); + if(_w_[1] !== Stdlib[7]) throw caml_maybe_attach_backtrace(_w_, 0); + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _A_ = 7, m = _A_; + } + catch(_D_){ + var _x_ = caml_wrap_exception(_D_); + if(_x_ !== Stdlib[8]) throw caml_maybe_attach_backtrace(_x_, 0); + var m = 0; + } + try{ + if(caml_string_equal(s, cst)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _z_ = [0, [0, caml_call1(Stdlib[79], cst_toto), n, m]]; + return _z_; + } + catch(_C_){ + var _y_ = caml_wrap_exception(_C_); + if(_y_ === Stdlib[8]) return 0; + throw caml_maybe_attach_backtrace(_y_, 0); + } + } + //end + function exceptions$1(s, cont){ + try{var _q_ = caml_int_of_string(s), n = _q_;} + catch(_v_){ + var _r_ = caml_wrap_exception(_v_); + if(_r_[1] !== Stdlib[7]){ + var raise$1 = caml_pop_trap(); + return raise$1(caml_maybe_attach_backtrace(_r_, 0)); + } + var n = 0; + } + try{ + if(caml_string_equal(s, cst$0)) + throw caml_maybe_attach_backtrace(Stdlib[8], 1); + var _o_ = 7, m = _o_; + } + catch(_u_){ + var _p_ = caml_wrap_exception(_u_); + if(_p_ !== Stdlib[8]){ + var raise$0 = caml_pop_trap(); + return raise$0(caml_maybe_attach_backtrace(_p_, 0)); + } + var m = 0; + } + caml_push_trap + (function(_t_){ + if(_t_ === Stdlib[8]) return cont(0); + var raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_t_, 0)); + }); + if(! caml_string_equal(s, cst)) + return caml_trampoline_cps_call2 + (Stdlib[79], + cst_toto, + function(_s_){caml_pop_trap(); return cont([0, [0, _s_, n, m]]);}); + var _n_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_n_, 1)); + } + //end + var exceptions = caml_cps_closure(exceptions$0, exceptions$1); + //end + |}]; + print_double_fun_decl code "handler_is_loop"; + [%expect + {| + function handler_is_loop$0(f, g, l){ + try{var _l_ = caml_call1(f, 0); return _l_;} + catch(_m_){ + var l$0 = l; + for(;;){ + var match = caml_call1(g, l$0); + if(72330306 > match[1]){ + var exn = match[2]; + throw caml_maybe_attach_backtrace(exn, 1); + } + var l$1 = match[2]; + l$0 = l$1; + } + } + } + //end + function handler_is_loop$1(f, g, l, cont){ + caml_push_trap + (function(_k_){ + function _j_(l){ + return caml_trampoline_cps_call2 + (g, + l, + function(match){ + if(72330306 <= match[1]){ + var l = match[2]; + return caml_exact_trampoline_call1(_j_, l); + } + var + exn$0 = match[2], + raise = caml_pop_trap(), + exn = caml_maybe_attach_backtrace(exn$0, 1); + return raise(exn); + }); + } + return _j_(l); + }); + return caml_trampoline_cps_call2 + (f, 0, function(_i_){caml_pop_trap(); return cont(_i_);}); + } + //end + var handler_is_loop = caml_cps_closure(handler_is_loop$0, handler_is_loop$1); + //end + |}]; + print_double_fun_decl code "handler_is_merge_node"; + [%expect + {| + function handler_is_merge_node$0(g){ + try{var _g_ = caml_call1(g, 0), s = _g_;}catch(_h_){var s = cst$1;} + return caml_call2(Stdlib[28], s, cst_aaa); + } + //end + function handler_is_merge_node$1(g, cont){ + function _d_(s){ + return caml_trampoline_cps_call3(Stdlib[28], s, cst_aaa, cont); + } + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_trampoline_cps_call2 + (g, 0, function(_e_){caml_pop_trap(); return _d_(_e_);}); + } + //end + var + handler_is_merge_node = + caml_cps_closure(handler_is_merge_node$0, handler_is_merge_node$1); + //end + |}] diff --git a/compiler/tests-compiler/double-translation/effects_toplevel.ml b/compiler/tests-compiler/double-translation/effects_toplevel.ml new file mode 100644 index 0000000000..6550860648 --- /dev/null +++ b/compiler/tests-compiler/double-translation/effects_toplevel.ml @@ -0,0 +1,87 @@ +(* Js_of_ocaml compiler + * http://www.ocsigen.org/js_of_ocaml/ + * Copyright (C) 2019 Hugo Heuzard + * + * This program is free software; you can redistribute it and/or modify + * it under the terms of the GNU Lesser General Public License as published by + * the Free Software Foundation, with linking exception; + * either version 2.1 of the License, or (at your option) any later version. + * + * This program is distributed in the hope that it will be useful, + * but WITHOUT ANY WARRANTY; without even the implied warranty of + * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + * GNU Lesser General Public License for more details. + * + * You should have received a copy of the GNU Lesser General Public License + * along with this program; if not, write to the Free Software + * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. + *) + +open Util + +let%expect_test "test-compiler/lib-effects/test1.ml" = + let code = + compile_and_parse + ~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. *) + let g () = Printf.printf "abc" in + let f () = for i = 1 to 5 do g () done in + g (); f (); g () + |} + in + print_program code; + [%expect + {| + (function(globalThis){ + "use strict"; + var + runtime = globalThis.jsoo_runtime, + caml_string_of_jsbytes = runtime.caml_string_of_jsbytes; + function caml_call1(f, a0){ + return (f.l >= 0 ? f.l : f.l = f.length) === 1 + ? f(a0) + : runtime.caml_call_gen(f, [a0]); + } + function caml_trampoline_cps_call2(f, a0, a1){ + return runtime.caml_stack_check_depth() + ? (f.cps.l + >= 0 + ? f.cps.l + : f.cps.l = f.cps.length) + === 2 + ? f.cps.call(null, a0, a1) + : runtime.caml_call_gen_cps(f, [a0, a1]) + : runtime.caml_trampoline_return(f, [a0, a1], 0); + } + var + dummy = 0, + global_data = runtime.caml_get_global_data(), + _b_ = + [0, + [11, caml_string_of_jsbytes("abc"), 0], + caml_string_of_jsbytes("abc")], + Stdlib_Printf = global_data.Stdlib__Printf; + function g$0(param){return caml_call1(Stdlib_Printf[2], _b_);} + function g$1(param, cont){ + return caml_trampoline_cps_call2(Stdlib_Printf[2], _b_, cont); + } + var g = runtime.caml_cps_closure(g$0, g$1); + g(); + var i = 1; + for(;;){ + g(); + var _c_ = i + 1 | 0; + if(5 === i){ + g(); + var Test = [0]; + runtime.caml_register_global(2, Test, "Test"); + return; + } + i = _c_; + } + } + (globalThis)); + //end + |}] diff --git a/compiler/tests-compiler/effects.ml b/compiler/tests-compiler/effects.ml index 95892eb396..1afd07d5f1 100644 --- a/compiler/tests-compiler/effects.ml +++ b/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 @@ -43,7 +43,7 @@ let fff () = [%expect {| function fff(param, cont){ - return caml_cps_call4 + return caml_trampoline_cps_call4 (Stdlib_Effect[3][5], function(x, cont){return cont(x);}, 10, @@ -53,11 +53,14 @@ let fff () = ? cont([0, function(k, cont){return cont(11);}]) : cont(0); }], - function(_b_){ - return caml_cps_call2 + function(_f_){ + return caml_trampoline_cps_call2 (Stdlib_Printf[2], - _a_, - function(_c_){return caml_cps_call2(_c_, _b_, cont);}); + _e_, + function(_g_){ + return caml_trampoline_cps_call2(_g_, _f_, cont); + }); }); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_continuations.ml b/compiler/tests-compiler/effects_continuations.ml index 0da72bd5ee..cee457e23f 100644 --- a/compiler/tests-compiler/effects_continuations.ml +++ b/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 @@ -101,112 +101,114 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_fun_decl code (Some "loop3"); [%expect {| - function exceptions(s, cont){ - try{var _t_ = runtime.caml_int_of_string(s), n = _t_;} - catch(_x_){ - var _p_ = caml_wrap_exception(_x_); - if(_p_[1] !== Stdlib[7]){ + try{var _A_ = runtime.caml_int_of_string(s), n = _A_;} + catch(_E_){ + var _w_ = caml_wrap_exception(_E_); + if(_w_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_p_, 0)); + return raise$1(caml_maybe_attach_backtrace(_w_, 0)); } var n = 0; } try{ if(caml_string_equal(s, cst$0)) throw caml_maybe_attach_backtrace(Stdlib[8], 1); - var _s_ = 7, m = _s_; + var _z_ = 7, m = _z_; } - catch(_w_){ - var _q_ = caml_wrap_exception(_w_); - if(_q_ !== Stdlib[8]){ + catch(_D_){ + var _x_ = caml_wrap_exception(_D_); + if(_x_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_q_, 0)); + return raise$0(caml_maybe_attach_backtrace(_x_, 0)); } var m = 0; } runtime.caml_push_trap - (function(_v_){ - if(_v_ === Stdlib[8]) return cont(0); + (function(_C_){ + if(_C_ === Stdlib[8]) return cont(0); var raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_v_, 0)); + return raise(caml_maybe_attach_backtrace(_C_, 0)); }); if(! caml_string_equal(s, cst)) - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_toto, - function(_u_){caml_pop_trap(); return cont([0, [0, _u_, n, m]]);}); - var _r_ = Stdlib[8], raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_r_, 1)); + function(_B_){caml_pop_trap(); return cont([0, [0, _B_, n, m]]);}); + var _y_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_y_, 1)); } //end function cond1(b, cont){ - function _o_(ic){return cont([0, ic, 7]);} + function _v_(ic){return cont([0, ic, 7]);} return b - ? caml_cps_call2(Stdlib[79], cst_toto$0, _o_) - : caml_cps_call2(Stdlib[79], cst_titi, _o_); + ? caml_trampoline_cps_call2(Stdlib[79], cst_toto$0, _v_) + : caml_trampoline_cps_call2(Stdlib[79], cst_titi, _v_); } //end function cond2(b, cont){ - function _m_(_n_){return cont(7);} + function _t_(_u_){return cont(7);} return b - ? caml_cps_call2(Stdlib_Printf[3], _a_, _m_) - : caml_cps_call2(Stdlib_Printf[3], _b_, _m_); + ? caml_trampoline_cps_call2(Stdlib_Printf[3], _h_, _t_) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _i_, _t_); } //end function cond3(b, cont){ var x = [0, 0]; - function _k_(_l_){return cont(x[1]);} - return b ? (x[1] = 1, _k_(0)) : caml_cps_call2(Stdlib_Printf[3], _c_, _k_); + function _r_(_s_){return cont(x[1]);} + return b + ? (x[1] = 1, _r_(0)) + : caml_trampoline_cps_call2(Stdlib_Printf[3], _j_, _r_); } //end function loop1(b, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_static_examples_ml, function(ic){ - function _i_(_j_){ - return caml_cps_call2 + function _p_(_q_){ + return caml_trampoline_cps_call2 (Stdlib[83], ic, function(line){ return b - ? caml_cps_call2(Stdlib[53], line, _i_) - : caml_cps_exact_call1(_i_, 0); + ? caml_trampoline_cps_call2(Stdlib[53], line, _p_) + : caml_exact_trampoline_call1(_p_, 0); }); } - return _i_(0); + return _p_(0); }); } //end function loop2(param, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_static_examples_ml$0, function(ic){ - function _g_(_h_){ - return caml_cps_call2 + function _n_(_o_){ + return caml_trampoline_cps_call2 (Stdlib[83], ic, function(line){ - return caml_cps_call2(Stdlib[53], line, _g_); + return caml_trampoline_cps_call2(Stdlib[53], line, _n_); }); } - return caml_cps_call2(Stdlib_Printf[3], _d_, _g_); + return caml_trampoline_cps_call2(Stdlib_Printf[3], _k_, _n_); }); } //end function loop3(param, cont){ - return caml_cps_call2 + return caml_trampoline_cps_call2 (list_rev, - _e_, + _l_, function(l){ - function _f_(x){ + function _m_(x){ if(! x) return cont(l); var r = x[2]; - return caml_cps_exact_call1(_f_, r); + return caml_exact_trampoline_call1(_m_, r); } - return _f_(l); + return _m_(l); }); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_exceptions.ml b/compiler/tests-compiler/effects_exceptions.ml index f227b7b881..5637ab11d1 100644 --- a/compiler/tests-compiler/effects_exceptions.ml +++ b/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', @@ -55,59 +55,59 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = print_fun_decl code (Some "exceptions"); [%expect {| - function exceptions(s, cont){ - try{var _k_ = runtime.caml_int_of_string(s), n = _k_;} - catch(_o_){ - var _g_ = caml_wrap_exception(_o_); - if(_g_[1] !== Stdlib[7]){ + try{var _n_ = runtime.caml_int_of_string(s), n = _n_;} + catch(_r_){ + var _j_ = caml_wrap_exception(_r_); + if(_j_[1] !== Stdlib[7]){ var raise$1 = caml_pop_trap(); - return raise$1(caml_maybe_attach_backtrace(_g_, 0)); + return raise$1(caml_maybe_attach_backtrace(_j_, 0)); } var n = 0; } try{ if(caml_string_equal(s, cst$0)) throw caml_maybe_attach_backtrace(Stdlib[8], 1); - var _j_ = 7, m = _j_; + var _m_ = 7, m = _m_; } - catch(_n_){ - var _h_ = caml_wrap_exception(_n_); - if(_h_ !== Stdlib[8]){ + catch(_q_){ + var _k_ = caml_wrap_exception(_q_); + if(_k_ !== Stdlib[8]){ var raise$0 = caml_pop_trap(); - return raise$0(caml_maybe_attach_backtrace(_h_, 0)); + return raise$0(caml_maybe_attach_backtrace(_k_, 0)); } var m = 0; } caml_push_trap - (function(_m_){ - if(_m_ === Stdlib[8]) return cont(0); + (function(_p_){ + if(_p_ === Stdlib[8]) return cont(0); var raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_m_, 0)); + return raise(caml_maybe_attach_backtrace(_p_, 0)); }); if(! caml_string_equal(s, cst)) - return caml_cps_call2 + return caml_trampoline_cps_call2 (Stdlib[79], cst_toto, - function(_l_){caml_pop_trap(); return cont([0, [0, _l_, n, m]]);}); - var _i_ = Stdlib[8], raise = caml_pop_trap(); - return raise(caml_maybe_attach_backtrace(_i_, 1)); + function(_o_){caml_pop_trap(); return cont([0, [0, _o_, n, m]]);}); + var _l_ = Stdlib[8], raise = caml_pop_trap(); + return raise(caml_maybe_attach_backtrace(_l_, 1)); } - //end |}]; + //end + |}]; print_fun_decl code (Some "handler_is_loop"); [%expect {| function handler_is_loop(f, g, l, cont){ caml_push_trap - (function(_e_){ - function _f_(l){ - return caml_cps_call2 + (function(_h_){ + function _i_(l){ + return caml_trampoline_cps_call2 (g, l, function(match){ if(72330306 <= match[1]){ var l = match[2]; - return caml_cps_exact_call1(_f_, l); + return caml_exact_trampoline_call1(_i_, l); } var exn = match[2], @@ -116,18 +116,23 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = return raise(exn$0); }); } - return _f_(l); + return _i_(l); }); - return caml_cps_call2 - (f, 0, function(_d_){caml_pop_trap(); return cont(_d_);}); + return caml_trampoline_cps_call2 + (f, 0, function(_g_){caml_pop_trap(); return cont(_g_);}); } - //end |}]; + //end + |}]; print_fun_decl code (Some "handler_is_merge_node"); [%expect {| function handler_is_merge_node(g, cont){ - function _a_(s){return caml_cps_call3(Stdlib[28], s, cst_aaa, cont);} - caml_push_trap(function(_c_){return _a_(cst$1);}); - return caml_cps_call2(g, 0, function(_b_){caml_pop_trap(); return _a_(_b_);}); + function _d_(s){ + return caml_trampoline_cps_call3(Stdlib[28], s, cst_aaa, cont); + } + caml_push_trap(function(_f_){return _d_(cst$1);}); + return caml_trampoline_cps_call2 + (g, 0, function(_e_){caml_pop_trap(); return _d_(_e_);}); } - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/effects_toplevel.ml b/compiler/tests-compiler/effects_toplevel.ml index 20eb72768b..4153f03b2f 100644 --- a/compiler/tests-compiler/effects_toplevel.ml +++ b/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]. *) @@ -40,12 +40,12 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = runtime = globalThis.jsoo_runtime, caml_callback = runtime.caml_callback, caml_string_of_jsbytes = runtime.caml_string_of_jsbytes; - function caml_cps_exact_call1(f, a0){ + function caml_exact_trampoline_call1(f, a0){ return runtime.caml_stack_check_depth() ? f(a0) - : runtime.caml_trampoline_return(f, [a0]); + : runtime.caml_trampoline_return(f, [a0], 1); } - function caml_cps_call2(f, a0, a1){ + function caml_trampoline_cps_call2(f, a0, a1){ return runtime.caml_stack_check_depth() ? (f.l >= 0 @@ -54,12 +54,12 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = === 2 ? f(a0, a1) : runtime.caml_call_gen(f, [a0, a1]) - : runtime.caml_trampoline_return(f, [a0, a1]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } - function caml_cps_exact_call2(f, a0, a1){ + function caml_exact_trampoline_cps_call(f, a0, a1){ return runtime.caml_stack_check_depth() ? f(a0, a1) - : runtime.caml_trampoline_return(f, [a0, a1]); + : runtime.caml_trampoline_return(f, [a0, a1], 0); } return caml_callback (function(cont){ @@ -67,27 +67,27 @@ let%expect_test "test-compiler/lib-effects/test1.ml" = dummy = 0, global_data = runtime.caml_get_global_data(), Stdlib_Printf = global_data.Stdlib__Printf, - _a_ = + _b_ = [0, [11, caml_string_of_jsbytes("abc"), 0], caml_string_of_jsbytes("abc")]; function g(param, cont){ - return caml_cps_call2(Stdlib_Printf[2], _a_, cont); + return caml_trampoline_cps_call2(Stdlib_Printf[2], _b_, cont); } caml_callback(g, [dummy]); - function _b_(i){ - return caml_cps_exact_call2 + function _c_(i){ + return caml_exact_trampoline_cps_call (g, dummy, - function(_c_){ - var _d_ = i + 1 | 0; - if(5 !== i) return caml_cps_exact_call1(_b_, _d_); + function(_d_){ + var _e_ = i + 1 | 0; + if(5 !== i) return caml_exact_trampoline_call1(_c_, _e_); caml_callback(g, [dummy]); var Test = [0]; runtime.caml_register_global(2, Test, "Test"); }); } - return _b_(1); + return _c_(1); }, []); } diff --git a/compiler/tests-compiler/es6.ml b/compiler/tests-compiler/es6.ml index 464a1d7d37..5f3f65dcef 100644 --- a/compiler/tests-compiler/es6.ml +++ b/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 {| diff --git a/compiler/tests-compiler/lambda_lifting.ml b/compiler/tests-compiler/lambda_lifting.ml index 44ba220119..1bd37835d1 100644 --- a/compiler/tests-compiler/lambda_lifting.ml +++ b/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 {| @@ -26,16 +28,17 @@ Printf.printf "%d\n" (f 3) runtime = globalThis.jsoo_runtime, global_data = runtime.caml_get_global_data(), Stdlib_Printf = global_data.Stdlib__Printf, - _b_ = + _e_ = [0, [4, 0, 0, 0, [12, 10, 0]], runtime.caml_string_of_jsbytes("%d\n")]; function h(x, y){function h(z){return (x + y | 0) + z | 0;} return h;} function g(x){function g(y){var h$0 = h(x, y); return h$0(7);} return g;} function f(x){var g$0 = g(x); return g$0(5);} - var _a_ = f(3); - runtime.caml_callback(Stdlib_Printf[2], [_b_, _a_]); + var _d_ = f(3); + runtime.caml_callback(Stdlib_Printf[2], [_e_, _d_]); var Test = [0]; runtime.caml_register_global(2, Test, "Test"); return; } (globalThis)); - //end |}] + //end + |}] diff --git a/compiler/tests-compiler/util/util.ml b/compiler/tests-compiler/util/util.ml index e19f6f8c46..32dbb86383 100644 --- a/compiler/tests-compiler/util/util.ml +++ b/compiler/tests-compiler/util/util.ml @@ -290,7 +290,7 @@ let extract_sourcemap file = let compile_to_javascript ?(flags = []) ?(use_js_string = false) - ?(effects = false) + ?effects ~pretty ~sourcemap file = @@ -299,7 +299,11 @@ let compile_to_javascript List.flatten [ (if pretty then [ "--pretty" ] else []) ; (if sourcemap then [ "--sourcemap" ] else []) - ; (if effects then [ "--enable=effects" ] else [ "--disable=effects" ]) + ; (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" ]) @@ -510,6 +514,50 @@ let print_fun_decl program n = | [] -> print_endline "not found" | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) +(* Find a doubly-translated function by name, and use the call to [caml_cps_closure] to find the direct-style and CPS closures *) +class find_double_function_declaration r n = + object + inherit Jsoo.Js_traverse.map as super + + method! statement s = + let open Jsoo.Javascript in + (match s with + | Variable_statement (_, l) -> + List.iter l ~f:(function + | DeclIdent + ( S { name = Utf8 name; _ } + , Some + ( ECall + ( EVar (S { name = Utf8 "caml_cps_closure"; _ }) + , _ + , [ Arg e1; Arg e2 ] + , _ ) + , _ ) ) as var_decl -> + let decls = var_decl, e1, e2 in + if String.equal name n then r := decls :: !r else () + | _ -> ()) + | _ -> ()); + super#statement s + end + +let print_double_fun_decl program n = + let r = ref [] in + let o = new find_double_function_declaration r n in + ignore (o#program program); + let module J = Jsoo.Javascript in + let maybe_print_decl = function + | J.EFun _ -> () + | J.(EVar (S { name = Utf8 name; _ })) -> print_fun_decl program (Some name) + | _ -> print_endline "not found" + in + match !r with + | [ (var_decl, e1, e2) ] -> + maybe_print_decl e1; + maybe_print_decl e2; + print_string (program_to_string [ J.(Variable_statement (Var, [ var_decl ]), N) ]) + | [] -> print_endline "not found" + | l -> print_endline (Format.sprintf "%d functions found" (List.length l)) + let compile_and_run_bytecode ?unix s = with_temp_dir ~f:(fun () -> s diff --git a/compiler/tests-compiler/util/util.mli b/compiler/tests-compiler/util/util.mli index 5788400928..b44b79e919 100644 --- a/compiler/tests-compiler/util/util.mli +++ b/compiler/tests-compiler/util/util.mli @@ -34,7 +34,7 @@ val compile_lib : Filetype.cmo_file list -> string -> Filetype.cmo_file val compile_cmo_to_javascript : ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -43,7 +43,7 @@ val compile_cmo_to_javascript : val compile_bc_to_javascript : ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?pretty:bool -> ?sourcemap:bool @@ -75,12 +75,15 @@ val find_variable : Javascript.program -> string -> Javascript.expression val find_function : Javascript.program -> string -> Javascript.function_declaration +(* Prints the two versions of a doubly translated function *) +val print_double_fun_decl : Javascript.program -> string -> unit + val compile_and_run : ?debug:bool -> ?pretty:bool -> ?skip_modern:bool -> ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?unix:bool -> string @@ -92,7 +95,7 @@ val compile_and_parse : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> string -> Javascript.program @@ -101,7 +104,7 @@ val compile_and_parse_whole_program : ?debug:bool -> ?pretty:bool -> ?flags:string list - -> ?effects:bool + -> ?effects:Config.effects_backend -> ?use_js_string:bool -> ?unix:bool -> string diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml new file mode 100644 index 0000000000..5808e584c5 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform.ml @@ -0,0 +1,164 @@ +open Printf +open Effect +open Effect.Deep + +module type TREE = sig + type 'a t + (** The type of tree. *) + + val leaf : 'a t + (** A tree with only a leaf. *) + + val node : 'a t -> 'a -> 'a t -> 'a t + (** [node l x r] constructs a new tree with a new node [x] as the value, with + [l] and [r] being the left and right sub-trees. *) + + val deep : int -> int t + (** [deep n] constructs a tree of depth n, in linear time, where every node at + level [l] has value [l]. *) + + val to_iter : 'a t -> ('a -> unit) -> unit + (** Iterator function. *) + + val to_gen : 'a t -> unit -> 'a option + (** Generator function. [to_gen t] returns a generator function [g] for the + tree that traverses the tree in depth-first fashion, returning [Some x] + for each node when [g] is invoked. [g] returns [None] once the traversal + is complete. *) + + val to_gen_cps : 'a t -> unit -> 'a option + (** CPS version of the generator function. *) +end + +module Tree : TREE = struct + type 'a t = + | Leaf + | Node of 'a t * 'a * 'a t + + let leaf = Leaf + + let node l x r = Node (l, x, r) + + let rec deep = function + | 0 -> Leaf + | n -> + let t = deep (n - 1) in + Node (t, n, t) + + let rec iter f = function + | Leaf -> () + | Node (l, x, r) -> + iter f l; + f x; + iter f r + + (* val to_iter : 'a t -> ('a -> unit) -> unit *) + let to_iter t f = iter f t + + (* val to_gen : 'a t -> (unit -> 'a option) *) + let to_gen (type a) (t : a t) = + let module M = struct + type _ Effect.t += Next : a -> unit Effect.t + end in + let open M in + let rec step = + ref (fun () -> + try_with + (fun t -> + iter (fun x -> perform (Next x)) t; + None) + t + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Next v -> + Some + (fun (k : (a, _) continuation) -> + (step := fun () -> continue k ()); + Some v) + | _ -> None) + }) + in + fun () -> !step () + + let to_gen_cps t = + let next = ref t in + let cont = ref Leaf in + let rec iter t k = + match t with + | Leaf -> run k + | Node (left, x, right) -> iter left (Node (k, x, right)) + and run = function + | Leaf -> None + | Node (k, x, right) -> + next := right; + cont := k; + Some x + in + fun () -> iter !next !cont +end + +let get_mean_sd l = + let get_mean l = + List.fold_right (fun a v -> a +. v) l 0. /. (float_of_int @@ List.length l) + in + let mean = get_mean l in + let sd = get_mean @@ List.map (fun v -> abs_float (v -. mean) ** 2.) l in + mean, sd + +let benchmark f n = + let rec run acc = function + | 0 -> acc + | n -> + let t1 = Sys.time () in + let () = f () in + let d = Sys.time () -. t1 in + run (d :: acc) (n - 1) + in + let r = run [] n in + get_mean_sd r + +(* Main follows *) + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + let n = try int_of_string Sys.argv.(1) with _ -> 21 in + let t = Tree.deep n in + let iter_fun () = Tree.to_iter t (fun _ -> ()) in + let rec consume_all f = + match f () with + | None -> () + | Some _ -> consume_all f + in + + (* The code below should be called in direct style despite the installed + effect handler *) + Jsoo_runtime.Effect.assume_no_perform (fun () -> + let m, sd = benchmark iter_fun 5 in + let () = printf "Iter: mean = %f, sd = %f\n%!" m sd in + + let gen_cps_fun () = + let f = Tree.to_gen_cps t in + consume_all f + in + + let m, sd = benchmark gen_cps_fun 5 in + printf "Gen_cps: mean = %f, sd = %f\n%!" m sd); + + let gen_fun () = + let f = Tree.to_gen t in + consume_all f + in + + let m, sd = benchmark gen_fun 5 in + printf "Gen_eff: mean = %f, sd = %f\n%!" m sd) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml new file mode 100644 index 0000000000..25f152ee82 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_nested_handler.ml @@ -0,0 +1,25 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let () = + try_with + (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> + try_with + (fun () -> ()) + () + { effc = (fun (type a) (_ : a Effect.t) -> None) }; + ); + perform Dummy + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> + Some (fun (k : (a, _) continuation) -> print_endline "ok"; continue k ()) + | _ -> None) + } diff --git a/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml new file mode 100644 index 0000000000..a6ff920bdf --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/assume_no_perform_unhandled.ml @@ -0,0 +1,26 @@ +open Printf +open Effect +open Effect.Deep + +type _ Effect.t += Dummy : unit t + +let must_raise () = + try_with + (fun () -> + Jsoo_runtime.Effect.assume_no_perform (fun () -> + (* Should raise [Effect.Unhandled] despite the installed handler *) + perform Dummy + ) + ) + () + { effc = + (fun (type a) (e : a Effect.t) -> + match e with + | Dummy -> Some (fun (k : (a, _) continuation) -> continue k ()) + | _ -> None) + } + +let () = + try + must_raise (); print_endline "failed"; exit 2 + with Effect.Unhandled Dummy -> print_endline "ok" diff --git a/compiler/tests-ocaml/lib-effects/double-translation/dune b/compiler/tests-ocaml/lib-effects/double-translation/dune new file mode 100644 index 0000000000..9dc258c2d8 --- /dev/null +++ b/compiler/tests-ocaml/lib-effects/double-translation/dune @@ -0,0 +1,91 @@ +(env + (with-effects + (flags + (:standard -w -38)) + (js_of_ocaml + (flags + (:standard --effects=double-translation)) + (build_runtime_flags + (:standard --effects=double-translation)) + ;; separate compilation doesn't yet work when using + ;; '--effect=double-translation' since Dune doesn't know it should compile a + ;; different version of the dependencies. + (compilation_mode whole_program))) + (_ + (flags + (:standard -w -38)) + (js_of_ocaml + (flags + (:standard --effects=double-translation)) + (build_runtime_flags + (:standard --effects=double-translation)) + ;; separate compilation doesn't yet work when using + ;; '--effect=double-translation' since Dune doesn't know it should compile a + ;; different version of the dependencies. + (compilation_mode whole_program)))) + +(copy_files ../*.expected) + +(copy_files# ../*.ml) + +(tests + (build_if + (>= %{ocaml_version} 5)) + (names + cmphash + marshal + effects + evenodd + manylive + overflow + partial + reperform + sched + shallow_state_io + shallow_state + test10 + test11 + test1 + test2 + test3 + test4 + test5 + test6 + test_lazy + used_cont) + (modules + (:standard + \ + unhandled_unlinked + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler)) + (modes js)) + +(tests + (build_if + (>= %{ocaml_version} 5)) + (names unhandled_unlinked) + (modules unhandled_unlinked) + (action + (pipe-outputs + (with-accepted-exit-codes + 2 + (run node %{test})) + (run cat))) + (modes js)) + +(tests + (build_if + (>= %{ocaml_version} 5)) + (names + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler) + (libraries js_of_ocaml) + (action + (ignore-outputs + (with-accepted-exit-codes + 0 + (run node %{test})))) + (modes js)) diff --git a/compiler/tests-ocaml/lib-effects/dune b/compiler/tests-ocaml/lib-effects/dune index b025306dc4..9ac073c2b3 100644 --- a/compiler/tests-ocaml/lib-effects/dune +++ b/compiler/tests-ocaml/lib-effects/dune @@ -4,7 +4,9 @@ (:standard -w -38)) (js_of_ocaml (flags - (:standard --enable effects))))) + (:standard --enable=effects)) + (build_runtime_flags + (:standard --enable=effects))))) (tests (build_if @@ -32,7 +34,12 @@ test_lazy used_cont) (modules - (:standard \ unhandled_unlinked)) + (:standard + \ + unhandled_unlinked + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler)) (modes js wasm)) (tests @@ -47,3 +54,18 @@ (run node %{test})) (run cat))) (modes js wasm)) + +(tests + (build_if + (>= %{ocaml_version} 5)) + (names + assume_no_perform + assume_no_perform_unhandled + assume_no_perform_nested_handler) + (libraries js_of_ocaml) + (action + (ignore-outputs + (with-accepted-exit-codes + 0 + (run node %{test})))) + (modes js wasm)) diff --git a/lib/js_of_ocaml/dune b/lib/js_of_ocaml/dune index df22bcb59a..9dc2c3cfe1 100644 --- a/lib/js_of_ocaml/dune +++ b/lib/js_of_ocaml/dune @@ -1,7 +1,8 @@ (library (name js_of_ocaml) (public_name js_of_ocaml) - (libraries js_of_ocaml-compiler.runtime) + (libraries + (re_export js_of_ocaml-compiler.runtime)) (foreign_stubs (language c) (names js_of_ocaml_stubs)) diff --git a/lib/runtime/js_of_ocaml_runtime_stubs.c b/lib/runtime/js_of_ocaml_runtime_stubs.c index 69f6b31c94..559cc91fd1 100644 --- a/lib/runtime/js_of_ocaml_runtime_stubs.c +++ b/lib/runtime/js_of_ocaml_runtime_stubs.c @@ -16,6 +16,10 @@ void bigstring_to_typed_array () { caml_fatal_error("Unimplemented Javascript primitive bigstring_to_typed_array!"); } +void caml_assume_no_perform () { + caml_fatal_error("Unimplemented Javascript primitive caml_assume_no_perform!"); +} + void caml_ba_from_typed_array () { caml_fatal_error("Unimplemented Javascript primitive caml_ba_from_typed_array!"); } diff --git a/lib/runtime/jsoo_runtime.ml b/lib/runtime/jsoo_runtime.ml index 8127195231..c95a8818e5 100644 --- a/lib/runtime/jsoo_runtime.ml +++ b/lib/runtime/jsoo_runtime.ml @@ -127,7 +127,18 @@ module Sys = struct module Config = struct external use_js_string : unit -> bool = "caml_jsoo_flags_use_js_string" - external effects : unit -> bool = "caml_jsoo_flags_effects" + type effects_backend = + | Cps + | Double_translation + + external effects_ : unit -> string = "caml_jsoo_flags_effects" + + let effects () = + match effects_ () with + | "none" -> None + | "cps" -> Some Cps + | "double-translation" -> Some Double_translation + | _ -> assert false end let version = Runtime_version.s @@ -228,3 +239,18 @@ module Int64 = struct external create_int64_lo_mi_hi : int -> int -> int -> Int64.t = "caml_int64_create_lo_mi_hi" end + +module Effect : sig + external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" + (** Passing a function [f] as argument of `assume_no_perform` guarantees that, + when compiling with `--effects=double-translation`, 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 `assume_no_perform`, unless a new effect handler was + installed in the meantime. + + This behaviour is the same when double translation is disabled. *) +end = struct + external assume_no_perform : (unit -> 'a) -> 'a = "caml_assume_no_perform" +end diff --git a/manual/effects.wiki b/manual/effects.wiki index 551afee24f..cffe51c226 100644 --- a/manual/effects.wiki +++ b/manual/effects.wiki @@ -11,6 +11,8 @@ The analysis is especially effective on monomorphic code. It is not so effective We hope to improve on this by trying alternative compilation strategies. +An alternative CPS transform is provided under the {{--effects=double-translation}} option. It keeps a direct-style version of the transformed functions in addition to the CPS version. The choice of running the CPS version is delayed to run time. Since CPS code is usually slower, this can avoid degradations. In addition, one can ensure that some code is run in direct style by using {{Jsoo_runtime.Effect.assume_no_perform}}. A caveat is that Dune does not know about {{--effects=double-translation}} yet and may try to link together files built with {{--enable=double-translation}} and files built with only {{--enable=effects}}, which gives an error. A work-around is to disable separate compilation by using the option {{(js_of_ocaml (compilation_mode whole_program))}}. + === Dune integration === We're still working on dune support for compiling js_of_ocaml programs diff --git a/manual/overview.wiki b/manual/overview.wiki index 24c7b8f515..6dce5ca01f 100644 --- a/manual/overview.wiki +++ b/manual/overview.wiki @@ -84,7 +84,11 @@ functions are optimized: * trampolines are used otherwise. <>. -Effect handlers are fully supported with the {{{--enable=effects}}} flag. This is not the default for now since effects are not widely used at the moment and the generated code can be slower, larger and less readable. +Effect handlers are fully supported with the +{{{--enable=effects}}} flag. Effect support is disabled by +default for now since effects are not widely used at the moment and the +generated code can be slower, larger and less readable. See the dedicated +manual section about effects for details. Data representation differs from the usual one. Most notably, integers are 32 bits (rather than 31 bits or 63 bits), which is their diff --git a/runtime/js/effect.js b/runtime/js/effect.js index 3856e76bf4..e7c467df67 100644 --- a/runtime/js/effect.js +++ b/runtime/js/effect.js @@ -68,6 +68,31 @@ function caml_pop_trap() { return h; } +//Provides: caml_raise_unhandled +//Requires: caml_named_value, caml_raise_with_arg, caml_raise_constant, caml_string_of_jsbytes, caml_fresh_oo_id +//If: effects +function caml_raise_unhandled(eff) { + var exn = caml_named_value("Effect.Unhandled"); + if (exn) caml_raise_with_arg(exn, eff); + else { + exn = [ + 248, + caml_string_of_jsbytes("Effect.Unhandled"), + caml_fresh_oo_id(0), + ]; + caml_raise_constant(exn); + } +} + +//Provides: caml_uncaught_effect_handler +//Requires: caml_resume_stack, caml_raise_unhandled +//If: effects +function caml_uncaught_effect_handler(eff, k, ms, cont) { + // Resumes the continuation k by raising exception Unhandled. + caml_resume_stack(k[1], ms); + caml_raise_unhandled(eff); +} + //Provides: caml_fiber_stack //If: effects // This has the shape {h, r:{k, x, e}} where h is a triple of handlers @@ -109,7 +134,7 @@ function caml_pop_fiber() { } //Provides: caml_perform_effect -//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack +//Requires: caml_pop_fiber, caml_stack_check_depth, caml_trampoline_return, caml_exn_stack, caml_fiber_stack, caml_get_cps_fun //If: effects function caml_perform_effect(eff, cont, k0) { // Allocate a continuation if we don't already have one @@ -123,12 +148,26 @@ function caml_perform_effect(eff, cont, k0) { // The handler is defined in Stdlib.Effect, so we know that the arity matches var k1 = caml_pop_fiber(); return caml_stack_check_depth() - ? handler(eff, cont, k1, k1) - : caml_trampoline_return(handler, [eff, cont, k1, k1]); + ? caml_get_cps_fun(handler)(eff, cont, k1, k1) + : caml_trampoline_return(handler, [eff, cont, k1, k1], 0); +} + +//Provides: caml_get_cps_fun +//If: effects +//If: !doubletranslate +function caml_get_cps_fun(f) { + return f; +} + +//Provides: caml_get_cps_fun +//If: effects +//If: doubletranslate +function caml_get_cps_fun(f) { + return f.cps; } //Provides: caml_alloc_stack -//Requires: caml_pop_fiber, caml_fiber_stack, caml_call_gen, caml_stack_check_depth, caml_trampoline_return +//Requires: caml_pop_fiber, caml_fiber_stack, caml_stack_check_depth, caml_trampoline_return, caml_call_gen_cps //If: effects //Version: >= 5.0 function caml_alloc_stack(hv, hx, hf) { @@ -136,8 +175,8 @@ function caml_alloc_stack(hv, hx, hf) { var f = caml_fiber_stack.h[i]; var args = [x, caml_pop_fiber()]; return caml_stack_check_depth() - ? caml_call_gen(f, args) - : caml_trampoline_return(f, args); + ? caml_call_gen_cps(f, args) + : caml_trampoline_return(f, args, 0); } function hval(x) { // Call [hv] in the parent fiber @@ -215,3 +254,62 @@ function caml_ml_condition_signal(t) { function jsoo_effect_not_supported() { caml_failwith("Effect handlers are not supported"); } + +//Provides: caml_resume +//Requires:caml_stack_depth, caml_call_gen_cps, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler, caml_resume_stack +//If: effects +//If: doubletranslate +function caml_resume(f, arg, stack) { + var saved_stack_depth = caml_stack_depth; + var saved_exn_stack = caml_exn_stack; + var saved_fiber_stack = caml_fiber_stack; + try { + caml_exn_stack = 0; + caml_fiber_stack = { + h: [0, 0, 0, { cps: caml_uncaught_effect_handler }], + r: { k: 0, x: 0, e: 0 }, + }; + var k = caml_resume_stack(stack, (x) => x); + /* Note: f is not an ordinary function but a (direct-style, CPS) closure pair */ + var res = { joo_tramp: f, joo_args: [arg, k], joo_direct: 0 }; + do { + caml_stack_depth = 40; + try { + res = res.joo_direct + ? res.joo_tramp.apply(null, res.joo_args) + : caml_call_gen_cps(res.joo_tramp, res.joo_args); + } catch (e) { + /* Handle exception coming from JavaScript or from the runtime. */ + if (!caml_exn_stack.length) throw e; + var handler = caml_exn_stack[1]; + caml_exn_stack = caml_exn_stack[2]; + res = { + joo_tramp: handler, + joo_args: [caml_wrap_exception(e)], + joo_direct: 1, + }; + } + } while (res && res.joo_args); + return res; + } finally { + caml_stack_depth = saved_stack_depth; + caml_exn_stack = saved_exn_stack; + caml_fiber_stack = saved_fiber_stack; + } +} + +//Provides: caml_cps_closure +//If: effects +//If: doubletranslate +function caml_cps_closure(direct_f, cps_f) { + direct_f.cps = cps_f; + return direct_f; +} + +//Provides: caml_assume_no_perform +//Requires: caml_callback +//If: effects +//If: !doubletranslate +function caml_assume_no_perform(f) { + return caml_callback(f, [0]); +} diff --git a/runtime/js/jslib.js b/runtime/js/jslib.js index 03fbdbefe9..495bbf1566 100644 --- a/runtime/js/jslib.js +++ b/runtime/js/jslib.js @@ -61,13 +61,14 @@ function caml_trampoline(res) { } //Provides:caml_trampoline_return -function caml_trampoline_return(f, args) { - return { joo_tramp: f, joo_args: args }; +function caml_trampoline_return(f, args, direct) { + return { joo_tramp: f, joo_args: args, joo_direct: direct }; } //Provides:caml_stack_depth //If: effects -var caml_stack_depth = 0; +var caml_stack_depth = 10; // Initialized to a non-zero value in case of +// unhandled effect //Provides:caml_stack_check_depth //If: effects @@ -83,30 +84,16 @@ var caml_callback = caml_call_gen; //Provides: caml_callback //If: effects -//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_resume_stack, caml_fresh_oo_id, caml_named_value, caml_raise_with_arg, caml_string_of_jsbytes -//Requires: caml_raise_constant +//If: !doubletranslate +//Requires:caml_stack_depth, caml_call_gen, caml_exn_stack, caml_fiber_stack, caml_wrap_exception, caml_uncaught_effect_handler function caml_callback(f, args) { - function uncaught_effect_handler(eff, k, ms) { - // Resumes the continuation k by raising exception Unhandled. - caml_resume_stack(k[1], ms); - var exn = caml_named_value("Effect.Unhandled"); - if (exn) caml_raise_with_arg(exn, eff); - else { - exn = [ - 248, - caml_string_of_jsbytes("Effect.Unhandled"), - caml_fresh_oo_id(0), - ]; - caml_raise_constant(exn); - } - } var saved_stack_depth = caml_stack_depth; var saved_exn_stack = caml_exn_stack; var saved_fiber_stack = caml_fiber_stack; try { caml_exn_stack = 0; caml_fiber_stack = { - h: [0, 0, 0, uncaught_effect_handler], + h: [0, 0, 0, caml_uncaught_effect_handler], r: { k: 0, x: 0, e: 0 }, }; var res = { @@ -135,6 +122,12 @@ function caml_callback(f, args) { return res; } +//Provides: caml_callback +//If: effects +//If: doubletranslate +//Requires: caml_call_gen +var caml_callback = caml_call_gen; + //Provides: caml_is_js function caml_is_js() { return 1; @@ -147,7 +140,7 @@ function caml_jsoo_flags_use_js_string(unit) { //Provides: caml_jsoo_flags_effects function caml_jsoo_flags_effects(unit) { - return FLAG("effects"); + return CONFIG("effects"); } //Provides: caml_wrap_exception const (mutable) diff --git a/runtime/js/stdlib.js b/runtime/js/stdlib.js index 307986787d..87e5f6d801 100644 --- a/runtime/js/stdlib.js +++ b/runtime/js/stdlib.js @@ -64,14 +64,14 @@ function caml_call_gen(f, args) { //Provides: caml_call_gen (const, shallow) //If: effects +//If: !doubletranslate //Weakdef function caml_call_gen(f, args) { var n = f.l >= 0 ? f.l : (f.l = f.length); var argsLen = args.length; var d = n - argsLen; - if (d === 0) { - return f.apply(null, args); - } else if (d < 0) { + if (d === 0) return f.apply(null, args); + else if (d < 0) { var rest = args.slice(n - 1); var k = args[argsLen - 1]; args = args.slice(0, n); @@ -120,6 +120,102 @@ function caml_call_gen(f, args) { } } +//Provides: caml_call_gen_cps +//Requires: caml_call_gen +//If: effects +//If: !doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen; + +//Provides: caml_call_gen_tuple (const, shallow) +//Requires: caml_fiber_stack, caml_cps_closure +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_tuple = (function () { + function caml_call_gen_direct(f, args) { + var n = f.l >= 0 ? f.l : (f.l = f.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.apply(null, args); + } else if (d < 0) { + return caml_call_gen_direct( + f.apply(null, args.slice(0, n)), + args.slice(n), + ); + } else { + // FIXME: Restore the optimization of handling specially d = 1 or 2 + var args_ = args.slice(); + args_.length = argsLen; + var ret = caml_cps_closure( + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args.concat(extra_args)); + }, + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); + }, + ); + ret.l = d; + ret.cps.l = d + 1; + return ret; + } + } + function caml_call_gen_cps(f, args) { + var n = f.cps.l >= 0 ? f.cps.l : (f.cps.l = f.cps.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.cps.apply(null, args); + } else if (d < 0) { + var rest = args.slice(n - 1); + var k = args[argsLen - 1]; + args = args.slice(0, n); + args[n - 1] = function (g) { + var args = rest.slice(); + args[args.length - 1] = k; + return caml_call_gen_cps(g, args); + }; + return f.cps.apply(null, args); + } else { + argsLen--; + var args_ = args.slice(); + args_.length = argsLen; + var cont = caml_cps_closure( + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args_.concat(extra_args)); + }, + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); + }, + ); + var k = args[argsLen]; + cont.l = d; + cont.cps.l = d + 1; + return k(cont); + } + } + return [caml_call_gen_direct, caml_call_gen_cps]; +})(); + +//Provides: caml_call_gen +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen = caml_call_gen_tuple[0]; + +//Provides: caml_call_gen_cps +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen_tuple[1]; + //Provides: caml_named_values var caml_named_values = {}; diff --git a/runtime/js/stdlib_modern.js b/runtime/js/stdlib_modern.js index 88c4806a1f..ba47bdc341 100644 --- a/runtime/js/stdlib_modern.js +++ b/runtime/js/stdlib_modern.js @@ -62,6 +62,8 @@ function caml_call_gen(f, args) { //Provides: caml_call_gen (const, shallow) //If: effects +//If: !doubletranslate +//Weakdef function caml_call_gen(f, args) { var n = f.l >= 0 ? f.l : (f.l = f.length); var argsLen = args.length; @@ -115,3 +117,89 @@ function caml_call_gen(f, args) { return k(g); } } + +//Provides: caml_call_gen_tuple (const, shallow) +//Requires: caml_fiber_stack, caml_cps_closure +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_tuple = (function () { + function caml_call_gen_direct(f, args) { + var n = f.l >= 0 ? f.l : (f.l = f.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f(...args); + } else if (d < 0) { + return caml_call_gen_direct(f.apply(...args.slice(0, n)), args.slice(n)); + } else { + // FIXME: Restore the optimization of handling specially d = 1 or 2 + var args_ = args.slice(); + args_.length = argsLen; + var ret = caml_cps_closure( + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args.concat(extra_args)); + }, + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); + }, + ); + ret.l = d; + ret.cps.l = d + 1; + return ret; + } + } + function caml_call_gen_cps(f, args) { + var n = f.cps.l >= 0 ? f.cps.l : (f.cps.l = f.cps.length); + var argsLen = args.length; + var d = n - argsLen; + if (d === 0) { + return f.cps(...args); + } else if (d < 0) { + var rest = args.slice(n - 1); + var k = args[argsLen - 1]; + args = args.slice(0, n); + args[n - 1] = function (g) { + var args = rest.slice(); + args[args.length - 1] = k; + return caml_call_gen_cps(g, args); + }; + return f.cps(...args); + } else { + argsLen--; + var args_ = args.slice(); + args_.length = argsLen; + var cont = caml_cps_closure( + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_direct(f, args_.concat(extra_args)); + }, + function (...extra_args) { + if (extra_args.length === 0) extra_args = [undefined]; + return caml_call_gen_cps(f, args_.concat(extra_args)); + }, + ); + var k = args[argsLen]; + cont.l = d; + cont.cps.l = d + 1; + return k(cont); + } + } + return [caml_call_gen_direct, caml_call_gen_cps]; +})(); + +//Provides: caml_call_gen +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen = caml_call_gen_tuple[0]; + +//Provides: caml_call_gen_cps +//Requires: caml_call_gen_tuple +//If: effects +//If: doubletranslate +//Weakdef +var caml_call_gen_cps = caml_call_gen_tuple[1]; diff --git a/runtime/wasm/effect.wat b/runtime/wasm/effect.wat index dbc41b3c76..5bc8678f2a 100644 --- a/runtime/wasm/effect.wat +++ b/runtime/wasm/effect.wat @@ -36,6 +36,9 @@ (param $f funcref) (param $env eqref) (result anyref))) (import "bindings" "resume_fiber" (func $resume_fiber (param externref) (param (ref eq)))) + (import "obj" "caml_callback_1" + (func $caml_callback_1 + (param (ref eq)) (param (ref eq)) (result (ref eq)))) (type $block (array (mut (ref eq)))) (type $string (array (mut i8))) @@ -303,7 +306,13 @@ (ref.func $do_perform) (struct.new $pair (local.get $eff) (local.get $cont)))) + (global $effect_allowed (mut i32) (i32.const 1)) + (func (export "%perform") (param $eff (ref eq)) (result (ref eq)) + (if (i32.eqz (global.get $effect_allowed)) + (then + (return_call $raise_unhandled + (local.get $eff) (ref.i31 (i32.const 0))))) (return_call $reperform (local.get $eff) (array.new_fixed $block 3 (ref.i31 (global.get $cont_tag)) (ref.i31 (i32.const 0)) (ref.i31 (i32.const 0))))) @@ -732,4 +741,25 @@ (func (export "caml_cps_initialize_effects") (global.set $caml_trampoline_ref (ref.func $caml_trampoline))) + + (func (export "caml_assume_no_perform") (param $f (ref eq)) (result (ref eq)) + (local $saved_effect_allowed i32) + (local $res (ref eq)) + (local $exn (ref eq)) + (local.set $saved_effect_allowed (global.get $effect_allowed)) + (global.set $effect_allowed (i32.const 0)) + (local.set $res + (try (result (ref eq)) + (do + (call $caml_callback_1 (local.get $f) (ref.i31 (i32.const 0)))) + (catch $ocaml_exception + (local.set $exn (pop (ref eq))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (throw $ocaml_exception (local.get $exn))) + (catch $javascript_exception + (local.set $exn (call $caml_wrap_exception (pop externref))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (throw $ocaml_exception (local.get $exn))))) + (global.set $effect_allowed (local.get $saved_effect_allowed)) + (local.get $res)) )