From 4a28c27e7297e94e6c0faa3e6c7b6a640ceab4a4 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 7 Jun 2024 14:25:28 +0200 Subject: [PATCH] Target-specific code --- compiler/bin-js_of_ocaml/build_fs.ml | 2 +- compiler/bin-js_of_ocaml/compile.ml | 10 +- compiler/lib/driver.ml | 144 ++++++++++++------- compiler/lib/driver.mli | 19 ++- compiler/lib/eval.ml | 97 +++++++++---- compiler/lib/eval.mli | 2 +- compiler/lib/inline.ml | 13 +- compiler/lib/inline.mli | 3 +- compiler/lib/link_js.ml | 8 +- compiler/lib/linker.ml | 27 ++-- compiler/lib/linker.mli | 12 +- compiler/lib/ocaml_compiler.ml | 17 ++- compiler/lib/ocaml_compiler.mli | 3 +- compiler/lib/parse_bytecode.ml | 204 ++++++++++++++++++--------- compiler/lib/parse_bytecode.mli | 14 +- compiler/lib/specialize_js.ml | 61 ++++---- compiler/lib/specialize_js.mli | 2 +- 17 files changed, 424 insertions(+), 214 deletions(-) diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml index 94fb9916cc..84ed7fb55d 100644 --- a/compiler/bin-js_of_ocaml/build_fs.ml +++ b/compiler/bin-js_of_ocaml/build_fs.ml @@ -75,10 +75,10 @@ function jsoo_create_file_extern(name,content){ let pfs_fmt = Pretty_print.to_out_channel chan in let (_ : Source_map.t option) = Driver.f + ~target:(JavaScript pfs_fmt) ~standalone:true ~wrap_with_fun:`Iife ~link:`Needed - pfs_fmt (Parse_bytecode.Debug.create ~include_cmis:false false) code in diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 3e01a30974..8e2f1b812a 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -196,12 +196,12 @@ let run in let code = Code.prepend one.code instr in Driver.f + ~target:(JavaScript fmt) ~standalone ?profile ~link ~wrap_with_fun ?source_map - fmt one.debug code | `File, fmt -> @@ -220,12 +220,12 @@ let run let code = Code.prepend one.code instr in let res = Driver.f + ~target:(JavaScript fmt) ~standalone ?profile ~link ~wrap_with_fun ?source_map - fmt one.debug code in @@ -285,7 +285,7 @@ let run | `None -> let prims = Linker.list_all () |> StringSet.elements in assert (List.length prims > 0); - let code, uinfo = Parse_bytecode.predefined_exceptions () in + let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`JavaScript in let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in let code : Parse_bytecode.one = { code @@ -331,6 +331,7 @@ let run let linkall = linkall || toplevel || dynlink in let code = Parse_bytecode.from_exe + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~link_info:(toplevel || dynlink) @@ -363,6 +364,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -419,6 +421,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -450,6 +453,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 6c638469ee..3454a23289 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -44,34 +44,35 @@ let deadcode p = let r, _ = deadcode' p in r -let inline p = +let inline ~target p = if Config.Flag.inline () && Config.Flag.deadcode () then ( let p, live_vars = deadcode' p in if debug () then Format.eprintf "Inlining...@."; - Inline.f p live_vars) + Inline.f ~target 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 (p, info) = +let specialize_js ~target (p, info) = if debug () then Format.eprintf "Specialize js...@."; - Specialize_js.f info p + Specialize_js.f ~target info p let specialize_js_once p = if debug () then Format.eprintf "Specialize js once...@."; Specialize_js.f_once p -let specialize' (p, info) = +let specialize' ~target (p, info) = let p = specialize_1 (p, info) in - let p = specialize_js (p, info) in + let p = specialize_js ~target (p, info) in p, info -let specialize p = fst (specialize' p) +let specialize ~target p = fst (specialize' ~target p) -let eval (p, info) = if Config.Flag.staticeval () then Eval.f info p else p +let eval ~target (p, info) = + if Config.Flag.staticeval () then Eval.f ~target info p else p let flow p = if debug () then Format.eprintf "Data flow...@."; @@ -143,51 +144,54 @@ let identity x = x (* o1 *) -let o1 : 'a -> 'a = +let o1 ~target : 'a -> 'a = print +> tailcall +> flow_simple (* flow simple to keep information for future tailcall opt *) - +> specialize' - +> eval - +> inline (* inlining may reveal new tailcall opt *) + +> specialize' ~target + +> eval ~target + +> inline ~target (* inlining may reveal new tailcall opt *) +> deadcode +> tailcall +> phi +> flow - +> specialize' - +> eval - +> inline + +> specialize' ~target + +> eval ~target + +> inline ~target +> deadcode +> print +> flow - +> specialize' - +> eval - +> inline + +> specialize' ~target + +> eval ~target + +> inline ~target +> deadcode +> phi +> flow - +> specialize + +> specialize ~target +> identity (* o2 *) -let o2 : 'a -> 'a = loop 10 "o1" o1 1 +> print +let o2 ~target : 'a -> 'a = loop 10 "o1" (o1 ~target) 1 +> print (* o3 *) -let round1 : 'a -> 'a = +let round1 ~target : 'a -> 'a = print +> tailcall - +> inline (* inlining may reveal new tailcall opt *) + +> inline ~target (* 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' - +> eval + +> specialize' ~target + +> eval ~target +> identity -let round2 = flow +> specialize' +> eval +> deadcode +> o1 +let round2 ~target = flow +> specialize' ~target +> eval ~target +> deadcode +> o1 ~target -let o3 = loop 10 "tailcall+inline" round1 1 +> loop 10 "flow" round2 1 +> print +let o3 ~target = + loop 10 "tailcall+inline" (round1 ~target) 1 + +> loop 10 "flow" (round2 ~target) 1 + +> print let generate d @@ -658,13 +662,39 @@ let configure formatter = Code.Var.set_pretty (pretty && not (Config.Flag.shortvar ())); Code.Var.set_stable (Config.Flag.stable_var ()) -let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p = - let exported_runtime = not standalone in +type 'a target = + | JavaScript : Pretty_print.t -> Source_map.t option target + | Wasm + : (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 | `All | `All_from _ -> true | `Needed | `No -> false in + p + |> link' ~export_runtime ~standalone ~link + |> pack ~wrap_with_fun ~standalone + |> coloring + |> check_js + +let full + (type result) + ~(target : result target) + ~standalone + ~wrap_with_fun + ~profile + ~link + ~source_map + d + p : result = let deadcode_sentinal = (* If deadcode is disabled, this field is just fresh variable *) Code.Var.fresh_n "undef" @@ -675,58 +705,74 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p = | O1 -> o1 | O2 -> o2 | O3 -> o3) + ~target:(target_flag target) +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal - +> map_fst (if Config.Flag.effects () then fun x -> x else Generate_closure.f) + +> map_fst + (match target with + | JavaScript _ -> if Config.Flag.effects () then Fun.id else Generate_closure.f + | Wasm -> Fun.id) +> map_fst deadcode' in - let emit = - generate - d - ~exported_runtime - ~wrap_with_fun - ~warn_on_unhandled_effect:standalone - ~deadcode_sentinal - +> link' ~export_runtime ~standalone ~link - +> pack ~wrap_with_fun ~standalone - +> coloring - +> check_js - +> output formatter ~source_map () - in if times () then Format.eprintf "Start Optimizing...@."; let t = Timer.make () in let r = opt p in let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in - emit r + match target with + | JavaScript formatter -> + let exported_runtime = not standalone in + let emit formatter = + generate + d + ~exported_runtime + ~wrap_with_fun + ~warn_on_unhandled_effect:standalone + ~deadcode_sentinal + +> link_and_pack ~standalone ~wrap_with_fun ~link + +> output formatter ~source_map () + in + let source_map = emit formatter r in + source_map + | Wasm -> + let (p, live_vars), _, in_cps = r in + live_vars, in_cps, p, d -let full_no_source_map ~standalone ~wrap_with_fun ~profile ~link formatter d p = +let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p = let (_ : Source_map.t option) = - full ~standalone ~wrap_with_fun ~profile ~link ~source_map:None formatter d p + full + ~target:(JavaScript formatter) + ~standalone + ~wrap_with_fun + ~profile + ~link + ~source_map:None + d + p in () let f + ~target ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link ?source_map - formatter d p = - full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p + full ~target ~standalone ~wrap_with_fun ~profile ~link ~source_map d p let f' ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link formatter d p = - full_no_source_map ~standalone ~wrap_with_fun ~profile ~link formatter d p + full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p let from_string ~prims ~debug s formatter = let p, d = Parse_bytecode.from_string ~prims ~debug s in full_no_source_map + ~formatter ~standalone:false ~wrap_with_fun:`Anonymous ~profile:O1 ~link:`No - formatter d p diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli index f4562f59e7..1b9eaa616a 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -20,16 +20,22 @@ type profile +type 'a target = + | JavaScript : Pretty_print.t -> Source_map.t option target + | Wasm + : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t) + target + val f : - ?standalone:bool + target:'result target + -> ?standalone:bool -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ] -> ?profile:profile -> link:[ `All | `All_from of string list | `Needed | `No ] -> ?source_map:Source_map.t - -> Pretty_print.t -> Parse_bytecode.Debug.t -> Code.program - -> Source_map.t option + -> 'result val f' : ?standalone:bool @@ -48,6 +54,13 @@ val from_string : -> Pretty_print.t -> unit +val link_and_pack : + ?standalone:bool + -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ] + -> ?link:[ `All | `All_from of string list | `Needed | `No ] + -> Javascript.statement_list + -> Javascript.statement_list + val configure : Pretty_print.t -> unit val profiles : (int * profile) list diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 24c8dbb5ad..a2719bda69 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -31,14 +31,14 @@ let get_static_env s = try Some (Hashtbl.find static_env s) with Not_found -> No module Int = Int32 -let int_binop l f = +let int_binop l w f = match l with - | [ Int i; Int j ] -> Some (Int (f i j)) + | [ Int i; Int j ] -> Some (Int (w (f i j))) | _ -> None -let shift l f = +let shift l w t f = match l with - | [ Int i; Int j ] -> Some (Int (f i (Int32.to_int j land 0x1f))) + | [ Int i; Int j ] -> Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) | _ -> None let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option = @@ -74,7 +74,7 @@ let float_binop_bool l f = | Some b -> bool b | None -> None -let eval_prim x = +let eval_prim ~target x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) | Lt, [ Int i; Int j ] -> bool Int32.(i < j) @@ -84,20 +84,32 @@ let eval_prim x = | Ult, [ Int i; Int j ] -> bool (Int32.(j < 0l) || Int32.(i < j)) | Extern name, l -> ( let name = Primitive.resolve name in + let wrap = + match target with + | `JavaScript -> fun i -> i + | `Wasm -> Int31.wrap + in match name, l with (* int *) - | "%int_add", _ -> int_binop l Int.add - | "%int_sub", _ -> int_binop l Int.sub - | "%direct_int_mul", _ -> int_binop l Int.mul + | "%int_add", _ -> int_binop l wrap Int.add + | "%int_sub", _ -> int_binop l wrap Int.sub + | "%direct_int_mul", _ -> int_binop l wrap Int.mul | "%direct_int_div", [ _; Int 0l ] -> None - | "%direct_int_div", _ -> int_binop l Int.div - | "%direct_int_mod", _ -> int_binop l Int.rem - | "%int_and", _ -> int_binop l Int.logand - | "%int_or", _ -> int_binop l Int.logor - | "%int_xor", _ -> int_binop l Int.logxor - | "%int_lsl", _ -> shift l Int.shift_left - | "%int_lsr", _ -> shift l Int.shift_right_logical - | "%int_asr", _ -> shift l Int.shift_right + | "%direct_int_div", _ -> int_binop l wrap Int.div + | "%direct_int_mod", _ -> int_binop l wrap Int.rem + | "%int_and", _ -> int_binop l wrap Int.logand + | "%int_or", _ -> int_binop l wrap Int.logor + | "%int_xor", _ -> int_binop l wrap Int.logxor + | "%int_lsl", _ -> shift l wrap Fun.id Int.shift_left + | "%int_lsr", _ -> + shift + l + wrap + (match target with + | `JavaScript -> Fun.id + | `Wasm -> fun i -> Int.logand i 0x7fffffffl) + Int.shift_right_logical + | "%int_asr", _ -> shift l wrap Fun.id Int.shift_right | "%int_neg", [ Int i ] -> Some (Int (Int.neg i)) (* float *) | "caml_eq_float", _ -> float_binop_bool l Float.( = ) @@ -143,7 +155,12 @@ let eval_prim x = | Some env -> Some (String env) | None -> None) | "caml_sys_const_word_size", [ _ ] -> Some (Int 32l) - | "caml_sys_const_int_size", [ _ ] -> Some (Int 32l) + | "caml_sys_const_int_size", [ _ ] -> + Some + (Int + (match target with + | `JavaScript -> 32l + | `Wasm -> 31l)) | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int 0l) | _ -> None) @@ -170,7 +187,7 @@ type is_int = | N | Unknown -let is_int info x = +let is_int ~target info x = match x with | Pv x -> get_approx @@ -178,6 +195,10 @@ let is_int info x = (fun x -> match Flow.Info.def info x with | Some (Constant (Int _)) -> Y + | Some (Constant (NativeInt _ | Int32 _)) -> ( + match target with + | `JavaScript -> Y + | `Wasm -> N) | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) Unknown @@ -188,6 +209,10 @@ let is_int info x = | _ -> Unknown) x | Pc (Int _) -> Y + | Pc (NativeInt _ | Int32 _) -> ( + match target with + | `JavaScript -> Y + | `Wasm -> N) | Pc _ -> N let the_tag_of info x get = @@ -258,7 +283,7 @@ let constant_js_equal a b = | Tuple _, _ | _, Tuple _ -> None -let eval_instr info ((x, loc) as i) = +let eval_instr info ~target ((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 @@ -315,7 +340,7 @@ let eval_instr info ((x, loc) as i) = below fail. *) [ i ] | Let (x, Prim (IsInt, [ y ])) -> ( - match is_int info y with + match is_int ~target info y with | Unknown -> [ i ] | (Y | N) as b -> let c = Constant (bool' Poly.(b = Y)) in @@ -330,7 +355,14 @@ let eval_instr info ((x, loc) as i) = | None -> [ i ]) | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in - [ Let (jsoo, Constant (String "js_of_ocaml")), noloc + [ ( Let + ( jsoo + , Constant + (String + (match target with + | `JavaScript -> "js_of_ocaml" + | `Wasm -> "wasm_of_ocaml")) ) + , noloc ) ; Let (x, Block (0, [| jsoo |], NotArray, Immutable)), loc ] | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) -> @@ -343,6 +375,7 @@ let eval_instr info ((x, loc) as i) = | _ -> false) then eval_prim + ~target ( prim , List.map prim_args' ~f:(function | Some c -> c @@ -359,14 +392,16 @@ let eval_instr info ((x, loc) as i) = ( x , Prim ( prim - , List.map2 prim_args prim_args' ~f:(fun arg c -> - match c with - | Some ((Int _ | Float _ | NativeString _) as c) -> Pc c - | Some (String _ as c) when Config.Flag.use_js_string () -> Pc c - | Some _ + , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> + match c, target with + | Some ((Int _ | NativeString _) as c), _ -> Pc c + | Some (Float _ as c), `JavaScript -> Pc c + | Some (String _ as c), `JavaScript + when Config.Flag.use_js_string () -> Pc c + | Some _, _ (* do not be duplicated other constant as they're not represented with constant in javascript. *) - | None -> arg) ) ) + | None, _ -> arg) ) ) , loc ) ]) | _ -> [ i ] @@ -488,15 +523,15 @@ let drop_exception_handler blocks = blocks blocks -let eval info blocks = +let eval ~target info blocks = Addr.Map.map (fun block -> - let body = List.concat_map block.body ~f:(eval_instr info) in + let body = List.concat_map block.body ~f:(eval_instr ~target info) in let branch = eval_branch info block.branch in { block with Code.body; Code.branch }) blocks -let f info p = - let blocks = eval info p.blocks in +let f ~target info p = + let blocks = eval ~target 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 e5d689e29f..bb3edd1238 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 : Flow.Info.t -> Code.program -> Code.program +val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index c6e8dd4b8e..edcc626477 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -167,7 +167,7 @@ let rec args_equal xs ys = | x :: xs, Pv y :: ys -> Code.Var.compare x y = 0 && args_equal xs ys | _ -> false -let inline live_vars closures name pc (outer, p) = +let inline ~first_class_primitives live_vars closures name pc (outer, p) = let block = Addr.Map.find pc p.blocks in let body, (outer, branch, p) = List.fold_right @@ -300,7 +300,7 @@ let inline live_vars closures name pc (outer, p) = , (outer, (Branch (fresh_addr, args), No), { p with blocks; free_pc }) ) | _ -> i :: rem, state) - | Let (x, Closure (l, (pc, []))), loc when not (Config.Flag.effects ()) -> ( + | Let (x, Closure (l, (pc, []))), loc when first_class_primitives -> ( let block = Addr.Map.find pc p.blocks in match block with | { body = [ (Let (y, Prim (Extern prim, args)), _loc) ] @@ -322,7 +322,12 @@ let inline live_vars closures name pc (outer, p) = let times = Debug.find "times" -let f p live_vars = +let f ~target p live_vars = + let first_class_primitives = + match target with + | `JavaScript -> not (Config.Flag.effects ()) + | `Wasm -> false + in Code.invariant p; let t = Timer.make () in let closures = get_closures p in @@ -333,7 +338,7 @@ let f p live_vars = let traverse outer = Code.traverse { fold = Code.fold_children } - (inline live_vars closures name) + (inline ~first_class_primitives live_vars closures name) pc p.blocks (outer, p) diff --git a/compiler/lib/inline.mli b/compiler/lib/inline.mli index 9799e882a2..2bc18bc4f2 100644 --- a/compiler/lib/inline.mli +++ b/compiler/lib/inline.mli @@ -18,4 +18,5 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val f : Code.program -> Deadcode.variable_uses -> Code.program +val f : + target:[ `JavaScript | `Wasm ] -> Code.program -> Deadcode.variable_uses -> Code.program diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index e4d3d2989e..4fa3778fb9 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -412,7 +412,13 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source List.fold_left units ~init:StringSet.empty ~f:(fun acc (u : Unit_info.t) -> StringSet.union acc (StringSet.of_list u.primitives)) in - let code = Parse_bytecode.link_info ~symbols:!sym ~primitives ~crcs:[] in + let code = + Parse_bytecode.link_info + ~target:`JavaScript + ~symbols:!sym + ~primitives + ~crcs:[] + in let b = Buffer.create 100 in let fmt = Pretty_print.to_buffer b in Driver.configure fmt; diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index fa50703f8a..8195a7cb98 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -437,7 +437,7 @@ let list_all ?from () = provided StringSet.empty -let load_fragment ~target_env ~filename (f : Fragment.t) = +let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.t) = match f with | Always_include code -> always_included := @@ -482,9 +482,11 @@ let load_fragment ~target_env ~filename (f : Fragment.t) = filename; if always then ( - always_included := - { ar_filename = filename; ar_program = code; ar_requires = requires } - :: !always_included; + if not ignore_always_annotation + then + always_included := + { ar_filename = filename; ar_program = code; ar_requires = requires } + :: !always_included; `Ok) else error @@ -586,19 +588,24 @@ let check_deps () = ()) code_pieces -let load_file ~target_env filename = +let load_file ~ignore_always_annotation ~target_env filename = List.iter (Fragment.parse_file filename) ~f:(fun frag -> - let (`Ok | `Ignored) = load_fragment ~target_env ~filename frag in + let (`Ok | `Ignored) = + load_fragment ~ignore_always_annotation ~target_env ~filename frag + in ()) -let load_fragments ~target_env ~filename l = +let load_fragments ?(ignore_always_annotation = false) ~target_env ~filename l = List.iter l ~f:(fun frag -> - let (`Ok | `Ignored) = load_fragment ~target_env ~filename frag in + let (`Ok | `Ignored) = + load_fragment ~ignore_always_annotation ~target_env ~filename frag + in ()); check_deps () -let load_files ~target_env l = - List.iter l ~f:(fun filename -> load_file ~target_env filename); +let load_files ?(ignore_always_annotation = false) ~target_env l = + List.iter l ~f:(fun filename -> + load_file ~ignore_always_annotation ~target_env filename); check_deps () (* resolve *) diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli index b7d49194c7..246b959403 100644 --- a/compiler/lib/linker.mli +++ b/compiler/lib/linker.mli @@ -36,9 +36,15 @@ end val reset : unit -> unit -val load_files : target_env:Target_env.t -> string list -> unit - -val load_fragments : target_env:Target_env.t -> filename:string -> Fragment.t list -> unit +val load_files : + ?ignore_always_annotation:bool -> target_env:Target_env.t -> string list -> unit + +val load_fragments : + ?ignore_always_annotation:bool + -> target_env:Target_env.t + -> filename:string + -> Fragment.t list + -> unit val check_deps : unit -> unit diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 12fcb3ab63..8d0cd1dba3 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -18,11 +18,15 @@ open! Stdlib -let rec constant_of_const : _ -> Code.constant = +let rec constant_of_const ~target c : Code.constant = let open Lambda in let open Asttypes in - function - | Const_base (Const_int i) -> Int (Int32.of_int_warning_on_overflow i) + match c with + | Const_base (Const_int i) -> + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.of_int_warning_on_overflow i) | Const_base (Const_char c) -> Int (Int32.of_int (Char.code c)) | ((Const_base (Const_string (s, _))) [@if ocaml_version < (4, 11, 0)]) | ((Const_base (Const_string (s, _, _))) [@if ocaml_version >= (4, 11, 0)]) -> String s @@ -35,9 +39,12 @@ let rec constant_of_const : _ -> Code.constant = let l = List.map ~f:(fun f -> float_of_string f) sl in Float_array (Array.of_list l) | ((Const_pointer i) [@if ocaml_version < (4, 12, 0)]) -> - Int (Int32.of_int_warning_on_overflow i) + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.of_int_warning_on_overflow i) | Const_block (tag, l) -> - let l = Array.of_list (List.map l ~f:constant_of_const) in + let l = Array.of_list (List.map l ~f:(fun c -> constant_of_const ~target c)) in Tuple (tag, l, Unknown) let rec find_loc_in_summary ident' = function diff --git a/compiler/lib/ocaml_compiler.mli b/compiler/lib/ocaml_compiler.mli index 227f1b9f31..409381a562 100644 --- a/compiler/lib/ocaml_compiler.mli +++ b/compiler/lib/ocaml_compiler.mli @@ -16,7 +16,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val constant_of_const : Lambda.structured_constant -> Code.constant +val constant_of_const : + target:[ `JavaScript | `Wasm ] -> Lambda.structured_constant -> Code.constant val find_loc_in_summary : Ident.t -> Env.summary -> Location.t option diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 18ef20b8df..d191ac231f 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -443,7 +443,7 @@ end (* Parse constants *) module Constants : sig - val parse : Obj.t -> Code.constant + val parse : target:[ `JavaScript | `Wasm ] -> Obj.t -> Code.constant val inlined : Code.constant -> bool end = struct @@ -477,7 +477,7 @@ end = struct let ident_native = ident_of_custom (Obj.repr 0n) - let rec parse x = + let rec parse ~target x = if Obj.is_block x then let tag = Obj.tag x in @@ -503,11 +503,17 @@ end = struct | None -> assert false else if tag < Obj.no_scan_tag then - Tuple (tag, Array.init (Obj.size x) ~f:(fun i -> parse (Obj.field x i)), Unknown) + Tuple + ( tag + , Array.init (Obj.size x) ~f:(fun i -> parse ~target (Obj.field x i)) + , Unknown ) else assert false else let i : int = Obj.magic x in - Int (Int32.of_int_warning_on_overflow i) + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.of_int_warning_on_overflow i) let inlined = function | String _ | NativeString _ -> false @@ -763,8 +769,25 @@ let access_global g i = g.vars.(i) <- Some x; x -let register_global ?(force = false) g i loc rem = - if force || g.is_exported.(i) +let register_global ~target ?(force = false) g i loc rem = + if g.is_exported.(i) + && + match target with + | `Wasm -> true + | `JavaScript -> false + then ( + let name = + match g.named_value.(i) with + | None -> assert false + | Some name -> name + in + Code.Var.name (access_global g i) name; + ( Let + ( Var.fresh () + , Prim (Extern "caml_set_global", [ Pc (String name); Pv (access_global g i) ]) ) + , loc ) + :: rem) + else if force || g.is_exported.(i) then let args = match g.named_value.(i) with @@ -782,25 +805,40 @@ let register_global ?(force = false) g i loc rem = :: rem else rem -let get_global state instrs i loc = +let get_global ~target state instrs i loc = State.size_globals state (i + 1); let g = State.globals state in match g.vars.(i) with | Some x -> if debug_parser () then Format.printf "(global access %a)@." Var.print x; x, State.set_accu state x loc, instrs - | None -> + | None -> ( if i < Array.length g.constants && Constants.inlined g.constants.(i) then let x, state = State.fresh_var state loc in let cst = g.constants.(i) in x, state, (Let (x, Constant cst), loc) :: instrs - else ( + else if i < Array.length g.constants + || + match target with + | `Wasm -> false + | `JavaScript -> true + then ( g.is_const.(i) <- true; let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = CONST(%d)@." Var.print x i; g.vars.(i) <- Some x; x, state, instrs) + else + match g.named_value.(i) with + | None -> assert false + | Some name -> + let x, state = State.fresh_var state loc in + if debug_parser () then Format.printf "%a = get_global(%s)@." Var.print x name; + ( x + , state + , (Let (x, Prim (Extern "caml_get_global", [ Pc (String name) ])), loc) + :: instrs )) let tagged_blocks = ref Addr.Map.empty @@ -815,6 +853,7 @@ type compile_info = ; code : string ; limit : int ; debug : Debug.t + ; target : [ `JavaScript | `Wasm ] } let string_of_addr debug_data addr = @@ -842,7 +881,7 @@ let ( ||| ) x y = | No -> y | _ -> x -let rec compile_block blocks debug_data code pc state = +let rec compile_block blocks debug_data ~target code pc state = match Addr.Map.find_opt pc !tagged_blocks with | Some old_state -> ( (* Check that the shape of the stack is compatible with the one used to compile the block *) @@ -874,7 +913,7 @@ let rec compile_block blocks debug_data code pc state = let state = State.start_block pc state in tagged_blocks := Addr.Map.add pc state !tagged_blocks; let instr, last, state' = - compile { blocks; code; limit; debug = debug_data } pc state [] + compile { blocks; code; limit; debug = debug_data; target } pc state [] in assert (not (Addr.Map.mem pc !compiled_blocks)); (* When jumping to a block that was already visited and the @@ -903,10 +942,11 @@ let rec compile_block blocks debug_data code pc state = in compiled_blocks := Addr.Map.add pc (state, List.rev instr, last) !compiled_blocks; match fst last with - | Branch (pc', _) -> compile_block blocks debug_data code pc' (adjust_state pc') + | Branch (pc', _) -> + compile_block blocks debug_data ~target code pc' (adjust_state pc') | Cond (_, (pc1, _), (pc2, _)) -> - compile_block blocks debug_data code pc1 (adjust_state pc1); - compile_block blocks debug_data code pc2 (adjust_state pc2) + compile_block blocks debug_data ~target code pc1 (adjust_state pc1); + compile_block blocks debug_data ~target code pc2 (adjust_state pc2) | Poptrap (_, _) -> () | Switch (_, _) -> () | Raise _ | Return _ | Stop -> () @@ -1248,7 +1288,7 @@ and compile infos pc state instrs = let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in - compile_block infos.blocks infos.debug code addr state'; + compile_block infos.blocks infos.debug ~target:infos.target code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let state'', _, _ = Addr.Map.find addr !compiled_blocks in @@ -1305,7 +1345,7 @@ and compile infos pc state instrs = let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in - compile_block infos.blocks infos.debug code addr state'; + compile_block infos.blocks infos.debug ~target:infos.target code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let state'', _, _ = Addr.Map.find addr !compiled_blocks in @@ -1335,16 +1375,16 @@ and compile infos pc state instrs = compile infos (pc + 2) (State.env_acc n state) instrs | GETGLOBAL -> let i = getu code (pc + 1) in - let _, state, instrs = get_global state instrs i loc in + let _, state, instrs = get_global ~target:infos.target state instrs i loc in compile infos (pc + 2) state instrs | PUSHGETGLOBAL -> let state = State.push state loc in let i = getu code (pc + 1) in - let _, state, instrs = get_global state instrs i loc in + let _, state, instrs = get_global ~target:infos.target state instrs i loc in compile infos (pc + 2) state instrs | GETGLOBALFIELD -> let i = getu code (pc + 1) in - let x, state, instrs = get_global state instrs i loc in + let x, state, instrs = get_global ~target:infos.target state instrs i loc in let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; @@ -1353,7 +1393,7 @@ and compile infos pc state instrs = let state = State.push state loc in let i = getu code (pc + 1) in - let x, state, instrs = get_global state instrs i loc in + let x, state, instrs = get_global ~target:infos.target state instrs i loc in let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; @@ -1378,7 +1418,7 @@ and compile infos pc state instrs = in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = 0@." Var.print x; - let instrs = register_global g i loc instrs in + let instrs = register_global ~target:infos.target g i loc instrs in compile infos (pc + 2) state ((Let (x, const 0l), loc) :: instrs) | ATOM0 -> let x, state = State.fresh_var state loc in @@ -1726,9 +1766,9 @@ and compile infos pc state instrs = let it = Array.init isize ~f:(fun i -> base + gets code (base + i)) in let bt = Array.init bsize ~f:(fun i -> base + gets code (base + isize + i)) in Array.iter it ~f:(fun pc' -> - compile_block infos.blocks infos.debug code pc' state); + compile_block infos.blocks infos.debug ~target:infos.target code pc' state); Array.iter bt ~f:(fun pc' -> - compile_block infos.blocks infos.debug code pc' state); + compile_block infos.blocks infos.debug ~target:infos.target code pc' state); match isize, bsize with | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, [])), loc), state | 0, _ -> @@ -1799,10 +1839,17 @@ and compile infos pc state instrs = , (handler_addr, State.stack_vars handler_state) ) , loc ) ) !compiled_blocks; - compile_block infos.blocks infos.debug code handler_addr handler_state; compile_block infos.blocks infos.debug + ~target:infos.target + code + handler_addr + handler_state; + compile_block + infos.blocks + infos.debug + ~target:infos.target code body_addr { (State.push_handler handler_ctx_state) with @@ -1820,6 +1867,7 @@ and compile infos pc state instrs = compile_block infos.blocks infos.debug + ~target:infos.target code addr (State.pop 4 (State.pop_handler state)); @@ -2503,7 +2551,7 @@ type one = ; debug : Debug.t } -let parse_bytecode code globals debug_data = +let parse_bytecode code globals debug_data ~target = let state = State.initial globals in Code.Var.reset (); let blocks = Blocks.analyse debug_data code in @@ -2518,7 +2566,7 @@ let parse_bytecode code globals debug_data = if not (Blocks.is_empty blocks') then ( let start = 0 in - compile_block blocks' debug_data code start state; + compile_block blocks' debug_data ~target code start state; let blocks = Addr.Map.mapi (fun _ (state, instr, last) -> @@ -2638,6 +2686,7 @@ type bytesections = [@@ocaml.warning "-unused-field"] let from_exe + ~target ?(includes = []) ~linkall ~link_info @@ -2651,7 +2700,7 @@ let from_exe let primitive_table = Array.of_list primitives in let code = Toc.read_code toc ic in let init_data = Toc.read_data toc ic in - let init_data = Array.map ~f:Constants.parse init_data in + let init_data = Array.map ~f:(Constants.parse ~target) init_data in let orig_symbols = Toc.read_symb toc ic in let orig_crcs = Toc.read_crcs toc ic in let keeps = @@ -2706,12 +2755,12 @@ let from_exe Ocaml_compiler.Symtable.GlobalMap.iter symbols ~f:(fun id n -> globals.named_value.(n) <- Some (Ocaml_compiler.Symtable.Global.name id); globals.is_exported.(n) <- true); - let p = parse_bytecode code globals debug_data in + let p = parse_bytecode code globals debug_data ~target in (* register predefined exception *) let body = List.fold_left predefined_exceptions ~init:[] ~f:(fun body (i, name) -> globals.named_value.(i) <- Some name; - let body = register_global ~force:true globals i noloc body in + let body = register_global ~target ~force:true globals i noloc body in globals.is_exported.(i) <- false; body) in @@ -2719,7 +2768,7 @@ let from_exe Array.fold_right_i globals.constants ~init:body ~f:(fun i _ l -> match globals.vars.(i) with | Some x when globals.is_const.(i) -> - let l = register_global globals i noloc l in + let l = register_global ~target globals i noloc l in (Let (x, Constant globals.constants.(i)), noloc) :: l | _ -> l) in @@ -2738,8 +2787,8 @@ let from_exe let gdata = Var.fresh () in let need_gdata = ref false in let infos = - [ "sections", Constants.parse (Obj.repr sections) - ; "symbols", Constants.parse (Obj.repr symbols_array) + [ "sections", Constants.parse ~target (Obj.repr sections) + ; "symbols", Constants.parse ~target (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in @@ -2830,7 +2879,7 @@ let from_bytes ~prims ~debug (code : bytecode) = t in let globals = make_globals 0 [||] prims in - let p = parse_bytecode code globals debug_data in + let p = parse_bytecode code globals debug_data ~target:`JavaScript in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let find_name i = @@ -2895,13 +2944,13 @@ module Reloc = struct let constant_of_const x = Constants.parse x [@@if ocaml_version >= (5, 1, 0)] (* We currently rely on constants to be relocated before globals. *) - let step1 t compunit code = + let step1 ~target t compunit code = if t.step2_started then assert false; let open Cmo_format in List.iter compunit.cu_primitives ~f:(fun name -> Hashtbl.add t.primitives name (Hashtbl.length t.primitives)); let slot_for_literal sc = - t.constants <- constant_of_const sc :: t.constants; + t.constants <- constant_of_const ~target sc :: t.constants; let pos = t.pos in t.pos <- succ t.pos; pos @@ -2969,16 +3018,16 @@ module Reloc = struct globals end -let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = +let from_compilation_units ~target ~includes:_ ~include_cmis ~debug_data l = let reloc = Reloc.create () in - List.iter l ~f:(fun (compunit, code) -> Reloc.step1 reloc compunit code); + List.iter l ~f:(fun (compunit, code) -> Reloc.step1 ~target reloc compunit code); List.iter l ~f:(fun (compunit, code) -> Reloc.step2 reloc compunit code); let globals = Reloc.make_globals reloc in let code = let l = List.map l ~f:(fun (_, c) -> Bytes.to_string c) in String.concat ~sep:"" l in - let prog = parse_bytecode code globals debug_data in + let prog = parse_bytecode code globals debug_data ~target in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let body = @@ -2987,7 +3036,7 @@ let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = | Some x when globals.is_const.(i) -> ( match globals.named_value.(i) with | None -> - let l = register_global globals i noloc l in + let l = register_global ~target globals i noloc l in let cst = globals.constants.(i) in (match cst, Code.Var.get_name x with | String str, None -> Code.Var.name x (Printf.sprintf "cst_%s" str) @@ -3020,7 +3069,8 @@ let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = in { code = prepend prog body; cmis; debug = debug_data } -let from_cmo ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit ic = +let from_cmo ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit ic + = let debug_data = Debug.create ~include_cmis debug in seek_in ic compunit.Cmo_format.cu_pos; let code = Bytes.create compunit.Cmo_format.cu_codesize in @@ -3031,11 +3081,13 @@ let from_cmo ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit seek_in ic compunit.Cmo_format.cu_debug; Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:0 ic); if times () then Format.eprintf " read debug events: %a@." Timer.print t; - let p = from_compilation_units ~includes ~include_cmis ~debug_data [ compunit, code ] in + let p = + from_compilation_units ~target ~includes ~include_cmis ~debug_data [ compunit, code ] + in Code.invariant p.code; p -let from_cma ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = +let from_cma ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = let debug_data = Debug.create ~include_cmis debug in let orig = ref 0 in let t = ref 0. in @@ -3054,7 +3106,7 @@ let from_cma ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = compunit, code) in if times () then Format.eprintf " read debug events: %.2f@." !t; - let p = from_compilation_units ~includes ~include_cmis ~debug_data units in + let p = from_compilation_units ~target ~includes ~include_cmis ~debug_data units in Code.invariant p.code; p @@ -3099,7 +3151,7 @@ let from_channel ic = `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) -let predefined_exceptions () = +let predefined_exceptions ~target = let body = let open Code in List.map predefined_exceptions ~f:(fun (index, name) -> @@ -3108,25 +3160,45 @@ let predefined_exceptions () = let v_name = Var.fresh () in let v_name_js = Var.fresh () in let v_index = Var.fresh () in - [ Let (v_name, Constant (String name)), noloc - ; Let (v_name_js, Constant (NativeString (Native_string.of_string name))), noloc - ; ( Let - ( v_index - , Constant - (Int - ((* Predefined exceptions are registered in - Symtable.init with [-index - 1] *) - Int32.of_int - (-index - 1))) ) - , noloc ) - ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc - ; ( Let - ( Var.fresh () - , Prim - ( Extern "caml_register_global" - , [ Pc (Int (Int32.of_int index)); Pv exn; Pv v_name_js ] ) ) - , noloc ) - ]) + [ Let (v_name, Constant (String name)), noloc ] + @ (match target with + | `Wasm -> [] + | `JavaScript -> + [ ( Let (v_name_js, Constant (NativeString (Native_string.of_string name))) + , noloc ) + ]) + @ [ ( Let + ( v_index + , Constant + (Int + ((* Predefined exceptions are registered in + Symtable.init with [-index - 1] *) + Int32.of_int + (-index - 1))) ) + , noloc ) + ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc + ; ( Let + ( Var.fresh () + , Prim + ( Extern "caml_register_global" + , [ Pc (Int (Int32.of_int index)) + ; Pv exn + ; Pv + (match target with + | `JavaScript -> v_name_js + | `Wasm -> v_name) + ] ) ) + , noloc ) + ] + @ + match target with + | `JavaScript -> [] + | `Wasm -> + [ ( Let + ( Var.fresh () + , Prim (Extern "caml_set_global", [ Pc (String name); Pv exn ]) ) + , noloc ) + ]) |> List.concat in let block = { params = []; body; branch = Stop, noloc } in @@ -3141,7 +3213,7 @@ let predefined_exceptions () = in { start = 0; blocks = Addr.Map.singleton 0 block; free_pc = 1 }, unit_info -let link_info ~symbols ~primitives ~crcs = +let link_info ~target ~symbols ~primitives ~crcs = let gdata = Code.Var.fresh_n "global_data" in let symbols_array = Ocaml_compiler.Symtable.GlobalMap.fold @@ -3159,8 +3231,8 @@ let link_info ~symbols ~primitives ~crcs = (* Include linking information *) let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in let infos = - [ "sections", Constants.parse (Obj.repr sections) - ; "symbols", Constants.parse (Obj.repr symbols_array) + [ "sections", Constants.parse ~target (Obj.repr sections) + ; "symbols", Constants.parse ~target (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (List.length primitives)) ] in diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 627f65fdd0..33edf53f1c 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -52,7 +52,8 @@ end val read_primitives : Toc.t -> in_channel -> string list val from_exe : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> linkall:bool -> link_info:bool -> include_cmis:bool @@ -62,7 +63,8 @@ val from_exe : -> one val from_cmo : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.compilation_unit @@ -70,7 +72,8 @@ val from_cmo : -> one val from_cma : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.library @@ -87,10 +90,11 @@ val from_string : -> string -> Code.program * Debug.t -val predefined_exceptions : unit -> Code.program * Unit_info.t +val predefined_exceptions : target:[ `JavaScript | `Wasm ] -> Code.program * Unit_info.t val link_info : - symbols:Ocaml_compiler.Symtable.GlobalMap.t + target:[ `JavaScript | `Wasm ] + -> symbols:Ocaml_compiler.Symtable.GlobalMap.t -> primitives:StringSet.t -> crcs:(string * Digest.t option) list -> Code.program diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 9fdce562be..f5aa3b45fa 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -22,48 +22,50 @@ open! Stdlib open Code open Flow -let specialize_instr info i = - match i with - | Let (x, Prim (Extern "caml_format_int", [ y; z ])) -> ( +let specialize_instr ~target info i = + match i, target with + | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( match the_string_of info y with | Some "%d" -> ( match the_int info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> Let (x, Prim (Extern "%caml_format_int_special", [ z ]))) | _ -> i) - | Let (x, Prim (Extern "%caml_format_int_special", [ z ])) -> ( + | Let (x, Prim (Extern "%caml_format_int_special", [ z ])), `JavaScript -> ( match the_int info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> i) (* inline the String constant argument so that generate.ml can attempt to parse it *) - | Let - ( x - , Prim - ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) - , [ (Pv _ as y) ] ) ) + | ( Let + ( x + , Prim + ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) + , [ (Pv _ as y) ] ) ) + , _ ) when Config.Flag.safe_string () -> ( match the_string_of info y with | Some s -> Let (x, Prim (Extern prim, [ Pc (String s) ])) | _ -> i) - | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])) -> ( + | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])), `JavaScript + -> ( match the_string_of info y with | Some s when Primitive.need_named_value s -> Let (x, Prim (Extern prim, [ Pc (String s); z ])) | Some _ -> Let (x, Constant (Int 0l)) | None -> i) - | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])) -> ( + | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])) -> ( + | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])) -> ( + | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> ( match the_string_of info m with | Some m when Javascript.is_ident m -> ( match the_def_of info a with @@ -78,13 +80,13 @@ let specialize_instr info i = :: Array.to_list a ) ) | _ -> i) | _ -> i) - | Let (x, Prim (Extern "caml_js_new", [ c; a ])) -> ( + | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_object", [ a ])) -> ( + | Let (x, Prim (Extern "caml_js_object", [ a ])), _ -> ( try let a = match the_def_of info a with @@ -109,43 +111,44 @@ let specialize_instr info i = in Let (x, Prim (Extern "%caml_js_opt_object", List.flatten (Array.to_list a))) with Exit -> i) - | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])) -> ( + | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_get", [ o; Pc (NativeString s) ])) | _ -> i) - | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])) -> ( + | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_set", [ o; Pc (NativeString s); v ])) | _ -> i) - | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])) -> ( + | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_delete", [ o; Pc (NativeString s) ])) | _ -> i) - | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])) -> ( + | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])), _ + -> ( match the_string_of info y with | Some s when String.is_valid_utf_8 s -> Let (x, Constant (NativeString (Native_string.of_string s))) | Some _ | None -> i) - | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])) -> ( + | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])), _ -> ( match the_string_of info y with | Some s -> Let (x, Constant (NativeString (Native_string.of_bytestring s))) | None -> i) - | Let (x, Prim (Extern "%int_mul", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_mul", [ y; z ])), `JavaScript -> ( match the_int info y, the_int info z with | Some j, _ when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _, Some j when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _ -> i) - | Let (x, Prim (Extern "%int_div", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_div", [ y; z ])), _ -> ( match the_int info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_div", [ y; z ])) | _ -> i) - | Let (x, Prim (Extern "%int_mod", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_mod", [ y; z ])), _ -> ( match the_int info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_mod", [ y; z ])) | _ -> i) - | _ -> i + | _, _ -> i let equal2 a b = Code.Var.equal a b @@ -153,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 info l = +let specialize_instrs ~target info l = let rec aux info checks l acc = match l with | [] -> List.rev acc @@ -282,22 +285,22 @@ let specialize_instrs info l = in aux info ((y, idx) :: checks) r acc | _ -> - let i = specialize_instr info i in + let i = specialize_instr ~target info i in aux info checks r ((i, loc) :: acc)) in aux info [] l [] -let specialize_all_instrs info p = +let specialize_all_instrs ~target info p = let blocks = Addr.Map.map - (fun block -> { block with Code.body = specialize_instrs info block.body }) + (fun block -> { block with Code.body = specialize_instrs ~target info block.body }) p.blocks in { p with blocks } (****) -let f info p = specialize_all_instrs info p +let f ~target info p = specialize_all_instrs ~target 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 b3904c8cb2..d82ef29162 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 : Flow.Info.t -> Code.program -> Code.program +val f : target:[ `JavaScript | `Wasm ] -> Flow.Info.t -> Code.program -> Code.program val f_once : Code.program -> Code.program