From 99c46f0dfbe4ab69b9b2bbc440a2a5ef1ded917b Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Thu, 26 Sep 2024 20:21:06 +0200 Subject: [PATCH 1/9] Compiler: nativeInt is always 32bit --- compiler/lib/code.ml | 12 ++++++------ compiler/lib/code.mli | 8 ++++---- 2 files changed, 10 insertions(+), 10 deletions(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index d9fffb4e..a05b1aef 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -284,10 +284,10 @@ type constant = | NativeString of Native_string.t | Float of float | Float_array of float array - | Int of int32 - | Int32 of int32 - | Int64 of int64 - | NativeInt of nativeint + | Int of Int32.t + | Int32 of Int32.t + | Int64 of Int64.t + | NativeInt of Int32.t (* Native int are 32bit on all known backend *) | Tuple of int * constant array * array_or_not module Constant = struct @@ -311,7 +311,7 @@ module Constant = struct !same | Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b) | Int64 a, Int64 b -> Some (Int64.equal a b) - | NativeInt a, NativeInt b -> Some (Nativeint.equal a b) + | NativeInt a, NativeInt b -> Some (Int32.equal a b) | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b) | Float a, Float b -> Some (Float.ieee_equal a b) | String _, NativeString _ | NativeString _, String _ -> None @@ -459,7 +459,7 @@ module Print = struct | Int i -> Format.fprintf f "%ld" i | Int32 i -> Format.fprintf f "%ldl" i | Int64 i -> Format.fprintf f "%LdL" i - | NativeInt i -> Format.fprintf f "%ndn" i + | NativeInt i -> Format.fprintf f "%ldn" i | Tuple (tag, a, _) -> ( Format.fprintf f "<%d>" tag; match Array.length a with diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 1c107d75..f0df91b3 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -164,10 +164,10 @@ type constant = | NativeString of Native_string.t | Float of float | Float_array of float array - | Int of int32 - | Int32 of int32 (** Only produced when compiling to WebAssembly. *) - | Int64 of int64 - | NativeInt of nativeint (** Only produced when compiling to WebAssembly. *) + | Int of Int32.t + | Int32 of Int32.t (** Only produced when compiling to WebAssembly. *) + | Int64 of Int64.t + | NativeInt of Int32.t (** Only produced when compiling to WebAssembly. *) | Tuple of int * constant array * array_or_not module Constant : sig From 2ab1d30d9f012a2173e6084ad5cd12dafd62ca96 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 27 Sep 2024 14:37:46 +0200 Subject: [PATCH 2/9] Target-specific code (#1655) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Co-authored-by: Olivier Nicole Co-authored-by: Jérôme Vouillon Co-authored-by: Hugo Heuzard --- compiler/bin-js_of_ocaml/build_fs.ml | 2 +- compiler/bin-js_of_ocaml/check_runtime.ml | 3 +- compiler/bin-js_of_ocaml/compile.ml | 7 +- compiler/bin-js_of_ocaml/link.ml | 1 + .../js_of_ocaml_compiler_dynlink.ml | 3 + compiler/lib-runtime-files/gen/gen.ml | 1 + compiler/lib/code.ml | 18 +- compiler/lib/config.ml | 14 +- compiler/lib/config.mli | 11 + compiler/lib/driver.ml | 149 ++++++------- compiler/lib/driver.mli | 22 +- compiler/lib/eval.ml | 177 ++++++++++------ compiler/lib/eval.mli | 2 +- compiler/lib/flow.ml | 33 +-- compiler/lib/inline.ml | 4 +- compiler/lib/inline.mli | 3 +- compiler/lib/ocaml_compiler.ml | 19 +- compiler/lib/parse_bytecode.ml | 198 ++++++++++-------- compiler/lib/specialize_js.ml | 14 +- compiler/lib/specialize_js.mli | 2 +- compiler/lib/stdlib.ml | 92 +++++++- compiler/tests-num/dune | 10 + compiler/tests-num/test_int31.ml | 194 +++++++++++++++++ dune-project | 1 + dune-workspace.dev | 2 +- 25 files changed, 686 insertions(+), 296 deletions(-) create mode 100644 compiler/tests-num/test_int31.ml diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml index 84ed7fb5..16ac22a2 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 + ~formatter:pfs_fmt (Parse_bytecode.Debug.create ~include_cmis:false false) code in diff --git a/compiler/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml index 14bca57e..29b54191 100644 --- a/compiler/bin-js_of_ocaml/check_runtime.ml +++ b/compiler/bin-js_of_ocaml/check_runtime.ml @@ -43,7 +43,8 @@ let print_groups output l = output_string output (Printf.sprintf "%s\n" name))) let f (runtime_files, bytecode, target_env) = - Generate.init (); + Config.set_target `JavaScript; + Linker.reset (); let runtime_files, builtin = List.partition_map runtime_files ~f:(fun name -> match Builtins.find name with diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index b456d69c..caeb1388 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -91,6 +91,7 @@ let run } = let include_cmis = toplevel && not no_cmis in let custom_header = common.Jsoo_cmdline.Arg.custom_header in + Config.set_target `JavaScript; Jsoo_cmdline.Arg.eval common; Generate.init (); (match output_file with @@ -184,7 +185,7 @@ let run let init_pseudo_fs = fs_external && standalone in let sm = match output_file with - | `Stdout, fmt -> + | `Stdout, formatter -> let instr = List.concat [ pseudo_fs_instr `create_file one.debug one.cmis @@ -200,9 +201,10 @@ let run ~link ~wrap_with_fun ?source_map + ~formatter one.debug code - | `File, fmt -> + | `File, formatter -> let fs_instr1, fs_instr2 = match fs_output with | None -> pseudo_fs_instr `create_file one.debug one.cmis, [] @@ -224,6 +226,7 @@ let run ~link ~wrap_with_fun ?source_map + ~formatter one.debug code in diff --git a/compiler/bin-js_of_ocaml/link.ml b/compiler/bin-js_of_ocaml/link.ml index 090913d2..77196797 100644 --- a/compiler/bin-js_of_ocaml/link.ml +++ b/compiler/bin-js_of_ocaml/link.ml @@ -150,6 +150,7 @@ let f ; mklib ; toplevel } = + Config.set_target `JavaScript; Jsoo_cmdline.Arg.eval common; let with_output f = match output_file with diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 9bf10680..c296919d 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -16,6 +16,9 @@ let split_primitives p = external get_section_table : unit -> (string * Obj.t) list = "caml_get_section_table" let () = + (match Sys.backend_type with + | Sys.Other "js_of_ocaml" -> Config.set_target `JavaScript + | 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 ()); diff --git a/compiler/lib-runtime-files/gen/gen.ml b/compiler/lib-runtime-files/gen/gen.ml index 3f014735..a4823998 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -47,6 +47,7 @@ let rec list_product l = let bool = [ true; false ] let () = + Js_of_ocaml_compiler.Config.set_target `JavaScript; let () = set_binary_mode_out stdout true in match Array.to_list Sys.argv with | [] -> assert false diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index a05b1aef..0bb91fff 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -816,6 +816,7 @@ let with_invariant = Debug.find "invariant" let check_defs = false let invariant { blocks; start; _ } = + let target = Config.target () in if with_invariant () then ( assert (Addr.Map.mem start blocks); @@ -830,6 +831,19 @@ let invariant { blocks; start; _ } = assert (not (Var.ISet.mem defs x)); Var.ISet.add defs x) in + let check_constant = function + | NativeInt _ | Int32 _ -> + assert ( + match target with + | `Wasm -> true + | _ -> false) + | String _ | NativeString _ | Float _ | Float_array _ | Int _ | Int64 _ + | Tuple (_, _, _) -> () + in + let check_prim_arg = function + | Pc c -> check_constant c + | Pv _ -> () + in let check_expr = function | Apply _ -> () | Block (_, _, _, _) -> () @@ -837,8 +851,8 @@ let invariant { blocks; start; _ } = | Closure (l, cont) -> List.iter l ~f:define; check_cont cont - | Constant _ -> () - | Prim (_, _) -> () + | Constant c -> check_constant c + | Prim (_, args) -> List.iter ~f:check_prim_arg args | Special _ -> () in let check_instr (i, _loc) = diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 95193f49..3f8e8754 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -162,7 +162,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 *) @@ -178,3 +178,15 @@ module Param = struct ~desc:"Set baseline for lifting deeply nested functions" (int 1) end + +(****) + +let target_ : [ `JavaScript | `Wasm | `None ] ref = ref `None + +let target () = + match !target_ with + | `None -> failwith "target was not set" + | (`JavaScript | `Wasm) as t -> t + +let set_target (t : [ `JavaScript | `Wasm ]) = + target_ := (t :> [ `JavaScript | `Wasm | `None ]) diff --git a/compiler/lib/config.mli b/compiler/lib/config.mli index ac1672bd..ab1f49d9 100644 --- a/compiler/lib/config.mli +++ b/compiler/lib/config.mli @@ -78,6 +78,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 @@ -102,3 +103,13 @@ 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 bb4ce4aa..ba7c1851 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -23,6 +23,14 @@ let debug = Debug.find "main" let times = Debug.find "times" +type optimized_result = + { program : Code.program + ; variable_uses : Deadcode.variable_uses + ; trampolined_calls : Effects.trampolined_calls + ; in_cps : Effects.in_cps + ; deadcode_sentinal : Code.Var.t + } + type profile = | O1 | O2 @@ -44,35 +52,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...@."; @@ -128,53 +136,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 @@ -182,13 +190,13 @@ let generate ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect - ((p, live_vars), trampolined_calls, _) = + { 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 - p + program ~exported_runtime - ~live_vars + ~live_vars:variable_uses ~trampolined_calls ~should_export ~warn_on_unhandled_effect @@ -642,18 +650,7 @@ let configure formatter = Code.Var.set_pretty (pretty && not (Config.Flag.shortvar ())); Code.Var.set_stable (Config.Flag.stable_var ()) -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 p = +let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p = let export_runtime = match link with | `All | `All_from _ -> true @@ -665,73 +662,57 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ~link p = |> coloring |> check_js -let full - (type result) - ~(target : result target) - ~standalone - ~wrap_with_fun - ~profile - ~link - ~source_map - d - p : result = +let optimize ~profile p = + let deadcode_sentinal = + (* If deadcode is disabled, this field is just fresh variable *) + Code.Var.fresh_n "dummy" + in let opt = specialize_js_once +> (match profile with | O1 -> o1 | O2 -> o2 | O3 -> o3) - ~target:(target_flag target) +> exact_calls profile +> effects +> map_fst - ((match target with - | JavaScript _ -> Generate_closure.f - | Wasm -> Fun.id) - +> deadcode') + (match Config.target (), Config.Flag.effects () with + | `JavaScript, false -> Generate_closure.f + | `JavaScript, true | `Wasm, _ -> Fun.id) + +> map_fst deadcode' in if times () then Format.eprintf "Start Optimizing...@."; let t = Timer.make () in - let r = opt p in + let (program, variable_uses), trampolined_calls, in_cps = opt p in let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in - 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 - +> 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 + { program; variable_uses; trampolined_calls; in_cps; deadcode_sentinal } + +let full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p = + let optimized_code = optimize ~profile p in + let exported_runtime = not standalone in + let emit formatter = + generate d ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect:standalone + +> link_and_pack ~standalone ~wrap_with_fun ~link + +> output formatter ~source_map () + in + emit formatter optimized_code let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p = let (_ : Source_map.t option) = - full - ~target:(JavaScript formatter) - ~standalone - ~wrap_with_fun - ~profile - ~link - ~source_map:None - d - p + full ~standalone ~wrap_with_fun ~profile ~link ~source_map:None ~formatter d p in () let f - ~target ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link ?source_map + ~formatter d p = - full ~target ~standalone ~wrap_with_fun ~profile ~link ~source_map d p + full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p let f' ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link formatter d p = full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli index 8e8d0c97..91f846b9 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -20,22 +20,26 @@ 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 +type optimized_result = + { program : Code.program + ; variable_uses : Deadcode.variable_uses + ; trampolined_calls : Effects.trampolined_calls + ; in_cps : Effects.in_cps + ; deadcode_sentinal : Code.Var.t + } + +val optimize : profile:profile -> Code.program -> optimized_result val f : - target:'result target - -> ?standalone:bool + ?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 + -> formatter:Pretty_print.t -> Parse_bytecode.Debug.t -> Code.program - -> 'result + -> Source_map.t option val f' : ?standalone:bool @@ -57,7 +61,7 @@ val from_string : val link_and_pack : ?standalone:bool -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ] - -> link:[ `All | `All_from of string list | `Needed | `No ] + -> ?link:[ `All | `All_from of string list | `Needed | `No ] -> Javascript.statement_list -> Javascript.statement_list diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 5faec48b..a5f78a38 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -29,17 +29,73 @@ let set_static_env s value = Hashtbl.add static_env s value let get_static_env s = try Some (Hashtbl.find static_env s) with Not_found -> None -module Int = Int32 +module type Int = sig + include Arith_ops -let int_binop l w f = - match l with - | [ Int i; Int j ] -> Some (Int (w (f i j))) - | _ -> None + val int_unop : constant list -> (t -> t) -> constant option -let shift l w t f = - match l with - | [ Int i; Int j ] -> Some (Int (w (f (t i) (Int32.to_int j land 0x1f)))) - | _ -> None + val int_binop : constant list -> (t -> t -> t) -> constant option + + val shift_op : constant list -> (t -> int -> t) -> constant option + + val of_int32_warning_on_overflow : int32 -> t + + val to_int32 : t -> int32 + + val numbits : int +end + +module Int32 = struct + include Int32 + + let int_unop l f = + match l with + | [ Int i ] -> Some (Int (f i)) + | _ -> None + + let int_binop l f = + match l with + | [ Int i; Int j ] -> Some (Int (f i j)) + | _ -> None + + (* For when the underlying function takes an [int] (not [t]) as its second argument *) + let shift_op l f = + match l with + | [ Int i; Int j ] -> Some (Int (f i (to_int j))) + | _ -> None + + let numbits = 32 + + let of_int32_warning_on_overflow = Fun.id + + let to_int32 = Fun.id +end + +module Int31 : Int = struct + include Int31 + + let int_unop l f = + match l with + | [ Int i ] -> Some (Int (to_int32 (f (of_int32_warning_on_overflow i)))) + | _ -> None + + let int_binop l f = + match l with + | [ Int i; Int j ] -> + Some + (Int + (to_int32 + (f (of_int32_warning_on_overflow i) (of_int32_warning_on_overflow j)))) + | _ -> None + + let shift_op l f = + match l with + | [ Int i; Int j ] -> + Some (Int (to_int32 (f (of_int32_warning_on_overflow i) (Int32.to_int j)))) + | _ -> None + + let numbits = 31 +end let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option = let args = @@ -83,34 +139,27 @@ let eval_prim ~target x = | Neq, [ Int i; Int j ] -> bool Int32.(i <> j) | Ult, [ Int i; Int j ] -> bool (Int32.(j < 0l) || Int32.(i < j)) | Extern name, l -> ( - let name = Primitive.resolve name in - let wrap = + let (module Int : Int) = match target with - | `JavaScript -> fun i -> i - | `Wasm -> Int31.wrap + | `JavaScript -> (module Int32) + | `Wasm -> (module Int31) in + let name = Primitive.resolve name in match name, l with (* int *) - | "%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 + | "%int_add", _ -> Int.int_binop l Int.add + | "%int_sub", _ -> Int.int_binop l Int.sub + | "%direct_int_mul", _ -> Int.int_binop l Int.mul | "%direct_int_div", [ _; Int 0l ] -> None - | "%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)) + | "%direct_int_div", _ -> Int.int_binop l Int.div + | "%direct_int_mod", _ -> Int.int_binop l Int.rem + | "%int_and", _ -> Int.int_binop l Int.logand + | "%int_or", _ -> Int.int_binop l Int.logor + | "%int_xor", _ -> Int.int_binop l Int.logxor + | "%int_lsl", _ -> Int.shift_op l Int.shift_left + | "%int_lsr", _ -> Int.shift_op l Int.shift_right_logical + | "%int_asr", _ -> Int.shift_op l Int.shift_right + | "%int_neg", _ -> Int.int_unop l Int.neg (* float *) | "caml_eq_float", _ -> float_binop_bool l Float.( = ) | "caml_neq_float", _ -> float_binop_bool l Float.( <> ) @@ -123,9 +172,9 @@ let eval_prim ~target x = | "caml_mul_float", _ -> float_binop l ( *. ) | "caml_div_float", _ -> float_binop l ( /. ) | "caml_fmod_float", _ -> float_binop l mod_float - | "caml_int_of_float", [ Float f ] -> Some (Int (Int.of_float f)) - | "to_int", [ Float f ] -> Some (Int (Int.of_float f)) - | "to_int", [ Int i ] -> Some (Int i) + | "caml_int_of_float", [ Float f ] -> + Some + (Int (Int32.of_float f |> Int.of_int32_warning_on_overflow |> Int.to_int32)) (* Math *) | "caml_neg_float", _ -> float_unop l ( ~-. ) | "caml_abs_float", _ -> float_unop l abs_float @@ -155,12 +204,7 @@ let eval_prim ~target x = | Some env -> Some (String env) | None -> None) | "caml_sys_const_word_size", [ _ ] -> Some (Int 32l) - | "caml_sys_const_int_size", [ _ ] -> - Some - (Int - (match target with - | `JavaScript -> 32l - | `Wasm -> 31l)) + | "caml_sys_const_int_size", [ _ ] -> Some (Int (Int32.of_int Int.numbits)) | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int 0l) | _ -> None) @@ -187,7 +231,7 @@ type is_int = | N | Unknown -let is_int ~target info x = +let is_int info x = match x with | Pv x -> get_approx @@ -195,11 +239,10 @@ let is_int ~target info x = (fun x -> match info.info_defs.(Var.idx x) with | Expr (Constant (Int _)) -> Y - | Expr (Constant (Int32 _ | NativeInt _)) -> ( - match target with - | `JavaScript -> Y - | `Wasm -> N) - | Expr (Block (_, _, _, _)) | Expr (Constant _) -> N + | Expr (Constant (NativeInt _ | Int32 _)) -> + (* These Wasm-specific constants are boxed *) + N + | Expr (Block (_, _, _, _) | Constant _) -> N | _ -> Unknown) Unknown (fun u v -> @@ -209,10 +252,9 @@ let is_int ~target info x = | _ -> Unknown) x | Pc (Int _) -> Y - | Pc (Int32 _ | NativeInt _) -> ( - match target with - | `JavaScript -> Y - | `Wasm -> N) + | Pc (NativeInt _ | Int32 _) -> + (* These Wasm-specific constants are boxed *) + N | Pc _ -> N let the_tag_of info x get = @@ -336,7 +378,7 @@ let eval_instr ~target info ((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 @@ -351,14 +393,12 @@ let eval_instr ~target 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 - (match target with - | `JavaScript -> "js_of_ocaml" - | `Wasm -> "wasm_of_ocaml")) ) - , noloc ) + let backend_name = + match target with + | `JavaScript -> "js_of_ocaml" + | `Wasm -> "wasm_of_ocaml" + in + [ Let (jsoo, Constant (String backend_name)), noloc ; Let (x, Block (0, [| jsoo |], NotArray, Immutable)), loc ] | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) -> @@ -388,10 +428,15 @@ let eval_instr ~target info ((x, loc) as i) = ( x , Prim ( prim - , List.map2 prim_args prim_args' ~f:(fun arg c -> - match (c : constant option), target with - | Some ((Int _ | NativeString _) as c), _ -> Pc c - | Some (Float _ as c), `JavaScript -> Pc c + , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> + match c, target with + | Some (Int _ as c), _ -> Pc c + | Some (Int32 _ | NativeInt _ | NativeString _), `Wasm -> + (* Avoid duplicating the constant here as it would cause an + allocation *) + arg + | Some (Int32 _ | NativeInt _), `JavaScript -> assert false + | Some ((Float _ | NativeString _) as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript when Config.Flag.use_js_string () -> Pc c | Some _, _ @@ -527,7 +572,7 @@ let eval ~target info blocks = { 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 ~target:(Config.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 30a36b08..a71f611c 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 -> Code.program -> Code.program +val f : Flow.info -> Code.program -> Code.program diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index c37a9a30..c32428f2 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -331,23 +331,26 @@ let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = | Float a, Float b, `JavaScript -> Float.bitwise_equal a b | Float _, Float _, `Wasm -> false | NativeString a, NativeString b, `JavaScript -> Native_string.equal a b + | NativeString _, NativeString _, `Wasm -> + false + (* Native strings are boxed (JavaScript objects) in Wasm and are + possibly different objects *) | String a, String b, `JavaScript -> Config.Flag.use_js_string () && String.equal a b - | Int _, Float _, _ | Float _, Int _, _ -> false + | String _, String _, `Wasm -> + false (* Strings are boxed in Wasm and are possibly different objects *) + | Int32 _, Int32 _, `Wasm -> + false (* [Int32]s are boxed in Wasm and are possibly different objects *) + | Int32 _, Int32 _, `JavaScript -> assert false + | NativeInt _, NativeInt _, `Wasm -> + false (* [NativeInt]s are boxed in Wasm and are possibly different objects *) + | NativeInt _, NativeInt _, `JavaScript -> assert false (* All other values may be distinct objects and thus different by [caml_js_equals]. *) - | String _, _, _ - | _, String _, _ - | NativeString _, _, _ - | _, NativeString _, _ - | Float_array _, _, _ - | _, Float_array _, _ - | Int64 _, _, _ - | _, Int64 _, _ - | Int32 _, _, _ - | _, Int32 _, _ - | NativeInt _, _, _ - | _, NativeInt _, _ - | Tuple _, _, _ - | _, Tuple _, _ -> false + | Int64 _, Int64 _, _ -> false + | Tuple _, Tuple _, _ -> false + | Float_array _, Float_array _, _ -> false + | (Int _ | Float _ | Int64 _ | Int32 _ | NativeInt _), _, _ -> false + | (String _ | NativeString _), _, _ -> false + | (Float_array _ | Tuple _), _, _ -> false let the_const_of ~target info x = match x with diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index 16b9ae53..a87ca602 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -264,9 +264,9 @@ let inline ~first_class_primitives live_vars closures pc (outer, blocks, free_pc 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 2bc18bc4..9799e882 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/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 9b2cf1d9..b2057d43 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -18,27 +18,28 @@ open! Stdlib -let rec constant_of_const ~target c : Code.constant = +let rec constant_of_const c : Code.constant = let open Lambda in let open Asttypes in match c with | Const_base (Const_int i) -> Int - (match target with + (match Config.target () with | `JavaScript -> Int32.of_int_warning_on_overflow i - | `Wasm -> Int31.of_int_warning_on_overflow i) + | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) | 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 | Const_base (Const_float s) -> Float (float_of_string s) | Const_base (Const_int32 i) -> ( - match target with + match Config.target () with | `JavaScript -> Int i | `Wasm -> Int32 i) | Const_base (Const_int64 i) -> Int64 i | Const_base (Const_nativeint i) -> ( - match target with - | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + let i = Int32.of_nativeint_warning_on_overflow i in + match Config.target () with + | `JavaScript -> Int i | `Wasm -> NativeInt i) | Const_immstring s -> String s | Const_float_array sl -> @@ -46,11 +47,11 @@ let rec constant_of_const ~target c : Code.constant = Float_array (Array.of_list l) | ((Const_pointer i) [@if ocaml_version < (4, 12, 0)]) -> Int - (match target with + (match Config.target () with | `JavaScript -> Int32.of_int_warning_on_overflow i - | `Wasm -> Int31.of_int_warning_on_overflow i) + | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) | Const_block (tag, l) -> - let l = Array.of_list (List.map l ~f:(fun c -> constant_of_const ~target c)) in + let l = Array.of_list (List.map l ~f:(fun c -> constant_of_const c)) in Tuple (tag, l, Unknown) let rec find_loc_in_summary ident' = function diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 155c3cf3..02a7053d 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -467,13 +467,14 @@ end = struct match ident_of_custom x with | Some name when same_ident name ident_32 -> ( let i : int32 = Obj.magic x in - match target with + match Config.target () with | `JavaScript -> Int i | `Wasm -> Int32 i) | Some name when same_ident name ident_native -> ( let i : nativeint = Obj.magic x in - match target with - | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + let i = Int32.of_nativeint_warning_on_overflow i in + match Config.target () with + | `JavaScript -> Int i | `Wasm -> NativeInt i) | Some name when same_ident name ident_64 -> Int64 (Obj.magic x : int64) | Some name -> @@ -492,9 +493,9 @@ end = struct else let i : int = Obj.magic x in Int - (match target with + (match Config.target () with | `JavaScript -> Int32.of_int_warning_on_overflow i - | `Wasm -> Int31.of_int_warning_on_overflow i) + | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) let inlined = function | String _ | NativeString _ -> false @@ -745,76 +746,88 @@ let access_global g i = g.vars.(i) <- Some x; x -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 - | None -> [] - | Some name -> - Code.Var.name (access_global g i) name; - [ Pc (NativeString (Native_string.of_string name)) ] - in - ( Let - ( Var.fresh () - , Prim - ( Extern "caml_register_global" - , Pc (Int (Int32.of_int i)) :: Pv (access_global g i) :: args ) ) - , loc ) - :: rem - else rem +let register_global ?(force = false) g i loc rem = + match g.is_exported.(i), force, Config.target () with + | true, _, `Wasm -> + (* Register a compilation unit (Wasm) *) + assert (not force); + 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 + | true, _, (`JavaScript as target) | false, true, ((`Wasm | `JavaScript) as target) -> + (* Register an exception (if force = true), or a compilation unit + (Javascript) *) + let args = + match g.named_value.(i) with + | None -> [] + | Some name -> + Code.Var.name (access_global g i) name; + [ Pc + (match target with + | `JavaScript -> NativeString (Native_string.of_string name) + | `Wasm -> String name) + ] + in + ( Let + ( Var.fresh () + , Prim + ( Extern "caml_register_global" + , Pc (Int (Int32.of_int i)) :: Pv (access_global g i) :: args ) ) + , loc ) + :: rem + | false, false, (`JavaScript | `Wasm) -> rem 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 -> + (* Registered global *) if debug_parser () then Format.printf "(global access %a)@." Var.print x; x, State.set_accu state x loc, instrs | None -> ( if i < Array.length g.constants && Constants.inlined g.constants.(i) then + (* Inlined constant *) let x, state = State.fresh_var state loc in let cst = g.constants.(i) in x, state, (Let (x, Constant cst), loc) :: instrs - 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 -> + match i < Array.length g.constants, Config.target () with + | true, _ | false, `JavaScript -> + (* Non-inlined constant, and reference to another compilation + units in case of separate compilation (JavaScript). + Some code is generated in a prelude to store the relevant + module in variable [x]. *) + g.is_const.(i) <- true; 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 )) + if debug_parser () then Format.printf "%a = CONST(%d)@." Var.print x i; + g.vars.(i) <- Some x; + x, state, instrs + | false, `Wasm -> ( + (* Reference to another compilation units in case of separate + compilation (Wasm). + The toplevel module is available in an imported global + variables. *) + 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.Set.empty @@ -3079,50 +3092,49 @@ let from_channel ic = `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) -let predefined_exceptions ~target = +let predefined_exceptions () = + (* Register predefined exceptions in case of separate compilation *) let body = let open Code in List.map predefined_exceptions ~f:(fun (index, name) -> assert (String.is_valid_utf_8 name); let exn = Var.fresh () in 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 ] - @ (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 ) - ] + [ Let (v_name, Constant (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 + ] @ - match target with - | `JavaScript -> [] + match Config.target () with + | `JavaScript -> + let v_name_js = Var.fresh () in + [ ( Let (v_name_js, Constant (NativeString (Native_string.of_string name))) + , noloc ) + ; ( Let + ( Var.fresh () + , Prim + ( Extern "caml_register_global" + , [ Pc (Int (Int32.of_int index)); Pv exn; Pv v_name_js ] ) ) + , noloc ) + ] | `Wasm -> [ ( Let + ( Var.fresh () + , Prim + ( Extern "caml_register_global" + , [ Pc (Int (Int32.of_int index)); Pv exn; Pv v_name ] ) ) + , noloc ) + (* Also make the exception available to the generated code *) + ; ( Let ( Var.fresh () , Prim (Extern "caml_set_global", [ Pc (String name); Pv exn ]) ) , noloc ) diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 39f02090..ff5b89be 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -25,6 +25,9 @@ open Flow let specialize_instr ~target info i = match i, target with | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( + (* We can implement the special case where the format string is "%s" in JavaScript + in a concise and efficient way with [""+x]. It does not make as much sense in + Wasm to have a special case for this. *) match the_string_of ~target info y with | Some "%d" -> ( match the_int ~target info z with @@ -41,13 +44,11 @@ let specialize_instr ~target info i = , Prim ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) , [ (Pv _ as y) ] ) ) - , _ ) - when Config.Flag.safe_string () -> ( + , target ) -> ( match the_string_of ~target 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 ])), `JavaScript - -> ( + | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])), _ -> ( match the_string_of ~target info y with | Some s when Primitive.need_named_value s -> Let (x, Prim (Extern prim, [ Pc (String s); z ])) @@ -134,6 +135,9 @@ let specialize_instr ~target info i = | Some s -> Let (x, Constant (NativeString (Native_string.of_bytestring s))) | None -> i) | Let (x, Prim (Extern "%int_mul", [ y; z ])), `JavaScript -> ( + (* Using * to multiply integers in JavaScript yields a float; and if the + float is large enough, some bits can be lost. So, in the general case, + we have to use Math.imul. There is no such issue in Wasm. *) match the_int ~target info y, the_int ~target info z with | Some j, _ when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) @@ -262,7 +266,7 @@ let specialize_all_instrs ~target info p = (****) -let f ~target info p = specialize_all_instrs ~target info p +let f info p = specialize_all_instrs ~target:(Config.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 4bf26256..3ed1f1a6 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 -> Code.program -> Code.program +val f : Flow.info -> Code.program -> Code.program val f_once : Code.program -> Code.program diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index d5c7122c..86d6e56b 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -341,7 +341,49 @@ module Int32 = struct n end -module Int31 = struct +module type Arith_ops = sig + type t + + val neg : t -> t + + val add : t -> t -> t + + val sub : t -> t -> t + + val mul : t -> t -> t + + val div : t -> t -> t + + val rem : t -> t -> t + + val logand : t -> t -> t + + val logor : t -> t -> t + + val logxor : t -> t -> t + + val shift_left : t -> int -> t + + val shift_right : t -> int -> t + + val shift_right_logical : t -> int -> t +end + +module Int31 : sig + type t + + include Arith_ops with type t := t + + val of_int_warning_on_overflow : int -> t + + val of_nativeint_warning_on_overflow : nativeint -> t + + val of_int32_warning_on_overflow : int32 -> t + + val to_int32 : t -> int32 +end = struct + type t = int32 + let wrap i = Int32.(shift_right (shift_left i 1) 1) let of_int_warning_on_overflow i = @@ -361,6 +403,54 @@ module Int31 = struct ~to_dec:(Printf.sprintf "%nd") ~to_hex:(Printf.sprintf "%nx") n + + let of_int32_warning_on_overflow n = + Int32.convert_warning_on_overflow + ~to_int32:(fun i -> wrap i) + ~of_int32:Fun.id + ~equal:Int32.equal + ~to_dec:(Printf.sprintf "%ld") + ~to_hex:(Printf.sprintf "%lx") + n + + let two_pow n = + assert (0 <= n && n <= 31); + Int32.shift_left 1l n + + let min_int = Int32.neg (two_pow 30) + + let neg x = if Int32.equal x min_int then x else Int32.neg x + + let int_binop f x y = wrap (f x y) + + let add = int_binop Int32.add + + let sub = int_binop Int32.sub + + let mul = int_binop Int32.mul + + let div = int_binop Int32.div + + let rem = int_binop Int32.rem + + let logand = int_binop Int32.logand + + let logor = int_binop Int32.logor + + let logxor = int_binop Int32.logxor + + let shift_op f x y = + (* Limit the shift offset to [0, 31] *) + wrap (f x (y land 0x1f)) + + let shift_left = shift_op Int32.shift_left + + let shift_right = shift_op Int32.shift_right + + let shift_right_logical a b = + shift_op Int32.shift_right_logical (Int32.logand a 0x7fffffffl) b + + let to_int32 (x : t) : int32 = x end module Option = struct diff --git a/compiler/tests-num/dune b/compiler/tests-num/dune index 1bd90f40..05677522 100644 --- a/compiler/tests-num/dune +++ b/compiler/tests-num/dune @@ -1,5 +1,6 @@ (executable (name main) + (modules main test_nats test test_big_ints test_ratios test_nums test_io) (libraries num) (modes js @@ -7,6 +8,15 @@ (flags (:standard -linkall -w -3-7-33-35-37 -safe-string -no-strict-sequence))) +(library + (name test_int31) + (modules test_int31) + (inline_tests) + (enabled_if %{lib-available:qcheck}) + (preprocess + (pps ppx_expect)) + (libraries js_of_ocaml-compiler qcheck)) + (rule (target main.referencejs) (enabled_if diff --git a/compiler/tests-num/test_int31.ml b/compiler/tests-num/test_int31.ml new file mode 100644 index 00000000..2b4743dd --- /dev/null +++ b/compiler/tests-num/test_int31.ml @@ -0,0 +1,194 @@ +open! Js_of_ocaml_compiler.Stdlib +open QCheck2 + +let () = Printexc.record_backtrace false + +let min_int31 = Int32.(neg (shift_left 1l 30)) +let max_int31 = Int32.(sub (shift_left 1l 30) 1l) + +let in_range i = + Int32.(min_int31 <= i && i <= max_int31) + +let in_range_i32 = + Gen.(Int32.of_int <$> int_range (- (1 lsl 30)) (1 lsl 30 - 1)) + +let out_of_range_int = + let open Gen in + oneof [ int_range (- (1 lsl 31)) (- (1 lsl 30) - 1); + int_range (1 lsl 30) (1 lsl 31 - 1) ] + +let out_of_range_i32 = + out_of_range_int |> Gen.map Int32.of_int + +let t_corner = + let open Gen in + graft_corners in_range_i32 [min_int31; max_int31] () + |> map Int31.of_int32_warning_on_overflow + +let print_t t = + Format.sprintf "%ld" (Int31.to_int32 t) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_int32_warning_on_overflow: normal" + in_range_i32 + (fun i -> + Int32.equal Int31.(to_int32 (of_int32_warning_on_overflow i)) i); + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_int_warning_on_overflow: normal" + (Gen.map Int32.to_int in_range_i32) + (fun i -> + Int.equal (Int31.(to_int32 (of_int_warning_on_overflow i)) |> Int32.to_int) i); + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.of_nativeint_warning_on_overflow: normal" + (Gen.map Nativeint.of_int32 in_range_i32) + (fun i -> + Nativeint.equal + (Int31.(to_int32 (of_nativeint_warning_on_overflow i)) |> Nativeint.of_int32) + i); + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink out_of_range_i32)) in + let i_trunc = Int32.(shift_right (shift_left i 1) 1) in + ignore (Int31.of_int32_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%lx (%ld) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink out_of_range_int)) in + let i_trunc = Int32.(shift_right (shift_left (of_int i) 1) 1) in + ignore (Int31.of_int_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%x (%d) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let%expect_test _ = + let i = Gen.(generate1 (no_shrink (Nativeint.of_int <$> out_of_range_int))) in + let i_trunc = Int32.(shift_right (shift_left (Nativeint.to_int32 i) 1) 1) in + ignore (Int31.of_nativeint_warning_on_overflow i); + let output = [%expect.output] in + let expected = + Format.sprintf "Warning: integer overflow: integer 0x%nx (%nd) truncated to 0x%lx (%ld); the generated code might be incorrect.@." i i i_trunc i_trunc + in + if not (String.equal output expected) then + Format.printf "Unexpected output string@.%s@.Expected:@.%s@." output expected; + [%expect ""] + +let modulus = Int32.(shift_left 1l 31) + +let canonicalize x = + if in_range x then x else Int32.(sub x modulus) + +let canon_equal x y = + Int32.(=) (canonicalize x) (canonicalize y) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.neg" + t_corner + ~print:print_t + (fun i -> + let r_int31 = Int31.(neg i |> to_int32) in + let r_int32 = Int32.neg (Int31.to_int32 i) in + in_range r_int31 && canon_equal r_int31 r_int32); + [%expect ""] + +let binop_prop op_i31 op_i32 i j = + let r_int31 = op_i31 i j |> Int31.to_int32 in + let r_int32 = op_i32 (Int31.to_int32 i) (Int31.to_int32 j) in + in_range r_int31 && canon_equal r_int31 r_int32 + +let binop_check ~count ~name op_i31 op_i32 = + Test.check_exn @@ Test.make ~count ~name + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> binop_prop op_i31 op_i32 i j) + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.add" Int31.add Int32.add; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.sub" Int31.sub Int32.sub; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.mul" Int31.mul Int32.mul; + [%expect ""] + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.div" + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> + try binop_prop Int31.div Int32.div i j + with Division_by_zero -> Int32.equal (Int31.to_int32 j) 0l) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.rem" + Gen.(tup2 t_corner t_corner) + ~print:(Print.tup2 print_t print_t) + (fun (i, j) -> + try binop_prop Int31.rem Int32.rem i j + with Division_by_zero -> Int32.equal (Int31.to_int32 j) 0l) + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logand" Int31.logand Int32.logand; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logor" Int31.logor Int32.logor; + [%expect ""] + +let%expect_test _ = + binop_check ~count:1000 ~name:"Int31.logxor" Int31.logxor Int32.logxor; + [%expect ""] + +let shift_op_prop op_i31 op_i32 x i = + let r_int31 = op_i31 x i |> Int31.to_int32 in + let r_int32 = op_i32 (Int31.to_int32 x) i in + in_range r_int31 && canon_equal r_int31 r_int32 + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.shift_left" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> shift_op_prop Int31.shift_left Int32.shift_left x i) + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:1000 ~name:"Int31.shift_right" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> shift_op_prop Int31.shift_right Int32.shift_right x i) + +(* Logical implication *) +let (-->) p q = not p || q + +let%expect_test _ = + Test.check_exn @@ Test.make ~count:10_000 ~name:"Int31.shift_right_logical" + Gen.(tup2 t_corner (int_bound 31)) + ~print:Print.(tup2 print_t int) + (fun (x, i) -> + let r_int31 = Int31.shift_right_logical x i |> Int31.to_int32 in + let x_int32 = Int31.to_int32 x in + let r_int32 = + if Int_replace_polymorphic_compare.( i = 0 ) then x_int32 + else Int32.(shift_right_logical (logand 0x7fffffffl x_int32) i) + in + (* The bits should be unchanged if the shift amount is zero, otherwise they should + match the result of shifting the 31 lower bits of the canonical representation *) + in_range r_int31 && Int32.equal r_int31 r_int32 + && (Int.equal i 0 --> Int32.(r_int31 = x_int32))); + [%expect ""] diff --git a/dune-project b/dune-project index ed1856d8..6cd544bd 100644 --- a/dune-project +++ b/dune-project @@ -25,6 +25,7 @@ (re :with-test) (cmdliner (>= 1.1.0)) (sedlex (>= 2.3)) + (qcheck :with-test) menhir menhirLib menhirSdk diff --git a/dune-workspace.dev b/dune-workspace.dev index a2121101..0f4dc203 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -1,4 +1,4 @@ -(lang dune 3.7) +(lang dune 3.15) ;; Install the following opam switches, copy this file as ;; dune-workspace and run: From f27e20ba48f898c588c843fc5a9b6c62d300304b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 30 Sep 2024 14:44:42 +0200 Subject: [PATCH 3/9] WSOO side of Target-specific code --- compiler/bin-js_of_ocaml/compile.ml | 7 +-- compiler/bin-wasm_of_ocaml/compile.ml | 45 ++++++--------- compiler/lib/driver.ml | 10 +--- compiler/lib/driver.mli | 2 +- compiler/lib/ocaml_compiler.mli | 3 +- compiler/lib/parse_bytecode.ml | 76 +++++++++++-------------- compiler/lib/parse_bytecode.mli | 8 +-- compiler/lib/stdlib.ml | 4 ++ compiler/lib/wasm/wa_code_generation.ml | 6 +- compiler/lib/wasm/wa_core_target.ml | 2 +- compiler/lib/wasm/wa_gc_target.ml | 6 +- compiler/lib/wasm/wa_generate.ml | 4 +- 12 files changed, 70 insertions(+), 103 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index caeb1388..53069bae 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -195,7 +195,6 @@ let run in let code = Code.prepend one.code instr in Driver.f - ~target:(JavaScript fmt) ~standalone ?profile ~link @@ -220,7 +219,6 @@ let run let code = Code.prepend one.code instr in let res = Driver.f - ~target:(JavaScript fmt) ~standalone ?profile ~link @@ -285,7 +283,7 @@ let run then ( let prims = Linker.list_all () |> StringSet.elements in assert (List.length prims > 0); - let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`JavaScript in + let code, uinfo = Parse_bytecode.predefined_exceptions () in let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in let code : Parse_bytecode.one = { code @@ -358,7 +356,6 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo - ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -415,7 +412,6 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo - ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -447,7 +443,6 @@ 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/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index 5a0135aa..beb883e8 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -140,17 +140,18 @@ let link_runtime ~profile runtime_wasm_files output_file = let generate_prelude ~out_file = Filename.gen_file out_file @@ fun ch -> - let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`Wasm in - let live_vars, in_cps, p, debug = - Driver.f - ~target:Wasm - ~link:`Needed - (Parse_bytecode.Debug.create ~include_cmis:false false) - code - in + let code, uinfo = Parse_bytecode.predefined_exceptions () in + let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize code in let context = Wa_generate.start () in + let debug = Parse_bytecode.Debug.create ~include_cmis:false false in let _ = - Wa_generate.f ~context ~unit_name:(Some "prelude") ~live_vars ~in_cps ~debug p + Wa_generate.f + ~context + ~unit_name:(Some "prelude") + ~live_vars:variable_uses + ~in_cps + ~debug + program in Wa_generate.output ch ~context ~debug; uinfo.provides @@ -244,6 +245,7 @@ let run ; sourcemap_root ; sourcemap_don't_inline_content } = + Config.set_target `Wasm; Jsoo_cmdline.Arg.eval common; Wa_generate.init (); let output_file = fst output_file in @@ -270,15 +272,8 @@ let run List.iter builtin ~f:(fun t -> let filename = Builtins.File.name t in let runtimes = Linker.Fragment.parse_builtin t in - Linker.load_fragments - ~ignore_always_annotation:true - ~target_env:Target_env.Isomorphic - ~filename - runtimes); - Linker.load_files - ~ignore_always_annotation:true - ~target_env:Target_env.Isomorphic - runtime_js_files; + Linker.load_fragments ~target_env:Target_env.Isomorphic ~filename runtimes); + Linker.load_files ~target_env:Target_env.Isomorphic runtime_js_files; Linker.check_deps (); if times () then Format.eprintf " parsing js: %a@." Timer.print t1; if times () then Format.eprintf "Start parsing...@."; @@ -299,12 +294,11 @@ let run check_debug one; let code = one.code in let standalone = Option.is_none unit_name in - let live_vars, in_cps, p, debug = - Driver.f ~target:Wasm ~standalone ?profile ~link:`No one.debug code - in + let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ?profile code in let context = Wa_generate.start () in + let debug = one.debug in let toplevel_name, generated_js = - Wa_generate.f ~context ~unit_name ~live_vars ~in_cps ~debug p + Wa_generate.f ~context ~unit_name ~live_vars:variable_uses ~in_cps ~debug program in if standalone then Wa_generate.add_start_function ~context toplevel_name; Wa_generate.output ch ~context ~debug; @@ -352,12 +346,7 @@ let run let compile_cmo cmo cont = let t1 = Timer.make () in let code = - Parse_bytecode.from_cmo - ~target:`Wasm - ~includes:include_dirs - ~debug:need_debug - cmo - ic + Parse_bytecode.from_cmo ~includes:include_dirs ~debug:need_debug cmo ic in let unit_info = Unit_info.of_cmo cmo in let unit_name = Ocaml_compiler.Cmo_format.name cmo in diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index ba7c1851..ea9c8686 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -79,8 +79,7 @@ let specialize' (p, info) = let specialize p = fst (specialize' p) -let eval (p, info) = - if Config.Flag.staticeval () then Eval.f 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...@."; @@ -180,10 +179,7 @@ let round1 : 'a -> 'a = let round2 = flow +> specialize' +> eval +> deadcode +> o1 -let o3 = - loop 10 "tailcall+inline" round1 1 - +> loop 10 "flow" round2 1 - +> print +let o3 = loop 10 "tailcall+inline" round1 1 +> loop 10 "flow" round2 1 +> print let generate d @@ -662,7 +658,7 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p |> coloring |> check_js -let optimize ~profile p = +let optimize ?(profile = O1) p = let deadcode_sentinal = (* If deadcode is disabled, this field is just fresh variable *) Code.Var.fresh_n "dummy" diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli index 91f846b9..16103a48 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -28,7 +28,7 @@ type optimized_result = ; deadcode_sentinal : Code.Var.t } -val optimize : profile:profile -> Code.program -> optimized_result +val optimize : ?profile:profile -> Code.program -> optimized_result val f : ?standalone:bool diff --git a/compiler/lib/ocaml_compiler.mli b/compiler/lib/ocaml_compiler.mli index 4a9a6fb8..0cb2d3ac 100644 --- a/compiler/lib/ocaml_compiler.mli +++ b/compiler/lib/ocaml_compiler.mli @@ -16,8 +16,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val constant_of_const : - target:[ `JavaScript | `Wasm ] -> Lambda.structured_constant -> Code.constant +val constant_of_const : 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 02a7053d..c433d93e 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -786,7 +786,7 @@ let register_global ?(force = false) g i loc rem = :: rem | false, false, (`JavaScript | `Wasm) -> rem -let get_global ~target state instrs i loc = +let get_global state instrs i loc = State.size_globals state (i + 1); let g = State.globals state in match g.vars.(i) with @@ -842,7 +842,6 @@ type compile_info = ; code : string ; limit : int ; debug : Debug.t - ; target : [ `JavaScript | `Wasm ] } let string_of_addr debug_data addr = @@ -870,7 +869,7 @@ let ( ||| ) x y = | No -> y | _ -> x -let rec compile_block blocks debug_data ~target code pc state = +let rec compile_block blocks debug_data code pc state = if not (Addr.Set.mem pc !tagged_blocks) then ( let limit = Blocks.next blocks pc in @@ -879,16 +878,16 @@ let rec compile_block blocks debug_data ~target code pc state = let state = State.start_block pc state in tagged_blocks := Addr.Set.add pc !tagged_blocks; let instr, last, state' = - compile { blocks; code; limit; debug = debug_data; target } pc state [] + compile { blocks; code; limit; debug = debug_data } pc state [] in assert (not (Addr.Map.mem pc !compiled_blocks)); compiled_blocks := Addr.Map.add pc (state, List.rev instr, last) !compiled_blocks; match fst last with | Branch (pc', _) | Poptrap (pc', _) -> - compile_block blocks debug_data ~target code pc' state' + compile_block blocks debug_data code pc' state' | Cond (_, (pc1, _), (pc2, _)) -> - compile_block blocks debug_data ~target code pc1 state'; - compile_block blocks debug_data ~target code pc2 state' + compile_block blocks debug_data code pc1 state'; + compile_block blocks debug_data code pc2 state' | Switch (_, _) -> () | Pushtrap _ -> () | Raise _ | Return _ | Stop -> ()) @@ -1226,7 +1225,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 ~target:infos.target code addr state'; + compile_block infos.blocks infos.debug 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 @@ -1283,7 +1282,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 ~target:infos.target code addr state'; + compile_block infos.blocks infos.debug 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 @@ -1313,16 +1312,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 ~target:infos.target state instrs i loc in + let _, state, instrs = get_global 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 ~target:infos.target state instrs i loc in + let _, state, instrs = get_global 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 ~target:infos.target state instrs i loc in + let x, state, instrs = get_global 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; @@ -1331,7 +1330,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 ~target:infos.target state instrs i loc in + let x, state, instrs = get_global 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; @@ -1356,7 +1355,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 ~target:infos.target g i loc instrs in + let instrs = register_global 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 @@ -1707,9 +1706,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 ~target:infos.target code pc' state); + compile_block infos.blocks infos.debug code pc' state); Array.iter bt ~f:(fun pc' -> - compile_block infos.blocks infos.debug ~target:infos.target code pc' state); + compile_block infos.blocks infos.debug code pc' state); match isize, bsize with | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, args)), loc), state | 0, _ -> @@ -1780,17 +1779,10 @@ 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 @@ -1808,7 +1800,6 @@ and compile infos pc state instrs = compile_block infos.blocks infos.debug - ~target:infos.target code addr (State.pop 4 (State.pop_handler state)); @@ -2495,7 +2486,7 @@ type one = ; debug : Debug.t } -let parse_bytecode code globals debug_data ~target = +let parse_bytecode code globals debug_data = let state = State.initial globals in Code.Var.reset (); let blocks = Blocks.analyse debug_data code in @@ -2510,7 +2501,7 @@ let parse_bytecode code globals debug_data ~target = if not (Blocks.is_empty blocks') then ( let start = 0 in - compile_block blocks' debug_data ~target code start state; + compile_block blocks' debug_data code start state; let blocks = Addr.Map.mapi (fun _ (state, instr, last) -> @@ -2691,12 +2682,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 ~target in + let p = parse_bytecode code globals debug_data 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 ~target ~force:true globals i noloc body in + let body = register_global ~force:true globals i noloc body in globals.is_exported.(i) <- false; body) in @@ -2704,7 +2695,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 ~target globals i noloc l in + let l = register_global globals i noloc l in (Let (x, Constant globals.constants.(i)), noloc) :: l | _ -> l) in @@ -2820,7 +2811,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 ~target:`JavaScript in + let p = parse_bytecode code globals debug_data in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let find_name i = @@ -2885,13 +2876,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 ~target t compunit code = + let step1 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 ~target sc :: t.constants; + t.constants <- constant_of_const sc :: t.constants; let pos = t.pos in t.pos <- succ t.pos; pos @@ -2959,16 +2950,16 @@ module Reloc = struct globals end -let from_compilation_units ~target ~includes:_ ~include_cmis ~debug_data l = +let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = let reloc = Reloc.create () in - List.iter l ~f:(fun (compunit, code) -> Reloc.step1 ~target reloc compunit code); + List.iter l ~f:(fun (compunit, code) -> Reloc.step1 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 ~target in + let prog = parse_bytecode code globals debug_data in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let body = @@ -2977,7 +2968,7 @@ let from_compilation_units ~target ~includes:_ ~include_cmis ~debug_data l = | Some x when globals.is_const.(i) -> ( match globals.named_value.(i) with | None -> - let l = register_global ~target globals i noloc l in + let l = register_global 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) @@ -3010,8 +3001,7 @@ let from_compilation_units ~target ~includes:_ ~include_cmis ~debug_data l = in { code = prepend prog body; cmis; debug = debug_data } -let from_cmo ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit ic - = +let from_cmo ?(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 @@ -3022,13 +3012,11 @@ let from_cmo ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) c 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 ~target ~includes ~include_cmis ~debug_data [ compunit, code ] - in + let p = from_compilation_units ~includes ~include_cmis ~debug_data [ compunit, code ] in Code.invariant p.code; p -let from_cma ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = +let from_cma ?(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 @@ -3047,7 +3035,7 @@ let from_cma ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) l compunit, code) in if times () then Format.eprintf " read debug events: %.2f@." !t; - let p = from_compilation_units ~target ~includes ~include_cmis ~debug_data units in + let p = from_compilation_units ~includes ~include_cmis ~debug_data units in Code.invariant p.code; p diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 244472cd..863d146c 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -63,8 +63,7 @@ val from_exe : -> one val from_cmo : - target:[ `JavaScript | `Wasm ] - -> ?includes:string list + ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.compilation_unit @@ -72,8 +71,7 @@ val from_cmo : -> one val from_cma : - target:[ `JavaScript | `Wasm ] - -> ?includes:string list + ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.library @@ -90,7 +88,7 @@ val from_string : -> string -> Code.program * Debug.t -val predefined_exceptions : target:[ `JavaScript | `Wasm ] -> Code.program * Unit_info.t +val predefined_exceptions : unit -> Code.program * Unit_info.t val link_info : target:[ `JavaScript | `Wasm ] diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 86d6e56b..40fe5b2e 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -380,12 +380,16 @@ module Int31 : sig val of_int32_warning_on_overflow : int32 -> t + val of_int32_truncate : int32 -> t + val to_int32 : t -> int32 end = struct type t = int32 let wrap i = Int32.(shift_right (shift_left i 1) 1) + let of_int32_truncate i = wrap i + let of_int_warning_on_overflow i = Int32.convert_warning_on_overflow ~to_int32:(fun i -> wrap (Int32.of_int i)) diff --git a/compiler/lib/wasm/wa_code_generation.ml b/compiler/lib/wasm/wa_code_generation.ml index ab290686..2760a1fc 100644 --- a/compiler/lib/wasm/wa_code_generation.ml +++ b/compiler/lib/wasm/wa_code_generation.ml @@ -396,10 +396,12 @@ module Arith = struct | W.I31Get (S, n') -> return n' | _ -> return (W.RefI31 n) + let wrap31 n = Int31.(of_int32_truncate n |> to_int32) + let of_int31 n = let* n = n in match n with - | W.RefI31 (Const (I32 n)) -> return (W.Const (I32 (Int31.wrap n))) + | W.RefI31 (Const (I32 n)) -> return (W.Const (I32 (wrap31 n))) | _ -> return (W.I31Get (S, n)) end @@ -422,7 +424,7 @@ let bin_op_is_smi (op : W.int_bin_op) = let rec is_smi e = match e with - | W.Const (I32 i) -> Int32.equal (Int31.wrap i) i + | W.Const (I32 i) -> Int32.equal (Arith.wrap31 i) i | UnOp ((I32 op | I64 op), _) -> un_op_is_smi op | BinOp ((I32 op | I64 op), _, _) -> bin_op_is_smi op | I31Get (S, _) -> true diff --git a/compiler/lib/wasm/wa_core_target.ml b/compiler/lib/wasm/wa_core_target.ml index 0e7eafda..8d102567 100644 --- a/compiler/lib/wasm/wa_core_target.ml +++ b/compiler/lib/wasm/wa_core_target.ml @@ -411,7 +411,7 @@ module Constant = struct let block = [ W.DataI32 h ; DataI32 0l (*ZZZ DataSym (S "caml_nativeint_ops", 0)*) - ; DataI32 (Int32.of_nativeint_warning_on_overflow i) + ; DataI32 i ] in context.data_segments <- Code.Var.Map.add name (true, block) context.data_segments; diff --git a/compiler/lib/wasm/wa_gc_target.ml b/compiler/lib/wasm/wa_gc_target.ml index 9f452b66..734fb39a 100644 --- a/compiler/lib/wasm/wa_gc_target.ml +++ b/compiler/lib/wasm/wa_gc_target.ml @@ -1035,11 +1035,7 @@ module Constant = struct let* e = Memory.make_int32 ~kind:`Int32 (return (W.Const (I32 i))) in return (Const, e) | NativeInt i -> - let* e = - Memory.make_int32 - ~kind:`Nativeint - (return (W.Const (I32 (Int32.of_nativeint_warning_on_overflow i)))) - in + let* e = Memory.make_int32 ~kind:`Nativeint (return (W.Const (I32 i))) in return (Const, e) let translate c = diff --git a/compiler/lib/wasm/wa_generate.ml b/compiler/lib/wasm/wa_generate.ml index d01daad0..511d7b17 100644 --- a/compiler/lib/wasm/wa_generate.ml +++ b/compiler/lib/wasm/wa_generate.ml @@ -161,7 +161,7 @@ module Generate (Target : Wa_target_sig.S) = struct | Field (x, n, Float) -> Memory.float_array_get (load x) - (Constant.translate (Int (Int31.of_int_warning_on_overflow n))) + (Constant.translate (Int Int31.(of_int_warning_on_overflow n |> to_int32))) | Closure _ -> Closure.translate ~context:ctx.global_context @@ -676,7 +676,7 @@ module Generate (Target : Wa_target_sig.S) = struct | Set_field (x, n, Float, y) -> Memory.float_array_set (load x) - (Constant.translate (Int (Int31.of_int_warning_on_overflow n))) + (Constant.translate (Int Int31.(of_int_warning_on_overflow n |> to_int32))) (load y) | Offset_ref (x, n) -> Memory.set_field From af34f714ed24846bf433737c8dd93f94069d7a17 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 1 Oct 2024 16:42:08 +0200 Subject: [PATCH 4/9] Upgrade Dune lang version --- dune-workspace.dev | 2 +- js_of_ocaml-compiler.opam | 1 + 2 files changed, 2 insertions(+), 1 deletion(-) diff --git a/dune-workspace.dev b/dune-workspace.dev index 0f4dc203..5b5373a1 100644 --- a/dune-workspace.dev +++ b/dune-workspace.dev @@ -1,4 +1,4 @@ -(lang dune 3.15) +(lang dune 3.17) ;; Install the following opam switches, copy this file as ;; dune-workspace and run: diff --git a/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index cf055403..11414a3d 100644 --- a/js_of_ocaml-compiler.opam +++ b/js_of_ocaml-compiler.opam @@ -20,6 +20,7 @@ depends: [ "re" {with-test} "cmdliner" {>= "1.1.0"} "sedlex" {>= "2.3"} + "qcheck" {with-test} "menhir" "menhirLib" "menhirSdk" From b078432b57500491ef4015fdac7a8dfd47a0c518 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Wed, 11 Sep 2024 18:49:32 +0200 Subject: [PATCH 5/9] No longer ignore always annotation --- compiler/lib/linker.ml | 27 ++++++++++----------------- compiler/lib/linker.mli | 12 +++--------- 2 files changed, 13 insertions(+), 26 deletions(-) diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 4e007ecf..d9c93b30 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -434,7 +434,7 @@ let list_all ?from () = provided StringSet.empty -let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment.t) = +let load_fragment ~target_env ~filename (f : Fragment.t) = match f with | Always_include code -> always_included := @@ -472,11 +472,9 @@ let load_fragment ~ignore_always_annotation ~target_env ~filename (f : Fragment. filename; if always then ( - if not ignore_always_annotation - then - always_included := - { ar_filename = filename; ar_program = code; ar_requires = requires } - :: !always_included; + always_included := + { ar_filename = filename; ar_program = code; ar_requires = requires } + :: !always_included; `Ok) else error @@ -578,24 +576,19 @@ let check_deps () = ()) code_pieces -let load_file ~ignore_always_annotation ~target_env filename = +let load_file ~target_env filename = List.iter (Fragment.parse_file filename) ~f:(fun frag -> - let (`Ok | `Ignored) = - load_fragment ~ignore_always_annotation ~target_env ~filename frag - in + let (`Ok | `Ignored) = load_fragment ~target_env ~filename frag in ()) -let load_fragments ?(ignore_always_annotation = false) ~target_env ~filename l = +let load_fragments ~target_env ~filename l = List.iter l ~f:(fun frag -> - let (`Ok | `Ignored) = - load_fragment ~ignore_always_annotation ~target_env ~filename frag - in + let (`Ok | `Ignored) = load_fragment ~target_env ~filename frag in ()); check_deps () -let load_files ?(ignore_always_annotation = false) ~target_env l = - List.iter l ~f:(fun filename -> - load_file ~ignore_always_annotation ~target_env filename); +let load_files ~target_env l = + List.iter l ~f:(fun filename -> load_file ~target_env filename); check_deps () (* resolve *) diff --git a/compiler/lib/linker.mli b/compiler/lib/linker.mli index 246b9594..b7d49194 100644 --- a/compiler/lib/linker.mli +++ b/compiler/lib/linker.mli @@ -36,15 +36,9 @@ end val reset : unit -> 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 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 check_deps : unit -> unit From 2a7f41384f75565e200a148c325f6659bf6a9c0e Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Tue, 17 Sep 2024 11:14:25 +0200 Subject: [PATCH 6/9] JavaScript linker: add 'wasm' flag --- compiler/lib/linker.ml | 9 ++++++++- runtime/sys.js | 1 + 2 files changed, 9 insertions(+), 1 deletion(-) diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index d9c93b30..a49cd797 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -186,7 +186,14 @@ module Fragment = struct List.fold_left ~f:(fun m (k, v) -> StringMap.add k v m) ~init:StringMap.empty - [ "js-string", Config.Flag.use_js_string; "effects", Config.Flag.effects ] + [ "js-string", Config.Flag.use_js_string + ; "effects", Config.Flag.effects + ; ( "wasm" + , fun () -> + match Config.target () with + | `JavaScript -> false + | `Wasm -> true ) + ] type t = | Always_include of Javascript.program pack diff --git a/runtime/sys.js b/runtime/sys.js index 02c57da1..ff811d99 100644 --- a/runtime/sys.js +++ b/runtime/sys.js @@ -352,6 +352,7 @@ function caml_sys_is_regular_file(name) { } //Always //Requires: caml_fatal_uncaught_exception +//If: !wasm function caml_setup_uncaught_exception_handler() { var process = globalThis.process; if(process && process.on) { From fb225da53b0b2c7f7ab9860a4c263c6151fe167e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Sep 2024 18:00:39 +0200 Subject: [PATCH 7/9] Fixup: Fix Source_map uses --- compiler/bin-js_of_ocaml/compile.ml | 2 +- compiler/bin-wasm_of_ocaml/compile.ml | 4 +-- compiler/lib/link_js.ml | 2 +- compiler/lib/source_map.ml | 46 +++++++++++---------------- compiler/lib/source_map.mli | 9 ++---- 5 files changed, 24 insertions(+), 39 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 53069bae..dc1826c6 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -53,7 +53,7 @@ let output_gen ~standalone ~custom_header ~build_info ~source_map output_file f let data = Source_map.to_string sm in "data:application/json;base64," ^ Base64.encode_exn data | Some output_file -> - Source_map.to_file sm ~file:output_file; + Source_map.to_file sm output_file; Filename.basename output_file in Pretty_print.newline fmt; diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index beb883e8..b21cff73 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -30,7 +30,7 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f if Option.is_some sourcemap_root || not sourcemap_don't_inline_content then ( let open Source_map in - let source_map, mappings = Source_map.of_file_no_mappings sourcemap_file in + let source_map = Source_map.of_file sourcemap_file in assert (List.is_empty (Option.value source_map.sources_content ~default:[])); (* Add source file contents to source map *) let sources_content = @@ -50,7 +50,7 @@ let update_sourcemap ~sourcemap_root ~sourcemap_don't_inline_content sourcemap_f (if Option.is_some sourcemap_root then sourcemap_root else source_map.sourceroot) } in - Source_map.to_file ?mappings source_map ~file:sourcemap_file) + Source_map.to_file source_map sourcemap_file) let opt_with action x f = match x with diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index cdd4d610..67a665c5 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -469,7 +469,7 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source let s = sourceMappingURL_base64 ^ Base64.encode_exn data in Line_writer.write oc s | Some file -> - Source_map.to_file sm ~file; + Source_map.to_file sm file; let s = sourceMappingURL ^ Filename.basename file in Line_writer.write oc s)); if times () then Format.eprintf " sourcemap: %a@." Timer.print t diff --git a/compiler/lib/source_map.ml b/compiler/lib/source_map.ml index aa5ec3c5..90b09747 100644 --- a/compiler/lib/source_map.ml +++ b/compiler/lib/source_map.ml @@ -311,7 +311,7 @@ let merge = function (* IO *) -let json ?replace_mappings t = +let json t = let rewrite_path path = if Filename.is_relative path then path @@ -331,11 +331,7 @@ let json ?replace_mappings t = | Some s -> rewrite_path s) ) ; "names", `List (List.map t.names ~f:(fun s -> stringlit s)) ; "sources", `List (List.map t.sources ~f:(fun s -> stringlit (rewrite_path s))) - ; ( "mappings" - , stringlit - (match replace_mappings with - | None -> string_of_mapping t.mappings - | Some m -> m) ) + ; "mappings", stringlit (string_of_mapping t.mappings) ; ( "sourcesContent" , `List (match t.sources_content with @@ -384,7 +380,7 @@ let list_stringlit_opt name rest = | _ -> invalid () with Not_found -> None -let of_json ~parse_mappings (json : Yojson.Raw.t) = +let of_json (json : Yojson.Raw.t) = match json with | `Assoc (("version", `Intlit version) :: rest) when int_of_string version = 3 -> let string name json = Option.map ~f:string_of_stringlit (stringlit name json) in @@ -413,31 +409,25 @@ let of_json ~parse_mappings (json : Yojson.Raw.t) = | None -> None | Some s -> Some (Source_content.of_stringlit s))) in - let mappings_str = string "mappings" rest in let mappings = - match parse_mappings, mappings_str with - | false, _ -> mapping_of_string "" - | true, None -> mapping_of_string "" - | true, Some s -> mapping_of_string s + match string "mappings" rest with + | None -> mapping_of_string "" + | Some s -> mapping_of_string s in - ( { version = int_of_float (float_of_string version) - ; file - ; sourceroot - ; names - ; sources_content - ; sources - ; mappings - } - , if parse_mappings then None else mappings_str ) + { version = int_of_float (float_of_string version) + ; file + ; sourceroot + ; names + ; sources_content + ; sources + ; mappings + } | _ -> invalid () -let of_string s = of_json ~parse_mappings:true (Yojson.Raw.from_string s) |> fst +let of_string s = of_json (Yojson.Raw.from_string s) -let to_string m = Yojson.Raw.to_string (json m) +let of_file filename = of_json (Yojson.Raw.from_file filename) -let to_file ?mappings m ~file = - let replace_mappings = mappings in - Yojson.Raw.to_file file (json ?replace_mappings m) +let to_string m = Yojson.Raw.to_string (json m) -let of_file_no_mappings filename = - of_json ~parse_mappings:false (Yojson.Raw.from_file filename) +let to_file m file = Yojson.Raw.to_file file (json m) diff --git a/compiler/lib/source_map.mli b/compiler/lib/source_map.mli index 5c3d7543..1c305d4c 100644 --- a/compiler/lib/source_map.mli +++ b/compiler/lib/source_map.mli @@ -70,11 +70,6 @@ val to_string : t -> string val of_string : string -> t -val of_file_no_mappings : string -> t * string option -(** Read source map from a file without parsing the mappings (which can be costly). The - [mappings] field is returned empty and the raw string is returned alongside the map. - *) +val to_file : t -> string -> unit -val to_file : ?mappings:string -> t -> file:string -> unit -(** Write to a file. If a string is supplied as [mappings], use it instead of the - sourcemap's [mappings]. *) +val of_file : string -> t From b16557e799356c3a7d25934d785376116f95bee8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 2 Oct 2024 10:49:10 +0200 Subject: [PATCH 8/9] Realign Driver.optimize --- compiler/bin-wasm_of_ocaml/compile.ml | 15 +++++++++++++-- compiler/lib/driver.ml | 2 +- compiler/lib/driver.mli | 2 +- 3 files changed, 15 insertions(+), 4 deletions(-) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index b21cff73..e1f9bf0c 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -141,7 +141,12 @@ let generate_prelude ~out_file = Filename.gen_file out_file @@ fun ch -> let code, uinfo = Parse_bytecode.predefined_exceptions () in - let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize code in + let profile = + match Driver.profile 1 with + | Some p -> p + | None -> assert false + in + let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in let context = Wa_generate.start () in let debug = Parse_bytecode.Debug.create ~include_cmis:false false in let _ = @@ -294,7 +299,13 @@ let run check_debug one; let code = one.code in let standalone = Option.is_none unit_name in - let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ?profile code in + let profile = + match profile, Driver.profile 1 with + | Some p, _ -> p + | None, Some p -> p + | None, None -> assert false + in + let Driver.{ program; variable_uses; in_cps; _ } = Driver.optimize ~profile code in let context = Wa_generate.start () in let debug = one.debug in let toplevel_name, generated_js = diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index ea9c8686..6d05e002 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -658,7 +658,7 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p |> coloring |> check_js -let optimize ?(profile = O1) p = +let optimize ~profile p = let deadcode_sentinal = (* If deadcode is disabled, this field is just fresh variable *) Code.Var.fresh_n "dummy" diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli index 16103a48..91f846b9 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -28,7 +28,7 @@ type optimized_result = ; deadcode_sentinal : Code.Var.t } -val optimize : ?profile:profile -> Code.program -> optimized_result +val optimize : profile:profile -> Code.program -> optimized_result val f : ?standalone:bool From 509636ed543960b398970bb127e8a2a8bac87fda Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 2 Oct 2024 10:59:50 +0200 Subject: [PATCH 9/9] Fix Parse_bytecode types --- compiler/bin-js_of_ocaml/compile.ml | 1 - compiler/bin-wasm_of_ocaml/compile.ml | 1 - compiler/lib/link_js.ml | 8 +------- compiler/lib/parse_bytecode.ml | 18 +++++++----------- compiler/lib/parse_bytecode.mli | 6 ++---- 5 files changed, 10 insertions(+), 24 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index dc1826c6..e0399c4a 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -323,7 +323,6 @@ 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) diff --git a/compiler/bin-wasm_of_ocaml/compile.ml b/compiler/bin-wasm_of_ocaml/compile.ml index e1f9bf0c..5448f089 100644 --- a/compiler/bin-wasm_of_ocaml/compile.ml +++ b/compiler/bin-wasm_of_ocaml/compile.ml @@ -391,7 +391,6 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_exe - ~target:`Wasm ~includes:include_dirs ~include_cmis:false ~link_info:false diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index 67a665c5..6cacff87 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -412,13 +412,7 @@ 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 - ~target:`JavaScript - ~symtable:!sym - ~primitives - ~crcs:[] - in + let code = Parse_bytecode.link_info ~symtable:!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/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index c433d93e..ba5c16b6 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -418,7 +418,7 @@ end (* Parse constants *) module Constants : sig - val parse : target:[ `JavaScript | `Wasm ] -> Obj.t -> Code.constant + val parse : Obj.t -> Code.constant val inlined : Code.constant -> bool end = struct @@ -452,7 +452,7 @@ end = struct let ident_native = ident_of_custom (Obj.repr 0n) - let rec parse ~target x = + let rec parse x = if Obj.is_block x then let tag = Obj.tag x in @@ -485,10 +485,7 @@ end = struct | None -> assert false else if tag < Obj.no_scan_tag then - Tuple - ( tag - , Array.init (Obj.size x) ~f:(fun i -> parse ~target (Obj.field x i)) - , Unknown ) + Tuple (tag, Array.init (Obj.size x) ~f:(fun i -> parse (Obj.field x i)), Unknown) else assert false else let i : int = Obj.magic x in @@ -2613,7 +2610,6 @@ let read_primitives toc ic = String.split_char ~sep:'\000' (String.sub prim ~pos:0 ~len:(String.length prim - 1)) let from_exe - ~target ?(includes = []) ~linkall ~link_info @@ -2627,7 +2623,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 ~target) init_data in + let init_data = Array.map ~f:Constants.parse init_data in let orig_symbols = Toc.read_symb toc ic in let orig_crcs = Toc.read_crcs toc ic in let keeps = @@ -2720,7 +2716,7 @@ let from_exe let gdata = Var.fresh () in let need_gdata = ref false in let infos = - [ "toc", Constants.parse ~target (Obj.repr toc) + [ "toc", Constants.parse (Obj.repr toc) ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in @@ -3141,7 +3137,7 @@ let predefined_exceptions () = in { start = 0; blocks = Addr.Map.singleton 0 block; free_pc = 1 }, unit_info -let link_info ~target ~symtable ~primitives ~crcs = +let link_info ~symtable ~primitives ~crcs = let gdata = Code.Var.fresh_n "global_data" in let symtable_js = Ocaml_compiler.Symtable.GlobalMap.fold @@ -3165,7 +3161,7 @@ let link_info ~target ~symtable ~primitives ~crcs = ] in let infos = - [ "toc", Constants.parse ~target (Obj.repr toc) + [ "toc", Constants.parse (Obj.repr toc) ; "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 863d146c..e34133d3 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -52,8 +52,7 @@ end val read_primitives : Toc.t -> in_channel -> string list val from_exe : - target:[ `JavaScript | `Wasm ] - -> ?includes:string list + ?includes:string list -> linkall:bool -> link_info:bool -> include_cmis:bool @@ -91,8 +90,7 @@ val from_string : val predefined_exceptions : unit -> Code.program * Unit_info.t val link_info : - target:[ `JavaScript | `Wasm ] - -> symtable:Ocaml_compiler.Symtable.GlobalMap.t + symtable:Ocaml_compiler.Symtable.GlobalMap.t -> primitives:StringSet.t -> crcs:(string * Digest.t option) list -> Code.program