From 1d48011defc7e1369e6701fb11923566f258e87e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 12 Sep 2024 16:25:34 +0200 Subject: [PATCH] Make compilation target a global parameter --- compiler/bin-js_of_ocaml/js_of_ocaml.ml | 1 + compiler/lib/config.ml | 10 +++- compiler/lib/config.mli | 10 ++++ compiler/lib/driver.ml | 64 +++++++++++-------------- compiler/lib/eval.ml | 29 ++++++----- compiler/lib/eval.mli | 2 +- compiler/lib/inline.ml | 4 +- compiler/lib/inline.mli | 3 +- compiler/lib/specialize_js.ml | 14 +++--- compiler/lib/specialize_js.mli | 2 +- 10 files changed, 75 insertions(+), 64 deletions(-) diff --git a/compiler/bin-js_of_ocaml/js_of_ocaml.ml b/compiler/bin-js_of_ocaml/js_of_ocaml.ml index 144543663c..b6db162a15 100644 --- a/compiler/bin-js_of_ocaml/js_of_ocaml.ml +++ b/compiler/bin-js_of_ocaml/js_of_ocaml.ml @@ -22,6 +22,7 @@ open! Js_of_ocaml_compiler.Stdlib open Js_of_ocaml_compiler let () = + Config.set_target `JavaScript; Sys.catch_break true; let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in let argv = diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 9385a063ba..7865b6fd33 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -164,7 +164,7 @@ module Param = struct p ~name:"tc" ~desc:"Set tailcall optimisation" - (enum [ "trampoline", TcTrampoline; (* default *) "none", TcNone ]) + (enum [ "trampoline", TcTrampoline (* default *); "none", TcNone ]) let lambda_lifting_threshold = (* When we reach this depth, we start looking for functions to be lifted *) @@ -180,3 +180,11 @@ module Param = struct ~desc:"Set baseline for lifting deeply nested functions" (int 1) end + +(****) + +let target_ : [ `JavaScript | `Wasm ] ref = ref `JavaScript + +let target () = !target_ + +let set_target t = target_ := t diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index e4c86d37b0..d3e38e9e95 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -80,6 +80,7 @@ module Flag : sig val disable : string -> unit end +(** This module contains parameters that may be modified through command-line flags. *) module Param : sig val set : string -> string -> unit @@ -104,3 +105,12 @@ module Param : sig val lambda_lifting_baseline : unit -> int end + +(****) + +(** {2 Parameters that are constant across a program run} *) + +(** These parameters should be set at most once at the beginning of the program. *) + +val target : unit -> [ `JavaScript | `Wasm ] +val set_target : [ `JavaScript | `Wasm ] -> unit diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 3454a23289..17953d0e61 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -44,35 +44,35 @@ let deadcode p = let r, _ = deadcode' p in r -let inline ~target p = +let inline p = if Config.Flag.inline () && Config.Flag.deadcode () then ( let p, live_vars = deadcode' p in if debug () then Format.eprintf "Inlining...@."; - Inline.f ~target p live_vars) + Inline.f p live_vars) else p let specialize_1 (p, info) = if debug () then Format.eprintf "Specialize...@."; Specialize.f ~function_arity:(fun f -> Specialize.function_arity info f) p -let specialize_js ~target (p, info) = +let specialize_js (p, info) = if debug () then Format.eprintf "Specialize js...@."; - Specialize_js.f ~target info p + Specialize_js.f info p let specialize_js_once p = if debug () then Format.eprintf "Specialize js once...@."; Specialize_js.f_once p -let specialize' ~target (p, info) = +let specialize' (p, info) = let p = specialize_1 (p, info) in - let p = specialize_js ~target (p, info) in + let p = specialize_js (p, info) in p, info -let specialize ~target p = fst (specialize' ~target p) +let specialize p = fst (specialize' p) -let eval ~target (p, info) = - if Config.Flag.staticeval () then Eval.f ~target info p else p +let eval (p, info) = + if Config.Flag.staticeval () then Eval.f info p else p let flow p = if debug () then Format.eprintf "Data flow...@."; @@ -144,53 +144,53 @@ let identity x = x (* o1 *) -let o1 ~target : 'a -> 'a = +let o1 : 'a -> 'a = print +> tailcall +> flow_simple (* flow simple to keep information for future tailcall opt *) - +> specialize' ~target - +> eval ~target - +> inline ~target (* inlining may reveal new tailcall opt *) + +> specialize' + +> eval + +> inline (* inlining may reveal new tailcall opt *) +> deadcode +> tailcall +> phi +> flow - +> specialize' ~target - +> eval ~target - +> inline ~target + +> specialize' + +> eval + +> inline +> deadcode +> print +> flow - +> specialize' ~target - +> eval ~target - +> inline ~target + +> specialize' + +> eval + +> inline +> deadcode +> phi +> flow - +> specialize ~target + +> specialize +> identity (* o2 *) -let o2 ~target : 'a -> 'a = loop 10 "o1" (o1 ~target) 1 +> print +let o2 : 'a -> 'a = loop 10 "o1" o1 1 +> print (* o3 *) -let round1 ~target : 'a -> 'a = +let round1 : 'a -> 'a = print +> tailcall - +> inline ~target (* inlining may reveal new tailcall opt *) + +> inline (* inlining may reveal new tailcall opt *) +> deadcode (* deadcode required before flow simple -> provided by constant *) +> flow_simple (* flow simple to keep information for future tailcall opt *) - +> specialize' ~target - +> eval ~target + +> specialize' + +> eval +> identity -let round2 ~target = flow +> specialize' ~target +> eval ~target +> deadcode +> o1 ~target +let round2 = flow +> specialize' +> eval +> deadcode +> o1 -let o3 ~target = - loop 10 "tailcall+inline" (round1 ~target) 1 - +> loop 10 "flow" (round2 ~target) 1 +let o3 = + loop 10 "tailcall+inline" round1 1 + +> loop 10 "flow" round2 1 +> print let generate @@ -668,11 +668,6 @@ type 'a target = : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t) target -let target_flag (type a) (t : a target) = - match t with - | JavaScript _ -> `JavaScript - | Wasm -> `Wasm - let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p = let export_runtime = match link with @@ -705,7 +700,6 @@ let full | O1 -> o1 | O2 -> o2 | O3 -> o3) - ~target:(target_flag target) +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal +> map_fst diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 754fe65f45..53417ab2ea 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -108,7 +108,7 @@ module type Int = sig val shift_op : (constant list) -> (t -> int -> t) -> constant option end -let eval_prim ~target x = +let eval_prim x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) | Lt, [ Int i; Int j ] -> bool Int32.(i < j) @@ -119,7 +119,7 @@ let eval_prim ~target x = | Extern name, l -> ( let name = Primitive.resolve name in let (module Int : Int) = - match target with + match Config.target () with | `JavaScript -> (module Int32) | `Wasm -> (module Int31) in @@ -185,7 +185,7 @@ let eval_prim ~target x = | "caml_sys_const_int_size", [ _ ] -> Some (Int - (match target with + (match Config.target () with | `JavaScript -> 32l | `Wasm -> 31l)) | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) @@ -214,7 +214,7 @@ type is_int = | N | Unknown -let is_int ~target info x = +let is_int info x = match x with | Pv x -> get_approx @@ -223,7 +223,7 @@ let is_int ~target info x = match Flow.Info.def info x with | Some (Constant (Int _)) -> Y | Some (Constant (NativeInt _ | Int32 _)) -> - assert (Poly.equal target `Wasm); + assert (Poly.equal (Config.target ()) `Wasm); N | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) @@ -236,7 +236,7 @@ let is_int ~target info x = x | Pc (Int _) -> Y | Pc (NativeInt _ | Int32 _) -> - assert (Poly.equal target `Wasm); + assert (Poly.equal (Config.target ()) `Wasm); N | Pc _ -> N @@ -308,7 +308,7 @@ let constant_js_equal a b = | Tuple _, _ | _, Tuple _ -> None -let eval_instr info ~target ((x, loc) as i) = +let eval_instr info ((x, loc) as i) = match x with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( match the_const_of info y, the_const_of info z with @@ -365,7 +365,7 @@ let eval_instr info ~target ((x, loc) as i) = below fail. *) [ i ] | Let (x, Prim (IsInt, [ y ])) -> ( - match is_int ~target info y with + match is_int info y with | Unknown -> [ i ] | (Y | N) as b -> let c = Constant (bool' Poly.(b = Y)) in @@ -381,7 +381,7 @@ let eval_instr info ~target ((x, loc) as i) = | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in let backend_name = - match target with + match Config.target () with | `JavaScript -> "js_of_ocaml" | `Wasm -> "wasm_of_ocaml" in @@ -398,7 +398,6 @@ let eval_instr info ~target ((x, loc) as i) = | _ -> false) then eval_prim - ~target ( prim , List.map prim_args' ~f:(function | Some c -> c @@ -416,7 +415,7 @@ let eval_instr info ~target ((x, loc) as i) = , Prim ( prim , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> - match c, target with + match c, Config.target () with | ( Some ((Int _ | Int32 _ | NativeInt _ | NativeString _) as c) , _ ) -> Pc c | Some (Float _ as c), `JavaScript -> Pc c @@ -547,15 +546,15 @@ let drop_exception_handler blocks = blocks blocks -let eval ~target info blocks = +let eval info blocks = Addr.Map.map (fun block -> - let body = List.concat_map block.body ~f:(eval_instr ~target info) in + let body = List.concat_map block.body ~f:(eval_instr info) in let branch = eval_branch info block.branch in { block with Code.body; Code.branch }) blocks -let f ~target info p = - let blocks = eval ~target info p.blocks in +let f info p = + let blocks = eval info p.blocks in let blocks = drop_exception_handler blocks in { p with blocks } diff --git a/compiler/lib/eval.mli b/compiler/lib/eval.mli index bb3edd1238..e5d689e29f 100644 --- a/compiler/lib/eval.mli +++ b/compiler/lib/eval.mli @@ -21,4 +21,4 @@ val clear_static_env : unit -> unit val set_static_env : string -> string -> unit -val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program +val f : Flow.Info.t -> Code.program -> Code.program diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index edcc626477..e6707e50d5 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -322,9 +322,9 @@ let inline ~first_class_primitives live_vars closures name pc (outer, p) = let times = Debug.find "times" -let f ~target p live_vars = +let f p live_vars = let first_class_primitives = - match target with + match Config.target () with | `JavaScript -> not (Config.Flag.effects ()) | `Wasm -> false in diff --git a/compiler/lib/inline.mli b/compiler/lib/inline.mli index 2bc18bc4f2..9799e882a2 100644 --- a/compiler/lib/inline.mli +++ b/compiler/lib/inline.mli @@ -18,5 +18,4 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val f : - target:[ `JavaScript | `Wasm ] -> Code.program -> Deadcode.variable_uses -> Code.program +val f : Code.program -> Deadcode.variable_uses -> Code.program diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index f5aa3b45fa..162b877582 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -22,8 +22,8 @@ open! Stdlib open Code open Flow -let specialize_instr ~target info i = - match i, target with +let specialize_instr info i = + match i, Config.target () with | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( match the_string_of info y with | Some "%d" -> ( @@ -156,7 +156,7 @@ let equal3 a b c = Code.Var.equal a b && Code.Var.equal b c let equal4 a b c d = Code.Var.equal a b && Code.Var.equal b c && Code.Var.equal c d -let specialize_instrs ~target info l = +let specialize_instrs info l = let rec aux info checks l acc = match l with | [] -> List.rev acc @@ -285,22 +285,22 @@ let specialize_instrs ~target info l = in aux info ((y, idx) :: checks) r acc | _ -> - let i = specialize_instr ~target info i in + let i = specialize_instr info i in aux info checks r ((i, loc) :: acc)) in aux info [] l [] -let specialize_all_instrs ~target info p = +let specialize_all_instrs info p = let blocks = Addr.Map.map - (fun block -> { block with Code.body = specialize_instrs ~target info block.body }) + (fun block -> { block with Code.body = specialize_instrs info block.body }) p.blocks in { p with blocks } (****) -let f ~target info p = specialize_all_instrs ~target info p +let f info p = specialize_all_instrs info p let f_once p = let rec loop acc l = diff --git a/compiler/lib/specialize_js.mli b/compiler/lib/specialize_js.mli index d82ef29162..b3904c8cb2 100644 --- a/compiler/lib/specialize_js.mli +++ b/compiler/lib/specialize_js.mli @@ -18,6 +18,6 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program +val f : Flow.Info.t -> Code.program -> Code.program val f_once : Code.program -> Code.program