From 347bd640284e6c5dd278ef40b52b1656a61aa7f3 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 7 Jun 2024 14:25:28 +0200 Subject: [PATCH 01/32] Target-specific code Co-authored-by: Olivier Nicole --- compiler/bin-js_of_ocaml/build_fs.ml | 2 +- compiler/bin-js_of_ocaml/compile.ml | 10 +- compiler/bin-js_of_ocaml/js_of_ocaml.ml | 1 + compiler/lib/config.ml | 2 +- compiler/lib/driver.ml | 82 +++++++--- compiler/lib/driver.mli | 19 ++- compiler/lib/eval.ml | 128 +++++++++++---- compiler/lib/inline.ml | 11 +- compiler/lib/link_js.ml | 8 +- compiler/lib/ocaml_compiler.ml | 17 +- compiler/lib/ocaml_compiler.mli | 3 +- compiler/lib/parse_bytecode.ml | 204 ++++++++++++++++-------- compiler/lib/parse_bytecode.mli | 14 +- compiler/lib/specialize_js.ml | 49 +++--- compiler/lib/stdlib.ml | 90 ++++++++++- 15 files changed, 473 insertions(+), 167 deletions(-) diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml index 94fb9916cc..84ed7fb55d 100644 --- a/compiler/bin-js_of_ocaml/build_fs.ml +++ b/compiler/bin-js_of_ocaml/build_fs.ml @@ -75,10 +75,10 @@ function jsoo_create_file_extern(name,content){ let pfs_fmt = Pretty_print.to_out_channel chan in let (_ : Source_map.t option) = Driver.f + ~target:(JavaScript pfs_fmt) ~standalone:true ~wrap_with_fun:`Iife ~link:`Needed - pfs_fmt (Parse_bytecode.Debug.create ~include_cmis:false false) code in diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 3e01a30974..8e2f1b812a 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -196,12 +196,12 @@ let run in let code = Code.prepend one.code instr in Driver.f + ~target:(JavaScript fmt) ~standalone ?profile ~link ~wrap_with_fun ?source_map - fmt one.debug code | `File, fmt -> @@ -220,12 +220,12 @@ let run let code = Code.prepend one.code instr in let res = Driver.f + ~target:(JavaScript fmt) ~standalone ?profile ~link ~wrap_with_fun ?source_map - fmt one.debug code in @@ -285,7 +285,7 @@ let run | `None -> let prims = Linker.list_all () |> StringSet.elements in assert (List.length prims > 0); - let code, uinfo = Parse_bytecode.predefined_exceptions () in + let code, uinfo = Parse_bytecode.predefined_exceptions ~target:`JavaScript in let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in let code : Parse_bytecode.one = { code @@ -331,6 +331,7 @@ let run let linkall = linkall || toplevel || dynlink in let code = Parse_bytecode.from_exe + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~link_info:(toplevel || dynlink) @@ -363,6 +364,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -419,6 +421,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -450,6 +453,7 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo + ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug diff --git a/compiler/bin-js_of_ocaml/js_of_ocaml.ml b/compiler/bin-js_of_ocaml/js_of_ocaml.ml index 144543663c..b6db162a15 100644 --- a/compiler/bin-js_of_ocaml/js_of_ocaml.ml +++ b/compiler/bin-js_of_ocaml/js_of_ocaml.ml @@ -22,6 +22,7 @@ open! Js_of_ocaml_compiler.Stdlib open Js_of_ocaml_compiler let () = + Config.set_target `JavaScript; Sys.catch_break true; let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in let argv = diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index 97e8d1fdab..7865b6fd33 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -164,7 +164,7 @@ module Param = struct p ~name:"tc" ~desc:"Set tailcall optimisation" - (enum [ "trampoline", TcTrampoline; (* default *) "none", TcNone ]) + (enum [ "trampoline", TcTrampoline (* default *); "none", TcNone ]) let lambda_lifting_threshold = (* When we reach this depth, we start looking for functions to be lifted *) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 9e812c5024..0581a6144e 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -658,13 +658,34 @@ let configure formatter = Code.Var.set_pretty (pretty && not (Config.Flag.shortvar ())); Code.Var.set_stable (Config.Flag.stable_var ()) -let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p = - let exported_runtime = not standalone in +type 'a target = + | JavaScript : Pretty_print.t -> Source_map.t option target + | Wasm + : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t) + target + +let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p = let export_runtime = match link with | `All | `All_from _ -> true | `Needed | `No -> false in + p + |> link' ~export_runtime ~standalone ~link + |> pack ~wrap_with_fun ~standalone + |> coloring + |> check_js + +let full + (type result) + ~(target : result target) + ~standalone + ~wrap_with_fun + ~profile + ~link + ~source_map + d + p : result = let deadcode_sentinal = (* If deadcode is disabled, this field is just fresh variable *) Code.Var.fresh_n "dummy" @@ -677,56 +698,71 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p = | O3 -> o3) +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal - +> map_fst (if Config.Flag.effects () then fun x -> x else Generate_closure.f) + +> map_fst + (match target with + | JavaScript _ -> if Config.Flag.effects () then Fun.id else Generate_closure.f + | Wasm -> Fun.id) +> map_fst deadcode' in - let emit = - generate - d - ~exported_runtime - ~wrap_with_fun - ~warn_on_unhandled_effect:standalone - ~deadcode_sentinal - +> link' ~export_runtime ~standalone ~link - +> pack ~wrap_with_fun ~standalone - +> coloring - +> check_js - +> output formatter ~source_map () - in if times () then Format.eprintf "Start Optimizing...@."; let t = Timer.make () in let r = opt p in let () = if times () then Format.eprintf " optimizations : %a@." Timer.print t in - emit r + match target with + | JavaScript formatter -> + let exported_runtime = not standalone in + let emit formatter = + generate + d + ~exported_runtime + ~wrap_with_fun + ~warn_on_unhandled_effect:standalone + ~deadcode_sentinal + +> link_and_pack ~standalone ~wrap_with_fun ~link + +> output formatter ~source_map () + in + let source_map = emit formatter r in + source_map + | Wasm -> + let (p, live_vars), _, in_cps = r in + live_vars, in_cps, p, d -let full_no_source_map ~standalone ~wrap_with_fun ~profile ~link formatter d p = +let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p = let (_ : Source_map.t option) = - full ~standalone ~wrap_with_fun ~profile ~link ~source_map:None formatter d p + full + ~target:(JavaScript formatter) + ~standalone + ~wrap_with_fun + ~profile + ~link + ~source_map:None + d + p in () let f + ~target ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link ?source_map - formatter d p = - full ~standalone ~wrap_with_fun ~profile ~link ~source_map formatter d p + full ~target ~standalone ~wrap_with_fun ~profile ~link ~source_map d p let f' ?(standalone = true) ?(wrap_with_fun = `Iife) ?(profile = O1) ~link formatter d p = - full_no_source_map ~standalone ~wrap_with_fun ~profile ~link formatter d p + full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p let from_string ~prims ~debug s formatter = let p, d = Parse_bytecode.from_string ~prims ~debug s in full_no_source_map + ~formatter ~standalone:false ~wrap_with_fun:`Anonymous ~profile:O1 ~link:`No - formatter d p diff --git a/compiler/lib/driver.mli b/compiler/lib/driver.mli index f4562f59e7..1b9eaa616a 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -20,16 +20,22 @@ type profile +type 'a target = + | JavaScript : Pretty_print.t -> Source_map.t option target + | Wasm + : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t) + target + val f : - ?standalone:bool + target:'result target + -> ?standalone:bool -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ] -> ?profile:profile -> link:[ `All | `All_from of string list | `Needed | `No ] -> ?source_map:Source_map.t - -> Pretty_print.t -> Parse_bytecode.Debug.t -> Code.program - -> Source_map.t option + -> 'result val f' : ?standalone:bool @@ -48,6 +54,13 @@ val from_string : -> Pretty_print.t -> unit +val link_and_pack : + ?standalone:bool + -> ?wrap_with_fun:[ `Iife | `Anonymous | `Named of string ] + -> ?link:[ `All | `All_from of string list | `Needed | `No ] + -> Javascript.statement_list + -> Javascript.statement_list + val configure : Pretty_print.t -> unit val profiles : (int * profile) list diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 24c8dbb5ad..2242ef1ce0 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -29,17 +29,49 @@ 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 Int32 = struct + include Int32 -let int_binop l f = - match l with - | [ Int i; Int j ] -> Some (Int (f i j)) - | _ -> None + let int_unop l f = + match l with + | [ Int i ] -> Some (Int (f i)) + | _ -> None -let shift l f = - match l with - | [ Int i; Int j ] -> Some (Int (f i (Int32.to_int j land 0x1f))) - | _ -> 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 +end + +module Int31 = 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 +end let float_binop_aux (l : constant list) (f : float -> float -> 'a) : 'a option = let args = @@ -74,6 +106,16 @@ let float_binop_bool l f = | Some b -> bool b | None -> None +module type Int = sig + include Arith_ops + + val int_unop : constant list -> (t -> t) -> constant option + + val int_binop : constant list -> (t -> t -> t) -> constant option + + val shift_op : constant list -> (t -> int -> t) -> constant option +end + let eval_prim x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) @@ -84,21 +126,26 @@ let eval_prim x = | Ult, [ Int i; Int j ] -> bool (Int32.(j < 0l) || Int32.(i < j)) | Extern name, l -> ( let name = Primitive.resolve name in + let (module Int : Int) = + match Config.target () with + | `JavaScript -> (module Int32) + | `Wasm -> (module Int31) + in match name, l with (* int *) - | "%int_add", _ -> int_binop l Int.add - | "%int_sub", _ -> int_binop l Int.sub - | "%direct_int_mul", _ -> int_binop l Int.mul + | "%int_add", _ -> Int.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 Int.div - | "%direct_int_mod", _ -> int_binop l Int.rem - | "%int_and", _ -> int_binop l Int.logand - | "%int_or", _ -> int_binop l Int.logor - | "%int_xor", _ -> int_binop l Int.logxor - | "%int_lsl", _ -> shift l Int.shift_left - | "%int_lsr", _ -> shift l Int.shift_right_logical - | "%int_asr", _ -> shift l Int.shift_right - | "%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.( <> ) @@ -131,9 +178,9 @@ let eval_prim x = | "caml_sqrt_float", _ -> float_unop l sqrt | "caml_tan_float", _ -> float_unop l tan | ("caml_string_get" | "caml_string_unsafe_get"), [ String s; Int pos ] -> - let pos = Int.to_int pos in + let pos = Int32.to_int pos in if Config.Flag.safe_string () && pos >= 0 && pos < String.length s - then Some (Int (Int.of_int (Char.code s.[pos]))) + then Some (Int (Int32.of_int (Char.code s.[pos]))) else None | "caml_string_equal", [ String s1; String s2 ] -> bool (String.equal s1 s2) | "caml_string_notequal", [ String s1; String s2 ] -> @@ -143,7 +190,12 @@ let eval_prim x = | Some env -> Some (String env) | None -> None) | "caml_sys_const_word_size", [ _ ] -> Some (Int 32l) - | "caml_sys_const_int_size", [ _ ] -> Some (Int 32l) + | "caml_sys_const_int_size", [ _ ] -> + Some + (Int + (match Config.target () with + | `JavaScript -> 32l + | `Wasm -> 31l)) | "caml_sys_const_big_endian", [ _ ] -> Some (Int 0l) | "caml_sys_const_naked_pointers_checked", [ _ ] -> Some (Int 0l) | _ -> None) @@ -178,6 +230,9 @@ let is_int info x = (fun x -> match Flow.Info.def info x with | Some (Constant (Int _)) -> Y + | Some (Constant (NativeInt _ | Int32 _)) -> + assert (Poly.equal (Config.target ()) `Wasm); + N | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) Unknown @@ -188,6 +243,9 @@ let is_int info x = | _ -> Unknown) x | Pc (Int _) -> Y + | Pc (NativeInt _ | Int32 _) -> + assert (Poly.equal (Config.target ()) `Wasm); + N | Pc _ -> N let the_tag_of info x get = @@ -330,7 +388,12 @@ let eval_instr info ((x, loc) as i) = | None -> [ i ]) | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in - [ Let (jsoo, Constant (String "js_of_ocaml")), noloc + let backend_name = + match Config.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"), _)) -> @@ -359,14 +422,17 @@ let eval_instr info ((x, loc) as i) = ( x , Prim ( prim - , List.map2 prim_args prim_args' ~f:(fun arg c -> - match c with - | Some ((Int _ | Float _ | NativeString _) as c) -> Pc c - | Some (String _ as c) when Config.Flag.use_js_string () -> Pc c - | Some _ + , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> + match c, Config.target () with + | ( Some ((Int _ | Int32 _ | NativeInt _ | NativeString _) as c) + , _ ) -> Pc c + | Some (Float _ as c), `JavaScript -> Pc c + | Some (String _ as c), `JavaScript + when Config.Flag.use_js_string () -> Pc c + | Some _, _ (* do not be duplicated other constant as they're not represented with constant in javascript. *) - | None -> arg) ) ) + | None, _ -> arg) ) ) , loc ) ]) | _ -> [ i ] diff --git a/compiler/lib/inline.ml b/compiler/lib/inline.ml index c6e8dd4b8e..e6707e50d5 100644 --- a/compiler/lib/inline.ml +++ b/compiler/lib/inline.ml @@ -167,7 +167,7 @@ let rec args_equal xs ys = | x :: xs, Pv y :: ys -> Code.Var.compare x y = 0 && args_equal xs ys | _ -> false -let inline live_vars closures name pc (outer, p) = +let inline ~first_class_primitives live_vars closures name pc (outer, p) = let block = Addr.Map.find pc p.blocks in let body, (outer, branch, p) = List.fold_right @@ -300,7 +300,7 @@ let inline live_vars closures name pc (outer, p) = , (outer, (Branch (fresh_addr, args), No), { p with blocks; free_pc }) ) | _ -> i :: rem, state) - | Let (x, Closure (l, (pc, []))), loc when not (Config.Flag.effects ()) -> ( + | Let (x, Closure (l, (pc, []))), loc when first_class_primitives -> ( let block = Addr.Map.find pc p.blocks in match block with | { body = [ (Let (y, Prim (Extern prim, args)), _loc) ] @@ -323,6 +323,11 @@ let inline live_vars closures name pc (outer, p) = let times = Debug.find "times" let f p live_vars = + let first_class_primitives = + match Config.target () with + | `JavaScript -> not (Config.Flag.effects ()) + | `Wasm -> false + in Code.invariant p; let t = Timer.make () in let closures = get_closures p in @@ -333,7 +338,7 @@ let f p live_vars = let traverse outer = Code.traverse { fold = Code.fold_children } - (inline live_vars closures name) + (inline ~first_class_primitives live_vars closures name) pc p.blocks (outer, p) diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index e4d3d2989e..4fa3778fb9 100644 --- a/compiler/lib/link_js.ml +++ b/compiler/lib/link_js.ml @@ -412,7 +412,13 @@ let link ~output ~linkall ~mklib ~toplevel ~files ~resolve_sourcemap_url ~source List.fold_left units ~init:StringSet.empty ~f:(fun acc (u : Unit_info.t) -> StringSet.union acc (StringSet.of_list u.primitives)) in - let code = Parse_bytecode.link_info ~symbols:!sym ~primitives ~crcs:[] in + let code = + Parse_bytecode.link_info + ~target:`JavaScript + ~symbols:!sym + ~primitives + ~crcs:[] + in let b = Buffer.create 100 in let fmt = Pretty_print.to_buffer b in Driver.configure fmt; diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 12fcb3ab63..d8020a8411 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -18,11 +18,15 @@ open! Stdlib -let rec constant_of_const : _ -> Code.constant = +let rec constant_of_const ~target c : Code.constant = let open Lambda in let open Asttypes in - function - | Const_base (Const_int i) -> Int (Int32.of_int_warning_on_overflow i) + match c with + | Const_base (Const_int i) -> + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.(of_int_warning_on_overflow i |> 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 @@ -35,9 +39,12 @@ let rec constant_of_const : _ -> Code.constant = let l = List.map ~f:(fun f -> float_of_string f) sl in Float_array (Array.of_list l) | ((Const_pointer i) [@if ocaml_version < (4, 12, 0)]) -> - Int (Int32.of_int_warning_on_overflow i) + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) | Const_block (tag, l) -> - let l = Array.of_list (List.map l ~f:constant_of_const) in + let l = Array.of_list (List.map l ~f:(fun c -> constant_of_const ~target c)) in Tuple (tag, l, Unknown) let rec find_loc_in_summary ident' = function diff --git a/compiler/lib/ocaml_compiler.mli b/compiler/lib/ocaml_compiler.mli index 227f1b9f31..409381a562 100644 --- a/compiler/lib/ocaml_compiler.mli +++ b/compiler/lib/ocaml_compiler.mli @@ -16,7 +16,8 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) -val constant_of_const : Lambda.structured_constant -> Code.constant +val constant_of_const : + target:[ `JavaScript | `Wasm ] -> Lambda.structured_constant -> Code.constant val find_loc_in_summary : Ident.t -> Env.summary -> Location.t option diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 18ef20b8df..4611259751 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -443,7 +443,7 @@ end (* Parse constants *) module Constants : sig - val parse : Obj.t -> Code.constant + val parse : target:[ `JavaScript | `Wasm ] -> Obj.t -> Code.constant val inlined : Code.constant -> bool end = struct @@ -477,7 +477,7 @@ end = struct let ident_native = ident_of_custom (Obj.repr 0n) - let rec parse x = + let rec parse ~target x = if Obj.is_block x then let tag = Obj.tag x in @@ -503,11 +503,17 @@ end = struct | None -> assert false else if tag < Obj.no_scan_tag then - Tuple (tag, Array.init (Obj.size x) ~f:(fun i -> parse (Obj.field x i)), Unknown) + Tuple + ( tag + , Array.init (Obj.size x) ~f:(fun i -> parse ~target (Obj.field x i)) + , Unknown ) else assert false else let i : int = Obj.magic x in - Int (Int32.of_int_warning_on_overflow i) + Int + (match target with + | `JavaScript -> Int32.of_int_warning_on_overflow i + | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) let inlined = function | String _ | NativeString _ -> false @@ -763,8 +769,25 @@ let access_global g i = g.vars.(i) <- Some x; x -let register_global ?(force = false) g i loc rem = - if force || g.is_exported.(i) +let register_global ~target ?(force = false) g i loc rem = + if g.is_exported.(i) + && + match target with + | `Wasm -> true + | `JavaScript -> false + then ( + let name = + match g.named_value.(i) with + | None -> assert false + | Some name -> name + in + Code.Var.name (access_global g i) name; + ( Let + ( Var.fresh () + , Prim (Extern "caml_set_global", [ Pc (String name); Pv (access_global g i) ]) ) + , loc ) + :: rem) + else if force || g.is_exported.(i) then let args = match g.named_value.(i) with @@ -782,25 +805,40 @@ let register_global ?(force = false) g i loc rem = :: rem else rem -let get_global state instrs i loc = +let get_global ~target state instrs i loc = State.size_globals state (i + 1); let g = State.globals state in match g.vars.(i) with | Some x -> if debug_parser () then Format.printf "(global access %a)@." Var.print x; x, State.set_accu state x loc, instrs - | None -> + | None -> ( if i < Array.length g.constants && Constants.inlined g.constants.(i) then let x, state = State.fresh_var state loc in let cst = g.constants.(i) in x, state, (Let (x, Constant cst), loc) :: instrs - else ( + else if i < Array.length g.constants + || + match target with + | `Wasm -> false + | `JavaScript -> true + then ( g.is_const.(i) <- true; let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = CONST(%d)@." Var.print x i; g.vars.(i) <- Some x; x, state, instrs) + else + match g.named_value.(i) with + | None -> assert false + | Some name -> + let x, state = State.fresh_var state loc in + if debug_parser () then Format.printf "%a = get_global(%s)@." Var.print x name; + ( x + , state + , (Let (x, Prim (Extern "caml_get_global", [ Pc (String name) ])), loc) + :: instrs )) let tagged_blocks = ref Addr.Map.empty @@ -815,6 +853,7 @@ type compile_info = ; code : string ; limit : int ; debug : Debug.t + ; target : [ `JavaScript | `Wasm ] } let string_of_addr debug_data addr = @@ -842,7 +881,7 @@ let ( ||| ) x y = | No -> y | _ -> x -let rec compile_block blocks debug_data code pc state = +let rec compile_block blocks debug_data ~target code pc state = match Addr.Map.find_opt pc !tagged_blocks with | Some old_state -> ( (* Check that the shape of the stack is compatible with the one used to compile the block *) @@ -874,7 +913,7 @@ let rec compile_block blocks debug_data code pc state = let state = State.start_block pc state in tagged_blocks := Addr.Map.add pc state !tagged_blocks; let instr, last, state' = - compile { blocks; code; limit; debug = debug_data } pc state [] + compile { blocks; code; limit; debug = debug_data; target } pc state [] in assert (not (Addr.Map.mem pc !compiled_blocks)); (* When jumping to a block that was already visited and the @@ -903,10 +942,11 @@ let rec compile_block blocks debug_data code pc state = in compiled_blocks := Addr.Map.add pc (state, List.rev instr, last) !compiled_blocks; match fst last with - | Branch (pc', _) -> compile_block blocks debug_data code pc' (adjust_state pc') + | Branch (pc', _) -> + compile_block blocks debug_data ~target code pc' (adjust_state pc') | Cond (_, (pc1, _), (pc2, _)) -> - compile_block blocks debug_data code pc1 (adjust_state pc1); - compile_block blocks debug_data code pc2 (adjust_state pc2) + compile_block blocks debug_data ~target code pc1 (adjust_state pc1); + compile_block blocks debug_data ~target code pc2 (adjust_state pc2) | Poptrap (_, _) -> () | Switch (_, _) -> () | Raise _ | Return _ | Stop -> () @@ -1248,7 +1288,7 @@ and compile infos pc state instrs = let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in - compile_block infos.blocks infos.debug code addr state'; + compile_block infos.blocks infos.debug ~target:infos.target code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let state'', _, _ = Addr.Map.find addr !compiled_blocks in @@ -1305,7 +1345,7 @@ and compile infos pc state instrs = let params, state' = State.make_stack nparams state' loc in if debug_parser () then Format.printf ") {@."; let state' = State.clear_accu state' in - compile_block infos.blocks infos.debug code addr state'; + compile_block infos.blocks infos.debug ~target:infos.target code addr state'; if debug_parser () then Format.printf "}@."; let args = State.stack_vars state' in let state'', _, _ = Addr.Map.find addr !compiled_blocks in @@ -1335,16 +1375,16 @@ and compile infos pc state instrs = compile infos (pc + 2) (State.env_acc n state) instrs | GETGLOBAL -> let i = getu code (pc + 1) in - let _, state, instrs = get_global state instrs i loc in + let _, state, instrs = get_global ~target:infos.target state instrs i loc in compile infos (pc + 2) state instrs | PUSHGETGLOBAL -> let state = State.push state loc in let i = getu code (pc + 1) in - let _, state, instrs = get_global state instrs i loc in + let _, state, instrs = get_global ~target:infos.target state instrs i loc in compile infos (pc + 2) state instrs | GETGLOBALFIELD -> let i = getu code (pc + 1) in - let x, state, instrs = get_global state instrs i loc in + let x, state, instrs = get_global ~target:infos.target state instrs i loc in let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; @@ -1353,7 +1393,7 @@ and compile infos pc state instrs = let state = State.push state loc in let i = getu code (pc + 1) in - let x, state, instrs = get_global state instrs i loc in + let x, state, instrs = get_global ~target:infos.target state instrs i loc in let j = getu code (pc + 2) in let y, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = %a[%d]@." Var.print y Var.print x j; @@ -1378,7 +1418,7 @@ and compile infos pc state instrs = in let x, state = State.fresh_var state loc in if debug_parser () then Format.printf "%a = 0@." Var.print x; - let instrs = register_global g i loc instrs in + let instrs = register_global ~target:infos.target g i loc instrs in compile infos (pc + 2) state ((Let (x, const 0l), loc) :: instrs) | ATOM0 -> let x, state = State.fresh_var state loc in @@ -1726,9 +1766,9 @@ and compile infos pc state instrs = let it = Array.init isize ~f:(fun i -> base + gets code (base + i)) in let bt = Array.init bsize ~f:(fun i -> base + gets code (base + isize + i)) in Array.iter it ~f:(fun pc' -> - compile_block infos.blocks infos.debug code pc' state); + compile_block infos.blocks infos.debug ~target:infos.target code pc' state); Array.iter bt ~f:(fun pc' -> - compile_block infos.blocks infos.debug code pc' state); + compile_block infos.blocks infos.debug ~target:infos.target code pc' state); match isize, bsize with | _, 0 -> instrs, (Switch (x, Array.map it ~f:(fun pc -> pc, [])), loc), state | 0, _ -> @@ -1799,10 +1839,17 @@ and compile infos pc state instrs = , (handler_addr, State.stack_vars handler_state) ) , loc ) ) !compiled_blocks; - compile_block infos.blocks infos.debug code handler_addr handler_state; compile_block infos.blocks infos.debug + ~target:infos.target + code + handler_addr + handler_state; + compile_block + infos.blocks + infos.debug + ~target:infos.target code body_addr { (State.push_handler handler_ctx_state) with @@ -1820,6 +1867,7 @@ and compile infos pc state instrs = compile_block infos.blocks infos.debug + ~target:infos.target code addr (State.pop 4 (State.pop_handler state)); @@ -2503,7 +2551,7 @@ type one = ; debug : Debug.t } -let parse_bytecode code globals debug_data = +let parse_bytecode code globals debug_data ~target = let state = State.initial globals in Code.Var.reset (); let blocks = Blocks.analyse debug_data code in @@ -2518,7 +2566,7 @@ let parse_bytecode code globals debug_data = if not (Blocks.is_empty blocks') then ( let start = 0 in - compile_block blocks' debug_data code start state; + compile_block blocks' debug_data ~target code start state; let blocks = Addr.Map.mapi (fun _ (state, instr, last) -> @@ -2638,6 +2686,7 @@ type bytesections = [@@ocaml.warning "-unused-field"] let from_exe + ~target ?(includes = []) ~linkall ~link_info @@ -2651,7 +2700,7 @@ let from_exe let primitive_table = Array.of_list primitives in let code = Toc.read_code toc ic in let init_data = Toc.read_data toc ic in - let init_data = Array.map ~f:Constants.parse init_data in + let init_data = Array.map ~f:(Constants.parse ~target) init_data in let orig_symbols = Toc.read_symb toc ic in let orig_crcs = Toc.read_crcs toc ic in let keeps = @@ -2706,12 +2755,12 @@ let from_exe Ocaml_compiler.Symtable.GlobalMap.iter symbols ~f:(fun id n -> globals.named_value.(n) <- Some (Ocaml_compiler.Symtable.Global.name id); globals.is_exported.(n) <- true); - let p = parse_bytecode code globals debug_data in + let p = parse_bytecode code globals debug_data ~target in (* register predefined exception *) let body = List.fold_left predefined_exceptions ~init:[] ~f:(fun body (i, name) -> globals.named_value.(i) <- Some name; - let body = register_global ~force:true globals i noloc body in + let body = register_global ~target ~force:true globals i noloc body in globals.is_exported.(i) <- false; body) in @@ -2719,7 +2768,7 @@ let from_exe Array.fold_right_i globals.constants ~init:body ~f:(fun i _ l -> match globals.vars.(i) with | Some x when globals.is_const.(i) -> - let l = register_global globals i noloc l in + let l = register_global ~target globals i noloc l in (Let (x, Constant globals.constants.(i)), noloc) :: l | _ -> l) in @@ -2738,8 +2787,8 @@ let from_exe let gdata = Var.fresh () in let need_gdata = ref false in let infos = - [ "sections", Constants.parse (Obj.repr sections) - ; "symbols", Constants.parse (Obj.repr symbols_array) + [ "sections", Constants.parse ~target (Obj.repr sections) + ; "symbols", Constants.parse ~target (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in @@ -2830,7 +2879,7 @@ let from_bytes ~prims ~debug (code : bytecode) = t in let globals = make_globals 0 [||] prims in - let p = parse_bytecode code globals debug_data in + let p = parse_bytecode code globals debug_data ~target:`JavaScript in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let find_name i = @@ -2895,13 +2944,13 @@ module Reloc = struct let constant_of_const x = Constants.parse x [@@if ocaml_version >= (5, 1, 0)] (* We currently rely on constants to be relocated before globals. *) - let step1 t compunit code = + let step1 ~target t compunit code = if t.step2_started then assert false; let open Cmo_format in List.iter compunit.cu_primitives ~f:(fun name -> Hashtbl.add t.primitives name (Hashtbl.length t.primitives)); let slot_for_literal sc = - t.constants <- constant_of_const sc :: t.constants; + t.constants <- constant_of_const ~target sc :: t.constants; let pos = t.pos in t.pos <- succ t.pos; pos @@ -2969,16 +3018,16 @@ module Reloc = struct globals end -let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = +let from_compilation_units ~target ~includes:_ ~include_cmis ~debug_data l = let reloc = Reloc.create () in - List.iter l ~f:(fun (compunit, code) -> Reloc.step1 reloc compunit code); + List.iter l ~f:(fun (compunit, code) -> Reloc.step1 ~target reloc compunit code); List.iter l ~f:(fun (compunit, code) -> Reloc.step2 reloc compunit code); let globals = Reloc.make_globals reloc in let code = let l = List.map l ~f:(fun (_, c) -> Bytes.to_string c) in String.concat ~sep:"" l in - let prog = parse_bytecode code globals debug_data in + let prog = parse_bytecode code globals debug_data ~target in let gdata = Var.fresh_n "global_data" in let need_gdata = ref false in let body = @@ -2987,7 +3036,7 @@ let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = | Some x when globals.is_const.(i) -> ( match globals.named_value.(i) with | None -> - let l = register_global globals i noloc l in + let l = register_global ~target globals i noloc l in let cst = globals.constants.(i) in (match cst, Code.Var.get_name x with | String str, None -> Code.Var.name x (Printf.sprintf "cst_%s" str) @@ -3020,7 +3069,8 @@ let from_compilation_units ~includes:_ ~include_cmis ~debug_data l = in { code = prepend prog body; cmis; debug = debug_data } -let from_cmo ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit ic = +let from_cmo ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit ic + = let debug_data = Debug.create ~include_cmis debug in seek_in ic compunit.Cmo_format.cu_pos; let code = Bytes.create compunit.Cmo_format.cu_codesize in @@ -3031,11 +3081,13 @@ let from_cmo ?(includes = []) ?(include_cmis = false) ?(debug = false) compunit seek_in ic compunit.Cmo_format.cu_debug; Debug.read_event_list debug_data ~crcs:[] ~includes ~orig:0 ic); if times () then Format.eprintf " read debug events: %a@." Timer.print t; - let p = from_compilation_units ~includes ~include_cmis ~debug_data [ compunit, code ] in + let p = + from_compilation_units ~target ~includes ~include_cmis ~debug_data [ compunit, code ] + in Code.invariant p.code; p -let from_cma ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = +let from_cma ~target ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = let debug_data = Debug.create ~include_cmis debug in let orig = ref 0 in let t = ref 0. in @@ -3054,7 +3106,7 @@ let from_cma ?(includes = []) ?(include_cmis = false) ?(debug = false) lib ic = compunit, code) in if times () then Format.eprintf " read debug events: %.2f@." !t; - let p = from_compilation_units ~includes ~include_cmis ~debug_data units in + let p = from_compilation_units ~target ~includes ~include_cmis ~debug_data units in Code.invariant p.code; p @@ -3099,7 +3151,7 @@ let from_channel ic = `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) -let predefined_exceptions () = +let predefined_exceptions ~target = let body = let open Code in List.map predefined_exceptions ~f:(fun (index, name) -> @@ -3108,25 +3160,45 @@ let predefined_exceptions () = let v_name = Var.fresh () in let v_name_js = Var.fresh () in let v_index = Var.fresh () in - [ Let (v_name, Constant (String name)), noloc - ; Let (v_name_js, Constant (NativeString (Native_string.of_string name))), noloc - ; ( Let - ( v_index - , Constant - (Int - ((* Predefined exceptions are registered in - Symtable.init with [-index - 1] *) - Int32.of_int - (-index - 1))) ) - , noloc ) - ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc - ; ( Let - ( Var.fresh () - , Prim - ( Extern "caml_register_global" - , [ Pc (Int (Int32.of_int index)); Pv exn; Pv v_name_js ] ) ) - , noloc ) - ]) + [ Let (v_name, Constant (String name)), noloc ] + @ (match target with + | `Wasm -> [] + | `JavaScript -> + [ ( Let (v_name_js, Constant (NativeString (Native_string.of_string name))) + , noloc ) + ]) + @ [ ( Let + ( v_index + , Constant + (Int + ((* Predefined exceptions are registered in + Symtable.init with [-index - 1] *) + Int32.of_int + (-index - 1))) ) + , noloc ) + ; Let (exn, Block (248, [| v_name; v_index |], NotArray, Immutable)), noloc + ; ( Let + ( Var.fresh () + , Prim + ( Extern "caml_register_global" + , [ Pc (Int (Int32.of_int index)) + ; Pv exn + ; Pv + (match target with + | `JavaScript -> v_name_js + | `Wasm -> v_name) + ] ) ) + , noloc ) + ] + @ + match target with + | `JavaScript -> [] + | `Wasm -> + [ ( Let + ( Var.fresh () + , Prim (Extern "caml_set_global", [ Pc (String name); Pv exn ]) ) + , noloc ) + ]) |> List.concat in let block = { params = []; body; branch = Stop, noloc } in @@ -3141,7 +3213,7 @@ let predefined_exceptions () = in { start = 0; blocks = Addr.Map.singleton 0 block; free_pc = 1 }, unit_info -let link_info ~symbols ~primitives ~crcs = +let link_info ~target ~symbols ~primitives ~crcs = let gdata = Code.Var.fresh_n "global_data" in let symbols_array = Ocaml_compiler.Symtable.GlobalMap.fold @@ -3159,8 +3231,8 @@ let link_info ~symbols ~primitives ~crcs = (* Include linking information *) let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in let infos = - [ "sections", Constants.parse (Obj.repr sections) - ; "symbols", Constants.parse (Obj.repr symbols_array) + [ "sections", Constants.parse ~target (Obj.repr sections) + ; "symbols", Constants.parse ~target (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (List.length primitives)) ] in diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 627f65fdd0..33edf53f1c 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -52,7 +52,8 @@ end val read_primitives : Toc.t -> in_channel -> string list val from_exe : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> linkall:bool -> link_info:bool -> include_cmis:bool @@ -62,7 +63,8 @@ val from_exe : -> one val from_cmo : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.compilation_unit @@ -70,7 +72,8 @@ val from_cmo : -> one val from_cma : - ?includes:string list + target:[ `JavaScript | `Wasm ] + -> ?includes:string list -> ?include_cmis:bool -> ?debug:bool -> Cmo_format.library @@ -87,10 +90,11 @@ val from_string : -> string -> Code.program * Debug.t -val predefined_exceptions : unit -> Code.program * Unit_info.t +val predefined_exceptions : target:[ `JavaScript | `Wasm ] -> Code.program * Unit_info.t val link_info : - symbols:Ocaml_compiler.Symtable.GlobalMap.t + target:[ `JavaScript | `Wasm ] + -> symbols:Ocaml_compiler.Symtable.GlobalMap.t -> primitives:StringSet.t -> crcs:(string * Digest.t option) list -> Code.program diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 9fdce562be..162b877582 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -23,47 +23,49 @@ open Code open Flow let specialize_instr info i = - match i with - | Let (x, Prim (Extern "caml_format_int", [ y; z ])) -> ( + match i, Config.target () with + | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( match the_string_of info y with | Some "%d" -> ( match the_int info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> Let (x, Prim (Extern "%caml_format_int_special", [ z ]))) | _ -> i) - | Let (x, Prim (Extern "%caml_format_int_special", [ z ])) -> ( + | Let (x, Prim (Extern "%caml_format_int_special", [ z ])), `JavaScript -> ( match the_int info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> i) (* inline the String constant argument so that generate.ml can attempt to parse it *) - | Let - ( x - , Prim - ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) - , [ (Pv _ as y) ] ) ) + | ( Let + ( x + , Prim + ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) + , [ (Pv _ as y) ] ) ) + , _ ) when Config.Flag.safe_string () -> ( match the_string_of info y with | Some s -> Let (x, Prim (Extern prim, [ Pc (String s) ])) | _ -> i) - | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])) -> ( + | Let (x, Prim (Extern ("caml_register_named_value" as prim), [ y; z ])), `JavaScript + -> ( match the_string_of info y with | Some s when Primitive.need_named_value s -> Let (x, Prim (Extern prim, [ Pc (String s); z ])) | Some _ -> Let (x, Constant (Int 0l)) | None -> i) - | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])) -> ( + | Let (x, Prim (Extern "caml_js_call", [ f; o; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_call", f :: o :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])) -> ( + | Let (x, Prim (Extern "caml_js_fun_call", [ f; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])) -> ( + | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> ( match the_string_of info m with | Some m when Javascript.is_ident m -> ( match the_def_of info a with @@ -78,13 +80,13 @@ let specialize_instr info i = :: Array.to_list a ) ) | _ -> i) | _ -> i) - | Let (x, Prim (Extern "caml_js_new", [ c; a ])) -> ( + | Let (x, Prim (Extern "caml_js_new", [ c; a ])), _ -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> let a = Array.map a ~f:(fun x -> Pv x) in Let (x, Prim (Extern "%caml_js_opt_new", c :: Array.to_list a)) | _ -> i) - | Let (x, Prim (Extern "caml_js_object", [ a ])) -> ( + | Let (x, Prim (Extern "caml_js_object", [ a ])), _ -> ( try let a = match the_def_of info a with @@ -109,43 +111,44 @@ let specialize_instr info i = in Let (x, Prim (Extern "%caml_js_opt_object", List.flatten (Array.to_list a))) with Exit -> i) - | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])) -> ( + | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_get", [ o; Pc (NativeString s) ])) | _ -> i) - | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])) -> ( + | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_set", [ o; Pc (NativeString s); v ])) | _ -> i) - | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])) -> ( + | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])), _ -> ( match the_native_string_of info f with | Some s -> Let (x, Prim (Extern "caml_js_delete", [ o; Pc (NativeString s) ])) | _ -> i) - | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])) -> ( + | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])), _ + -> ( match the_string_of info y with | Some s when String.is_valid_utf_8 s -> Let (x, Constant (NativeString (Native_string.of_string s))) | Some _ | None -> i) - | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])) -> ( + | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])), _ -> ( match the_string_of info y with | Some s -> Let (x, Constant (NativeString (Native_string.of_bytestring s))) | None -> i) - | Let (x, Prim (Extern "%int_mul", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_mul", [ y; z ])), `JavaScript -> ( match the_int info y, the_int info z with | Some j, _ when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _, Some j when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _ -> i) - | Let (x, Prim (Extern "%int_div", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_div", [ y; z ])), _ -> ( match the_int info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_div", [ y; z ])) | _ -> i) - | Let (x, Prim (Extern "%int_mod", [ y; z ])) -> ( + | Let (x, Prim (Extern "%int_mod", [ y; z ])), _ -> ( match the_int info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_mod", [ y; z ])) | _ -> i) - | _ -> i + | _, _ -> i let equal2 a b = Code.Var.equal a b diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index d67f4b0483..abd4bc9afd 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -341,7 +341,51 @@ 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 = private int32 + + include Arith_ops with type t := t + + val of_int_warning_on_overflow : int -> t + + val of_nativeint_warning_on_overflow : nativeint -> t + + val to_int32 : t -> int32 + + val of_int32_warning_on_overflow : int32 -> t + + val to_int : t -> int +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 +405,50 @@ 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 neg = Int32.neg + + let int_binop wrap f x y = wrap (f x y) + + let add = int_binop wrap Int32.add + + let sub = int_binop wrap Int32.sub + + let mul = int_binop wrap Int32.mul + + let div = int_binop wrap Int32.div + + let rem = int_binop wrap Int32.rem + + let logand = int_binop wrap Int32.logand + + let logor = int_binop wrap Int32.logor + + let logxor = int_binop wrap Int32.logxor + + let shift_op wrap truncate f x y = + (* Limit the shift offset to [0, 31] *) + wrap (f (truncate x) (y land 0x1f)) + + let shift_left = shift_op wrap Fun.id Int32.shift_left + + let shift_right = shift_op wrap Fun.id Int32.shift_right + + let shift_right_logical = + shift_op wrap (fun i -> Int32.logand i 0x7fffffffl) Int32.shift_right_logical + + let to_int32 (x : t) : int32 = x + + let to_int (x : t) = Int32.to_int x end module Option = struct From a5351eba2c8ab7c229ee1e5fc42d94ffd684cbe2 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 13 Sep 2024 20:52:50 +0200 Subject: [PATCH 02/32] Update changelog --- CHANGES.md | 2 ++ 1 file changed, 2 insertions(+) diff --git a/CHANGES.md b/CHANGES.md index 4ff15d42ae..8814ee7bda 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,8 @@ * Runtime: allow dynlink of precompiled js with separate compilation (#1676) * Lib: Modify Typed_array API for compatibility with WebAssembly * Compiler: improved global dead code elimination (#2206) +* Compiler: add support for the Wasm backend in parts of the pipeline, in + prevision for the merge of wasm_of_ocaml ## Bug fixes From 3badf5e166ef17c95a03ff5f020f5fd74aef5749 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Sep 2024 10:46:42 +0200 Subject: [PATCH 03/32] CR: remove GADT --- compiler/bin-js_of_ocaml/build_fs.ml | 2 +- compiler/bin-js_of_ocaml/compile.ml | 8 +-- compiler/lib/driver.ml | 80 ++++++++++------------------ compiler/lib/driver.mli | 18 ++++--- 4 files changed, 43 insertions(+), 65 deletions(-) diff --git a/compiler/bin-js_of_ocaml/build_fs.ml b/compiler/bin-js_of_ocaml/build_fs.ml index 84ed7fb55d..16ac22a23d 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/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 8e2f1b812a..d3e924e807 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -186,7 +186,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 @@ -196,15 +196,15 @@ let run in let code = Code.prepend one.code instr in Driver.f - ~target:(JavaScript fmt) ~standalone ?profile ~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, [] @@ -220,12 +220,12 @@ let run let code = Code.prepend one.code instr in let res = Driver.f - ~target:(JavaScript fmt) ~standalone ?profile ~link ~wrap_with_fun ?source_map + ~formatter one.debug code in diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 0581a6144e..6c60557fb8 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -658,12 +658,6 @@ 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 link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p = let export_runtime = match link with @@ -676,20 +670,7 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p |> coloring |> check_js -let full - (type result) - ~(target : result target) - ~standalone - ~wrap_with_fun - ~profile - ~link - ~source_map - d - p : result = - let deadcode_sentinal = - (* If deadcode is disabled, this field is just fresh variable *) - Code.Var.fresh_n "dummy" - in +let optimize ~profile ~deadcode_sentinal p = let opt = specialize_js_once +> (match profile with @@ -699,58 +680,53 @@ let full +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal +> map_fst - (match target with - | JavaScript _ -> if Config.Flag.effects () then Fun.id else Generate_closure.f - | Wasm -> Fun.id) + (match Config.target () with + | `JavaScript -> if Config.Flag.effects () then Fun.id else Generate_closure.f + | `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 () = 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 - ~deadcode_sentinal - +> link_and_pack ~standalone ~wrap_with_fun ~link - +> output formatter ~source_map () - in - let source_map = emit formatter r in - source_map - | Wasm -> - let (p, live_vars), _, in_cps = r in - live_vars, in_cps, p, d + r + +let full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p = + let deadcode_sentinal = + (* If deadcode is disabled, this field is just fresh variable *) + Code.Var.fresh_n "dummy" + in + let r = optimize ~profile ~deadcode_sentinal p in + let exported_runtime = not standalone in + let emit formatter = + generate + d + ~exported_runtime + ~wrap_with_fun + ~warn_on_unhandled_effect:standalone + ~deadcode_sentinal + +> link_and_pack ~standalone ~wrap_with_fun ~link + +> output formatter ~source_map () + in + let source_map = emit formatter r in + source_map 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 1b9eaa616a..7f3e16bb4f 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -20,22 +20,24 @@ type profile -type 'a target = - | JavaScript : Pretty_print.t -> Source_map.t option target - | Wasm - : (Deadcode.variable_uses * Effects.in_cps * Code.program * Parse_bytecode.Debug.t) - target +val optimize : + profile:profile + -> deadcode_sentinal:Code.Var.t + -> Code.program + -> (Code.program * Deadcode.variable_uses) + * Effects.trampolined_calls + * Effects.trampolined_calls 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 From eb3956905c7a5fa8df83ed1c9365680ca64bf048 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 19 Sep 2024 16:00:11 +0200 Subject: [PATCH 04/32] CR --- compiler/bin-js_of_ocaml/compile.ml | 6 +- compiler/lib/config.ml | 9 ++- compiler/lib/driver.ml | 26 +++++-- compiler/lib/driver.mli | 16 ++-- compiler/lib/eval.ml | 63 +++++++++------ compiler/lib/link_js.ml | 8 +- compiler/lib/ocaml_compiler.ml | 8 +- compiler/lib/ocaml_compiler.mli | 3 +- compiler/lib/parse_bytecode.ml | 115 ++++++++++++---------------- compiler/lib/parse_bytecode.mli | 14 ++-- compiler/lib/specialize_js.ml | 14 ++-- 11 files changed, 142 insertions(+), 140 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index d3e924e807..ba99440925 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -285,7 +285,7 @@ let run | `None -> let prims = Linker.list_all () |> StringSet.elements in assert (List.length prims > 0); - let code, uinfo = Parse_bytecode.predefined_exceptions ~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 @@ -331,7 +331,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) @@ -364,7 +363,6 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo - ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -421,7 +419,6 @@ let run let t1 = Timer.make () in let code = Parse_bytecode.from_cmo - ~target:`JavaScript ~includes:include_dirs ~include_cmis ~debug:need_debug @@ -453,7 +450,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/lib/config.ml b/compiler/lib/config.ml index 7865b6fd33..caf8f55be6 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -183,8 +183,11 @@ end (****) -let target_ : [ `JavaScript | `Wasm ] ref = ref `JavaScript +let target_ : [ `JavaScript | `Wasm ] option ref = ref (Some `JavaScript) -let target () = !target_ +let target () = + match !target_ with + | Some t -> t + | None -> failwith "target was not set" -let set_target t = target_ := t +let set_target t = target_ := Some t diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 6c60557fb8..64dfbb75ac 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -670,7 +670,19 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p |> coloring |> check_js -let optimize ~profile ~deadcode_sentinal p = +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 + } + +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 @@ -687,16 +699,14 @@ let optimize ~profile ~deadcode_sentinal p = 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 - r + { program; variable_uses; trampolined_calls; in_cps; deadcode_sentinal } let full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p = - let deadcode_sentinal = - (* If deadcode is disabled, this field is just fresh variable *) - Code.Var.fresh_n "dummy" + let { program; variable_uses; trampolined_calls; in_cps; deadcode_sentinal } = + optimize ~profile p in - let r = optimize ~profile ~deadcode_sentinal p in let exported_runtime = not standalone in let emit formatter = generate @@ -708,7 +718,7 @@ let full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p = +> link_and_pack ~standalone ~wrap_with_fun ~link +> output formatter ~source_map () in - let source_map = emit formatter r in + let source_map = emit formatter ((program, variable_uses), trampolined_calls, in_cps) in source_map let 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 7f3e16bb4f..91f846b989 100644 --- a/compiler/lib/driver.mli +++ b/compiler/lib/driver.mli @@ -20,13 +20,15 @@ type profile -val optimize : - profile:profile - -> deadcode_sentinal:Code.Var.t - -> Code.program - -> (Code.program * Deadcode.variable_uses) - * Effects.trampolined_calls - * Effects.trampolined_calls +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 : ?standalone:bool diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 2242ef1ce0..ab4183f302 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -47,6 +47,8 @@ module Int32 = struct match l with | [ Int i; Int j ] -> Some (Int (f i (to_int j))) | _ -> None + + let numbits = 32 end module Int31 = struct @@ -71,6 +73,8 @@ module Int31 = struct | [ 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 = @@ -114,9 +118,15 @@ module type Int = sig 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 -let eval_prim x = +let eval_prim ~target x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) | Lt, [ Int i; Int j ] -> bool Int32.(i < j) @@ -127,8 +137,15 @@ let eval_prim x = | Extern name, l -> ( let name = Primitive.resolve name in let (module Int : Int) = - match Config.target () with - | `JavaScript -> (module Int32) + match target with + | `JavaScript -> + (module struct + include Int32 + + let of_int32_warning_on_overflow = Fun.id + + let to_int32 = Fun.id + end) | `Wasm -> (module Int31) in match name, l with @@ -158,7 +175,9 @@ let eval_prim 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 (Int32.of_float f)) + | "caml_int_of_float", [ Float f ] -> + Some + (Int (Int32.of_float f |> Int.of_int32_warning_on_overflow |> Int.to_int32)) | "to_int", [ Float f ] -> Some (Int (Int32.of_float f)) | "to_int", [ Int i ] -> Some (Int i) (* Math *) @@ -190,12 +209,7 @@ let eval_prim x = | Some env -> Some (String env) | None -> None) | "caml_sys_const_word_size", [ _ ] -> Some (Int 32l) - | "caml_sys_const_int_size", [ _ ] -> - Some - (Int - (match Config.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) @@ -222,7 +236,7 @@ type is_int = | N | Unknown -let is_int info x = +let is_int ~target info x = match x with | Pv x -> get_approx @@ -231,7 +245,7 @@ let is_int info x = match Flow.Info.def info x with | Some (Constant (Int _)) -> Y | Some (Constant (NativeInt _ | Int32 _)) -> - assert (Poly.equal (Config.target ()) `Wasm); + assert (Poly.equal target `Wasm); N | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) @@ -244,7 +258,7 @@ let is_int info x = x | Pc (Int _) -> Y | Pc (NativeInt _ | Int32 _) -> - assert (Poly.equal (Config.target ()) `Wasm); + assert (Poly.equal target `Wasm); N | Pc _ -> N @@ -316,7 +330,7 @@ let constant_js_equal a b = | Tuple _, _ | _, Tuple _ -> None -let eval_instr info ((x, loc) as i) = +let eval_instr ~target info ((x, loc) as i) = match x with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( match the_const_of info y, the_const_of info z with @@ -373,7 +387,7 @@ let eval_instr info ((x, loc) as i) = below fail. *) [ i ] | Let (x, Prim (IsInt, [ y ])) -> ( - match is_int info y with + match is_int ~target info y with | Unknown -> [ i ] | (Y | N) as b -> let c = Constant (bool' Poly.(b = Y)) in @@ -389,7 +403,7 @@ let eval_instr info ((x, loc) as i) = | Let (x, Prim (Extern "caml_sys_const_backend_type", [ _ ])) -> let jsoo = Code.Var.fresh () in let backend_name = - match Config.target () with + match target with | `JavaScript -> "js_of_ocaml" | `Wasm -> "wasm_of_ocaml" in @@ -406,6 +420,7 @@ let eval_instr info ((x, loc) as i) = | _ -> false) then eval_prim + ~target ( prim , List.map prim_args' ~f:(function | Some c -> c @@ -423,9 +438,13 @@ let eval_instr info ((x, loc) as i) = , Prim ( prim , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> - match c, Config.target () with - | ( Some ((Int _ | Int32 _ | NativeInt _ | NativeString _) as c) - , _ ) -> Pc c + match c, target with + | Some ((Int _ | NativeString _) as c), _ -> Pc c + | Some ((Int32 _ | NativeInt _) as c), `Wasm -> Pc c + | Some (Int32 _ | NativeInt _), `JavaScript -> + invalid_arg + "Constant of type Int32 or NativeInt unexpected in the \ + JavaScript backend" | Some (Float _ as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript when Config.Flag.use_js_string () -> Pc c @@ -554,15 +573,15 @@ let drop_exception_handler blocks = blocks blocks -let eval info blocks = +let eval ~target info blocks = Addr.Map.map (fun block -> - let body = List.concat_map block.body ~f:(eval_instr info) in + let body = List.concat_map block.body ~f:(eval_instr ~target info) in let branch = eval_branch info block.branch in { block with Code.body; Code.branch }) blocks let f info p = - let blocks = eval info p.blocks in + let blocks = eval ~target:(Config.target ()) info p.blocks in let blocks = drop_exception_handler blocks in { p with blocks } diff --git a/compiler/lib/link_js.ml b/compiler/lib/link_js.ml index 4fa3778fb9..e4d3d2989e 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 - ~symbols:!sym - ~primitives - ~crcs:[] - in + let code = Parse_bytecode.link_info ~symbols:!sym ~primitives ~crcs:[] in let b = Buffer.create 100 in let fmt = Pretty_print.to_buffer b in Driver.configure fmt; diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index d8020a8411..2518753d5f 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -18,13 +18,13 @@ 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 |> to_int32)) | Const_base (Const_char c) -> Int (Int32.of_int (Char.code c)) @@ -40,11 +40,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 |> 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/ocaml_compiler.mli b/compiler/lib/ocaml_compiler.mli index 409381a562..227f1b9f31 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 4611259751..0db004cdf9 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -443,7 +443,7 @@ end (* Parse constants *) module Constants : sig - val parse : target:[ `JavaScript | `Wasm ] -> Obj.t -> Code.constant + val parse : Obj.t -> Code.constant val inlined : Code.constant -> bool end = struct @@ -477,7 +477,7 @@ end = struct let ident_native = ident_of_custom (Obj.repr 0n) - let rec parse ~target x = + let rec parse x = if Obj.is_block x then let tag = Obj.tag x in @@ -503,15 +503,12 @@ 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 Int - (match target with + (match Config.target () with | `JavaScript -> Int32.of_int_warning_on_overflow i | `Wasm -> Int31.(of_int_warning_on_overflow i |> to_int32)) @@ -769,10 +766,10 @@ let access_global g i = g.vars.(i) <- Some x; x -let register_global ~target ?(force = false) g i loc rem = +let register_global ?(force = false) g i loc rem = if g.is_exported.(i) && - match target with + match Config.target () with | `Wasm -> true | `JavaScript -> false then ( @@ -805,7 +802,7 @@ let register_global ~target ?(force = false) g i loc rem = :: rem else 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 @@ -820,7 +817,7 @@ let get_global ~target state instrs i loc = x, state, (Let (x, Constant cst), loc) :: instrs else if i < Array.length g.constants || - match target with + match Config.target () with | `Wasm -> false | `JavaScript -> true then ( @@ -853,7 +850,6 @@ type compile_info = ; code : string ; limit : int ; debug : Debug.t - ; target : [ `JavaScript | `Wasm ] } let string_of_addr debug_data addr = @@ -881,7 +877,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 = match Addr.Map.find_opt pc !tagged_blocks with | Some old_state -> ( (* Check that the shape of the stack is compatible with the one used to compile the block *) @@ -913,7 +909,7 @@ let rec compile_block blocks debug_data ~target code pc state = let state = State.start_block pc state in tagged_blocks := Addr.Map.add pc state !tagged_blocks; let instr, last, state' = - compile { blocks; code; limit; debug = debug_data; target } pc state [] + compile { blocks; code; limit; debug = debug_data } pc state [] in assert (not (Addr.Map.mem pc !compiled_blocks)); (* When jumping to a block that was already visited and the @@ -942,11 +938,10 @@ let rec compile_block blocks debug_data ~target code pc state = in compiled_blocks := Addr.Map.add pc (state, List.rev instr, last) !compiled_blocks; match fst last with - | Branch (pc', _) -> - compile_block blocks debug_data ~target code pc' (adjust_state pc') + | Branch (pc', _) -> compile_block blocks debug_data code pc' (adjust_state pc') | Cond (_, (pc1, _), (pc2, _)) -> - compile_block blocks debug_data ~target code pc1 (adjust_state pc1); - compile_block blocks debug_data ~target code pc2 (adjust_state pc2) + compile_block blocks debug_data code pc1 (adjust_state pc1); + compile_block blocks debug_data code pc2 (adjust_state pc2) | Poptrap (_, _) -> () | Switch (_, _) -> () | Raise _ | Return _ | Stop -> () @@ -1288,7 +1283,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 @@ -1345,7 +1340,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 @@ -1375,16 +1370,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; @@ -1393,7 +1388,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; @@ -1418,7 +1413,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 @@ -1766,9 +1761,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, [])), loc), state | 0, _ -> @@ -1839,17 +1834,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 @@ -1867,7 +1855,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)); @@ -2551,7 +2538,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 @@ -2566,7 +2553,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) -> @@ -2686,7 +2673,6 @@ type bytesections = [@@ocaml.warning "-unused-field"] let from_exe - ~target ?(includes = []) ~linkall ~link_info @@ -2700,7 +2686,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 = @@ -2755,12 +2741,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 @@ -2768,7 +2754,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 @@ -2787,8 +2773,8 @@ let from_exe let gdata = Var.fresh () in let need_gdata = ref false in let infos = - [ "sections", Constants.parse ~target (Obj.repr sections) - ; "symbols", Constants.parse ~target (Obj.repr symbols_array) + [ "sections", Constants.parse (Obj.repr sections) + ; "symbols", Constants.parse (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (Array.length globals.primitives)) ] in @@ -2879,7 +2865,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 = @@ -2944,13 +2930,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 @@ -3018,16 +3004,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 = @@ -3036,7 +3022,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) @@ -3069,8 +3055,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 @@ -3081,13 +3066,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 @@ -3106,7 +3089,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 @@ -3151,7 +3134,7 @@ let from_channel ic = `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) -let predefined_exceptions ~target = +let predefined_exceptions = let body = let open Code in List.map predefined_exceptions ~f:(fun (index, name) -> @@ -3161,7 +3144,7 @@ let predefined_exceptions ~target = let v_name_js = Var.fresh () in let v_index = Var.fresh () in [ Let (v_name, Constant (String name)), noloc ] - @ (match target with + @ (match Config.target () with | `Wasm -> [] | `JavaScript -> [ ( Let (v_name_js, Constant (NativeString (Native_string.of_string name))) @@ -3184,14 +3167,14 @@ let predefined_exceptions ~target = , [ Pc (Int (Int32.of_int index)) ; Pv exn ; Pv - (match target with + (match Config.target () with | `JavaScript -> v_name_js | `Wasm -> v_name) ] ) ) , noloc ) ] @ - match target with + match Config.target () with | `JavaScript -> [] | `Wasm -> [ ( Let @@ -3213,7 +3196,7 @@ let predefined_exceptions ~target = in { start = 0; blocks = Addr.Map.singleton 0 block; free_pc = 1 }, unit_info -let link_info ~target ~symbols ~primitives ~crcs = +let link_info ~symbols ~primitives ~crcs = let gdata = Code.Var.fresh_n "global_data" in let symbols_array = Ocaml_compiler.Symtable.GlobalMap.fold @@ -3231,8 +3214,8 @@ let link_info ~target ~symbols ~primitives ~crcs = (* Include linking information *) let sections = { symb = symbols; crcs; prim = primitives; dlpt = [] } in let infos = - [ "sections", Constants.parse ~target (Obj.repr sections) - ; "symbols", Constants.parse ~target (Obj.repr symbols_array) + [ "sections", Constants.parse (Obj.repr sections) + ; "symbols", Constants.parse (Obj.repr symbols_array) ; "prim_count", Int (Int32.of_int (List.length primitives)) ] in diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index 33edf53f1c..dac8e266d9 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 @@ -63,8 +62,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 +70,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,11 +87,10 @@ val from_string : -> string -> Code.program * Debug.t -val predefined_exceptions : target:[ `JavaScript | `Wasm ] -> Code.program * Unit_info.t +val predefined_exceptions : Code.program * Unit_info.t val link_info : - target:[ `JavaScript | `Wasm ] - -> symbols:Ocaml_compiler.Symtable.GlobalMap.t + symbols:Ocaml_compiler.Symtable.GlobalMap.t -> primitives:StringSet.t -> crcs:(string * Digest.t option) list -> Code.program diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 162b877582..e8fa7b9535 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -22,8 +22,8 @@ open! Stdlib open Code open Flow -let specialize_instr info i = - match i, Config.target () with +let specialize_instr ~target info i = + match i, target with | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( match the_string_of info y with | Some "%d" -> ( @@ -156,7 +156,7 @@ let equal3 a b c = Code.Var.equal a b && Code.Var.equal b c let equal4 a b c d = Code.Var.equal a b && Code.Var.equal b c && Code.Var.equal c d -let specialize_instrs info l = +let specialize_instrs ~target info l = let rec aux info checks l acc = match l with | [] -> List.rev acc @@ -285,22 +285,22 @@ let specialize_instrs info l = in aux info ((y, idx) :: checks) r acc | _ -> - let i = specialize_instr info i in + let i = specialize_instr ~target info i in aux info checks r ((i, loc) :: acc)) in aux info [] l [] -let specialize_all_instrs info p = +let specialize_all_instrs ~target info p = let blocks = Addr.Map.map - (fun block -> { block with Code.body = specialize_instrs info block.body }) + (fun block -> { block with Code.body = specialize_instrs ~target info block.body }) p.blocks in { p with blocks } (****) -let f info p = specialize_all_instrs info p +let f info p = specialize_all_instrs ~target:(Config.target ()) info p let f_once p = let rec loop acc l = From 0440867b404258a4e075b4d3724da2af915ea032 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Sep 2024 11:12:25 +0200 Subject: [PATCH 05/32] CR --- compiler/bin-js_of_ocaml/compile.ml | 2 +- compiler/lib/eval.ml | 54 +++++++++++++---------------- compiler/lib/parse_bytecode.ml | 2 +- compiler/lib/parse_bytecode.mli | 2 +- 4 files changed, 28 insertions(+), 32 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index ba99440925..60a0110b08 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -285,7 +285,7 @@ let run | `None -> let prims = Linker.list_all () |> StringSet.elements in assert (List.length prims > 0); - let code, uinfo = Parse_bytecode.predefined_exceptions in + let code, uinfo = Parse_bytecode.predefined_exceptions () in let uinfo = { uinfo with primitives = uinfo.primitives @ prims } in let code : Parse_bytecode.one = { code diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index ab4183f302..a1559a49ab 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -29,6 +29,22 @@ 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 type Int = sig + include Arith_ops + + val int_unop : constant list -> (t -> t) -> constant option + + 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 @@ -49,9 +65,13 @@ module Int32 = struct | _ -> None let numbits = 32 + + let of_int32_warning_on_overflow = Fun.id + + let to_int32 = Fun.id end -module Int31 = struct +module Int31 : Int = struct include Int31 let int_unop l f = @@ -110,23 +130,7 @@ let float_binop_bool l f = | Some b -> bool b | None -> None -module type Int = sig - include Arith_ops - - val int_unop : constant list -> (t -> t) -> constant option - - 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 - -let eval_prim ~target x = +let eval_prim x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) | Lt, [ Int i; Int j ] -> bool Int32.(i < j) @@ -135,19 +139,12 @@ 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 (module Int : Int) = - match target with - | `JavaScript -> - (module struct - include Int32 - - let of_int32_warning_on_overflow = Fun.id - - let to_int32 = Fun.id - end) + match Config.target () with + | `JavaScript -> (module Int32) | `Wasm -> (module Int31) in + let name = Primitive.resolve name in match name, l with (* int *) | "%int_add", _ -> Int.int_binop l Int.add @@ -420,7 +417,6 @@ let eval_instr ~target info ((x, loc) as i) = | _ -> false) then eval_prim - ~target ( prim , List.map prim_args' ~f:(function | Some c -> c diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 0db004cdf9..d73323dedd 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -3134,7 +3134,7 @@ let from_channel ic = `Exe | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) -let predefined_exceptions = +let predefined_exceptions () = let body = let open Code in List.map predefined_exceptions ~f:(fun (index, name) -> diff --git a/compiler/lib/parse_bytecode.mli b/compiler/lib/parse_bytecode.mli index dac8e266d9..627f65fdd0 100644 --- a/compiler/lib/parse_bytecode.mli +++ b/compiler/lib/parse_bytecode.mli @@ -87,7 +87,7 @@ val from_string : -> string -> Code.program * Debug.t -val predefined_exceptions : Code.program * Unit_info.t +val predefined_exceptions : unit -> Code.program * Unit_info.t val link_info : symbols:Ocaml_compiler.Symtable.GlobalMap.t From 6bd522bd4095b6cf0b26145c66f13b7c201c11a3 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Sep 2024 15:36:17 +0200 Subject: [PATCH 06/32] Fix constant_identical for Wasm target --- compiler/lib/eval.ml | 12 +++---- compiler/lib/flow.ml | 61 ++++++++++++++++++----------------- compiler/lib/flow.mli | 11 ++++--- compiler/lib/specialize_js.ml | 34 +++++++++---------- 4 files changed, 61 insertions(+), 57 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index a1559a49ab..47dbf26f80 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -212,14 +212,14 @@ let eval_prim x = | _ -> None) | _ -> None -let the_length_of info x = +let the_length_of ~target info x = get_approx info (fun x -> match Flow.Info.def info x with | Some (Constant (String s)) -> Some (Int32.of_int (String.length s)) | Some (Prim (Extern "caml_create_string", [ arg ])) - | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg + | Some (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg | None | Some _ -> None) None (fun u v -> @@ -330,7 +330,7 @@ let constant_js_equal a b = let eval_instr ~target info ((x, loc) as i) = match x with | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( - match the_const_of info y, the_const_of info z with + match the_const_of ~target info y, the_const_of ~target info z with | Some e1, Some e2 -> ( match Code.Constant.ocaml_equal e1 e2 with | None -> [ i ] @@ -346,7 +346,7 @@ let eval_instr ~target info ((x, loc) as i) = [ Let (x, c), loc ]) | _ -> [ i ]) | Let (x, Prim (Extern ("caml_js_equals" | "caml_js_strict_equals"), [ y; z ])) -> ( - match the_const_of info y, the_const_of info z with + match the_const_of ~target info y, the_const_of ~target info z with | Some e1, Some e2 -> ( match constant_js_equal e1 e2 with | None -> [ i ] @@ -359,7 +359,7 @@ let eval_instr ~target info ((x, loc) as i) = let c = match s with | Pc (String s) -> Some (Int32.of_int (String.length s)) - | Pv v -> the_length_of info v + | Pv v -> the_length_of ~target info v | _ -> None in match c with @@ -410,7 +410,7 @@ let eval_instr ~target info ((x, loc) as i) = | Let (_, Prim (Extern ("%resume" | "%perform" | "%reperform"), _)) -> [ i ] (* We need that the arguments to this primitives remain variables *) | Let (x, Prim (prim, prim_args)) -> ( - let prim_args' = List.map prim_args ~f:(fun x -> the_const_of info x) in + let prim_args' = List.map prim_args ~f:(fun x -> the_const_of ~target info x) in let res = if List.for_all prim_args' ~f:(function | Some _ -> true diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 138622b4f7..9943166836 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -343,30 +343,31 @@ let the_def_of info x = (* If [constant_identical a b = true], then the two values cannot be distinguished, i.e., they are not different objects (and [caml_js_equals a b = true]) and if both are floats, they are bitwise equal. *) -let constant_identical a b = - match a, b with - | Int i, Int j -> Int32.equal i j - | Float a, Float b -> Float.bitwise_equal a b - | NativeString a, NativeString b -> Native_string.equal a b - | String a, String b -> Config.Flag.use_js_string () && String.equal a b - | Int _, Float _ | Float _, Int _ -> false +let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = + match a, b, target with + | Int i, Int j, _ -> Int32.equal i j + | Float a, Float b, `JavaScript -> Float.bitwise_equal a b + | Float _, Float _, `Wasm -> false + | NativeString a, NativeString b, `JavaScript -> Native_string.equal a b + | String a, String b, `JavaScript -> Config.Flag.use_js_string () && String.equal a b + | Int _, Float _, _ | Float _, Int _, _ -> 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 - -let the_const_of info x = + | String _, _, _ + | _, String _, _ + | NativeString _, _, _ + | _, NativeString _, _ + | Float_array _, _, _ + | _, Float_array _, _ + | Int64 _, _, _ + | _, Int64 _, _ + | Int32 _, _, _ + | _, Int32 _, _ + | NativeInt _, _, _ + | _, NativeInt _, _ + | Tuple _, _, _ + | _, Tuple _, _ -> false + +let the_const_of ~target info x = match x with | Pv x -> get_approx @@ -381,23 +382,23 @@ let the_const_of info x = None (fun u v -> match u, v with - | Some i, Some j when constant_identical i j -> u + | Some i, Some j when constant_identical ~target i j -> u | _ -> None) x | Pc c -> Some c -let the_int info x = - match the_const_of info x with +let the_int ~target info x = + match the_const_of ~target info x with | Some (Int i) -> Some i | _ -> None -let the_string_of info x = - match the_const_of info x with +let the_string_of ~target info x = + match the_const_of info ~target x with | Some (String i) -> Some i | _ -> None -let the_native_string_of info x = - match the_const_of info x with +let the_native_string_of ~target info x = + match the_const_of ~target info x with | Some (NativeString i) -> Some i | _ -> None diff --git a/compiler/lib/flow.mli b/compiler/lib/flow.mli index c2033e0c6c..1dd89af353 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -52,12 +52,15 @@ val get_approx : val the_def_of : Info.t -> Code.prim_arg -> Code.expr option -val the_const_of : Info.t -> Code.prim_arg -> Code.constant option +val the_const_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.constant option -val the_string_of : Info.t -> Code.prim_arg -> string option +val the_string_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> string option -val the_native_string_of : Info.t -> Code.prim_arg -> Code.Native_string.t option +val the_native_string_of : + target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> Code.Native_string.t option -val the_int : Info.t -> Code.prim_arg -> int32 option +val the_int : target:[ `JavaScript | `Wasm ] -> Info.t -> Code.prim_arg -> int32 option val f : ?skip_param:bool -> Code.program -> Code.program * Info.t diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index e8fa7b9535..22ffdab84c 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -25,14 +25,14 @@ open Flow let specialize_instr ~target info i = match i, target with | Let (x, Prim (Extern "caml_format_int", [ y; z ])), `JavaScript -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some "%d" -> ( - match the_int info z with + match the_int ~target info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> Let (x, Prim (Extern "%caml_format_int_special", [ z ]))) | _ -> i) | Let (x, Prim (Extern "%caml_format_int_special", [ z ])), `JavaScript -> ( - match the_int info z with + match the_int ~target info z with | Some i -> Let (x, Constant (String (Int32.to_string i))) | None -> i) (* inline the String constant argument so that generate.ml can attempt to parse it *) @@ -43,12 +43,12 @@ let specialize_instr ~target info i = , [ (Pv _ as y) ] ) ) , _ ) when Config.Flag.safe_string () -> ( - match the_string_of info y with + 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 -> ( - match the_string_of info y with + 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 ])) | Some _ -> Let (x, Constant (Int 0l)) @@ -66,7 +66,7 @@ let specialize_instr ~target info i = Let (x, Prim (Extern "%caml_js_opt_fun_call", f :: Array.to_list a)) | _ -> i) | Let (x, Prim (Extern "caml_js_meth_call", [ o; m; a ])), _ -> ( - match the_string_of info m with + match the_string_of ~target info m with | Some m when Javascript.is_ident m -> ( match the_def_of info a with | Some (Block (_, a, _, _)) -> @@ -98,7 +98,7 @@ let specialize_instr ~target info i = match the_def_of info (Pv x) with | Some (Block (_, [| k; v |], _, _)) -> let k = - match the_string_of info (Pv k) with + match the_string_of ~target info (Pv k) with | Some s when String.is_valid_utf_8 s -> Pc (NativeString (Native_string.of_string s)) | Some _ | None -> raise Exit @@ -112,40 +112,40 @@ let specialize_instr ~target info i = Let (x, Prim (Extern "%caml_js_opt_object", List.flatten (Array.to_list a))) with Exit -> i) | Let (x, Prim (Extern "caml_js_get", [ o; (Pv _ as f) ])), _ -> ( - match the_native_string_of info f with + match the_native_string_of ~target info f with | Some s -> Let (x, Prim (Extern "caml_js_get", [ o; Pc (NativeString s) ])) | _ -> i) | Let (x, Prim (Extern "caml_js_set", [ o; (Pv _ as f); v ])), _ -> ( - match the_native_string_of info f with + match the_native_string_of ~target info f with | Some s -> Let (x, Prim (Extern "caml_js_set", [ o; Pc (NativeString s); v ])) | _ -> i) | Let (x, Prim (Extern "caml_js_delete", [ o; (Pv _ as f) ])), _ -> ( - match the_native_string_of info f with + match the_native_string_of ~target info f with | Some s -> Let (x, Prim (Extern "caml_js_delete", [ o; Pc (NativeString s) ])) | _ -> i) | Let (x, Prim (Extern ("caml_jsstring_of_string" | "caml_js_from_string"), [ y ])), _ -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some s when String.is_valid_utf_8 s -> Let (x, Constant (NativeString (Native_string.of_string s))) | Some _ | None -> i) | Let (x, Prim (Extern "caml_jsbytes_of_string", [ y ])), _ -> ( - match the_string_of info y with + match the_string_of ~target info y with | Some s -> Let (x, Constant (NativeString (Native_string.of_bytestring s))) | None -> i) | Let (x, Prim (Extern "%int_mul", [ y; z ])), `JavaScript -> ( - match the_int info y, the_int info z with + 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 ])) | _, Some j when Int32.(abs j < 0x200000l) -> Let (x, Prim (Extern "%direct_int_mul", [ y; z ])) | _ -> i) | Let (x, Prim (Extern "%int_div", [ y; z ])), _ -> ( - match the_int info z with + match the_int ~target info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_div", [ y; z ])) | _ -> i) | Let (x, Prim (Extern "%int_mod", [ y; z ])), _ -> ( - match the_int info z with + match the_int ~target info z with | Some j when Int32.(j <> 0l) -> Let (x, Prim (Extern "%direct_int_mod", [ y; z ])) | _ -> i) | _, _ -> i @@ -208,7 +208,7 @@ let specialize_instrs ~target info l = | "caml_array_get_addr" ) as prim) , [ y; z ] ) ) -> let idx = - match the_int info z with + match the_int ~target info z with | Some idx -> `Cst idx | None -> `Var z in @@ -251,7 +251,7 @@ let specialize_instrs ~target info l = | "caml_array_set_addr" ) as prim) , [ y; z; t ] ) ) -> let idx = - match the_int info z with + match the_int ~target info z with | Some idx -> `Cst idx | None -> `Var z in From f817ece7a03f01bb6392a0f3a145f329b57d657d Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Sep 2024 18:42:50 +0200 Subject: [PATCH 07/32] Fix wrong start value for Config.target --- compiler/lib/config.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/lib/config.ml b/compiler/lib/config.ml index caf8f55be6..aad34fd42c 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -183,7 +183,7 @@ end (****) -let target_ : [ `JavaScript | `Wasm ] option ref = ref (Some `JavaScript) +let target_ : [ `JavaScript | `Wasm ] option ref = ref None let target () = match !target_ with From ca7fced6928354d26e722aaf8610b1ec09db6701 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Sat, 21 Sep 2024 23:52:21 +0200 Subject: [PATCH 08/32] CR: Config.target --- compiler/bin-js_of_ocaml/compile.ml | 1 + compiler/bin-js_of_ocaml/link.ml | 1 + compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml | 1 + compiler/lib-runtime-files/gen/gen.ml | 1 + compiler/lib/config.ml | 9 +++++---- 5 files changed, 9 insertions(+), 4 deletions(-) diff --git a/compiler/bin-js_of_ocaml/compile.ml b/compiler/bin-js_of_ocaml/compile.ml index 60a0110b08..cc7b2c34c6 100644 --- a/compiler/bin-js_of_ocaml/compile.ml +++ b/compiler/bin-js_of_ocaml/compile.ml @@ -90,6 +90,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; Linker.reset (); (match output_file with diff --git a/compiler/bin-js_of_ocaml/link.ml b/compiler/bin-js_of_ocaml/link.ml index 45c2dd0c0e..0cd273b600 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; Linker.reset (); let with_output f = diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 8ff9e3d8eb..583323ab62 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -26,6 +26,7 @@ let normalize_bytecode code = Bytes.to_string b let () = + Config.set_target `JavaScript; 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 bdf330f4e8..7f920cc953 100644 --- a/compiler/lib-runtime-files/gen/gen.ml +++ b/compiler/lib-runtime-files/gen/gen.ml @@ -51,6 +51,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/config.ml b/compiler/lib/config.ml index aad34fd42c..d38b798f69 100644 --- a/compiler/lib/config.ml +++ b/compiler/lib/config.ml @@ -183,11 +183,12 @@ end (****) -let target_ : [ `JavaScript | `Wasm ] option ref = ref None +let target_ : [ `JavaScript | `Wasm | `None ] ref = ref `None let target () = match !target_ with - | Some t -> t - | None -> failwith "target was not set" + | `None -> failwith "target was not set" + | (`JavaScript | `Wasm) as t -> t -let set_target t = target_ := Some t +let set_target (t : [ `JavaScript | `Wasm ]) = + target_ := (t :> [ `JavaScript | `Wasm | `None ]) From 56f2ea4f74c53d49d8ddff23779d48c879ae1ed9 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 12:41:57 +0200 Subject: [PATCH 09/32] CR --- compiler/bin-js_of_ocaml/js_of_ocaml.ml | 1 - compiler/lib/code.ml | 15 ++++++++++++- compiler/lib/eval.ml | 8 +++---- compiler/lib/ocaml_compiler.ml | 2 +- compiler/lib/stdlib.ml | 28 +++++++++++++++---------- 5 files changed, 36 insertions(+), 18 deletions(-) diff --git a/compiler/bin-js_of_ocaml/js_of_ocaml.ml b/compiler/bin-js_of_ocaml/js_of_ocaml.ml index b6db162a15..144543663c 100644 --- a/compiler/bin-js_of_ocaml/js_of_ocaml.ml +++ b/compiler/bin-js_of_ocaml/js_of_ocaml.ml @@ -22,7 +22,6 @@ open! Js_of_ocaml_compiler.Stdlib open Js_of_ocaml_compiler let () = - Config.set_target `JavaScript; Sys.catch_break true; let argv = Jsoo_cmdline.normalize_argv ~warn:(warn "%s") Sys.argv in let argv = diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 6b4c2d09f3..f67b2615ce 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -870,6 +870,14 @@ let invariant { blocks; start; _ } = assert (not (Var.ISet.mem defs x)); Var.ISet.add defs x) in + let check_prim_arg = function + | Pc (NativeInt _ | Int32 _) -> + assert ( + match Config.target () with + | `Wasm -> true + | _ -> false) + | Pc _ | Pv _ -> () + in let check_expr = function | Apply _ -> () | Block (_, _, _, _) -> () @@ -877,8 +885,13 @@ let invariant { blocks; start; _ } = | Closure (l, cont) -> List.iter l ~f:define; check_cont cont + | Constant (NativeInt _ | Int32 _) -> + assert ( + match Config.target () with + | `Wasm -> true + | _ -> false) | Constant _ -> () - | Prim (_, _) -> () + | Prim (_, args) -> List.iter ~f:check_prim_arg args | Special _ -> () in let check_instr (i, _loc) = diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 47dbf26f80..1ee05f3731 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -233,7 +233,7 @@ type is_int = | N | Unknown -let is_int ~target info x = +let is_int info x = match x with | Pv x -> get_approx @@ -242,7 +242,7 @@ let is_int ~target info x = match Flow.Info.def info x with | Some (Constant (Int _)) -> Y | Some (Constant (NativeInt _ | Int32 _)) -> - assert (Poly.equal target `Wasm); + (* These Wasm-specific constants are boxed *) N | Some (Block (_, _, _, _) | Constant _) -> N | None | Some _ -> Unknown) @@ -255,7 +255,7 @@ let is_int ~target info x = x | Pc (Int _) -> Y | Pc (NativeInt _ | Int32 _) -> - assert (Poly.equal target `Wasm); + (* These Wasm-specific constants are boxed *) N | Pc _ -> N @@ -384,7 +384,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 diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 2518753d5f..21a524c774 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -44,7 +44,7 @@ let rec constant_of_const c : Code.constant = | `JavaScript -> Int32.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 c)) in + let l = Array.of_list (List.map l ~f:constant_of_const) in Tuple (tag, l, Unknown) let rec find_loc_in_summary ident' = function diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index abd4bc9afd..d2186c7a92 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -370,7 +370,7 @@ module type Arith_ops = sig end module Int31 : sig - type t = private int32 + type t include Arith_ops with type t := t @@ -415,25 +415,31 @@ end = struct ~to_hex:(Printf.sprintf "%lx") n - let neg = Int32.neg + 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 wrap f x y = wrap (f x y) + let int_binop f x y = wrap (f x y) - let add = int_binop wrap Int32.add + let add = int_binop Int32.add - let sub = int_binop wrap Int32.sub + let sub = int_binop Int32.sub - let mul = int_binop wrap Int32.mul + let mul = int_binop Int32.mul - let div = int_binop wrap Int32.div + let div = int_binop Int32.div - let rem = int_binop wrap Int32.rem + let rem = int_binop Int32.rem - let logand = int_binop wrap Int32.logand + let logand = int_binop Int32.logand - let logor = int_binop wrap Int32.logor + let logor = int_binop Int32.logor - let logxor = int_binop wrap Int32.logxor + let logxor = int_binop Int32.logxor let shift_op wrap truncate f x y = (* Limit the shift offset to [0, 31] *) From 377abe2f65b65851900c2c0ded28ad8675aa0f88 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 12:52:17 +0200 Subject: [PATCH 10/32] CR --- compiler/lib/specialize_js.ml | 9 ++++++--- 1 file changed, 6 insertions(+), 3 deletions(-) diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 22ffdab84c..607d73fc30 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -41,12 +41,12 @@ 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 ) + when (Poly.equal target `Wasm || Config.Flag.safe_string ()) -> ( 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 -> @@ -134,6 +134,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 ])) From 767a4d4dae2b7762522a6a96774b65a462b1a39e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 12:58:24 +0200 Subject: [PATCH 11/32] ocamlformat --- compiler/lib/specialize_js.ml | 5 ++--- 1 file changed, 2 insertions(+), 3 deletions(-) diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 607d73fc30..143bf0a7e1 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -42,12 +42,11 @@ let specialize_instr ~target info i = ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) , [ (Pv _ as y) ] ) ) , target ) - when (Poly.equal target `Wasm || Config.Flag.safe_string ()) -> ( + when Poly.equal target `Wasm || Config.Flag.safe_string () -> ( 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 ])), _ - -> ( + | 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 ])) From 9f8c4aaf51fdd08cc026f880e10d2f35a355968b Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 13:16:04 +0200 Subject: [PATCH 12/32] Fix --- compiler/bin-js_of_ocaml/check_runtime.ml | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/bin-js_of_ocaml/check_runtime.ml b/compiler/bin-js_of_ocaml/check_runtime.ml index 56c2c0a3f1..29b541914a 100644 --- a/compiler/bin-js_of_ocaml/check_runtime.ml +++ b/compiler/bin-js_of_ocaml/check_runtime.ml @@ -43,6 +43,7 @@ let print_groups output l = output_string output (Printf.sprintf "%s\n" name))) let f (runtime_files, bytecode, target_env) = + Config.set_target `JavaScript; Linker.reset (); let runtime_files, builtin = List.partition_map runtime_files ~f:(fun name -> From a3f1ce89043d59e3a712c3c62001f866f88b5d53 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 14:53:21 +0200 Subject: [PATCH 13/32] CR: Add comment --- compiler/lib/specialize_js.ml | 3 +++ 1 file changed, 3 insertions(+) diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 143bf0a7e1..c76f44850b 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 From 04dff5efe4a173990e2ced14da77f165fa51c6a8 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 15:59:40 +0200 Subject: [PATCH 14/32] CR --- compiler/lib/eval.ml | 5 +++-- 1 file changed, 3 insertions(+), 2 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 1ee05f3731..56aca99c9c 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -130,7 +130,7 @@ let float_binop_bool l f = | Some b -> bool b | None -> None -let eval_prim x = +let eval_prim ~target x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) | Lt, [ Int i; Int j ] -> bool Int32.(i < j) @@ -140,7 +140,7 @@ let eval_prim x = | Ult, [ Int i; Int j ] -> bool (Int32.(j < 0l) || Int32.(i < j)) | Extern name, l -> ( let (module Int : Int) = - match Config.target () with + match target with | `JavaScript -> (module Int32) | `Wasm -> (module Int31) in @@ -417,6 +417,7 @@ let eval_instr ~target info ((x, loc) as i) = | _ -> false) then eval_prim + ~target ( prim , List.map prim_args' ~f:(function | Some c -> c From 74a23ef6ae84fc65586cb8ec294ddc181c774a80 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 16:19:04 +0200 Subject: [PATCH 15/32] CR: Drop code for non-existent primitives --- compiler/lib/eval.ml | 2 -- 1 file changed, 2 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 56aca99c9c..86f068e4cd 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -175,8 +175,6 @@ let eval_prim ~target x = | "caml_int_of_float", [ Float f ] -> Some (Int (Int32.of_float f |> Int.of_int32_warning_on_overflow |> Int.to_int32)) - | "to_int", [ Float f ] -> Some (Int (Int32.of_float f)) - | "to_int", [ Int i ] -> Some (Int i) (* Math *) | "caml_neg_float", _ -> float_unop l ( ~-. ) | "caml_abs_float", _ -> float_unop l abs_float From cd24eef54816e5228c28bd89f54c6c4a7526ec64 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Mon, 23 Sep 2024 17:06:20 +0200 Subject: [PATCH 16/32] CR --- compiler/lib/specialize_js.ml | 3 +-- 1 file changed, 1 insertion(+), 2 deletions(-) diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index c76f44850b..106a86ce06 100644 --- a/compiler/lib/specialize_js.ml +++ b/compiler/lib/specialize_js.ml @@ -44,8 +44,7 @@ let specialize_instr ~target info i = , Prim ( Extern (("caml_js_var" | "caml_js_expr" | "caml_pure_js_expr") as prim) , [ (Pv _ as y) ] ) ) - , target ) - when Poly.equal target `Wasm || Config.Flag.safe_string () -> ( + , target ) -> ( match the_string_of ~target info y with | Some s -> Let (x, Prim (Extern prim, [ Pc (String s) ])) | _ -> i) From 4b5c126c88d6e74a2ab29069354e84820ef6a879 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 23 Sep 2024 17:27:17 +0200 Subject: [PATCH 17/32] Parse_bytecode: add comments --- compiler/lib/parse_bytecode.ml | 18 ++++++++++++++++++ 1 file changed, 18 insertions(+) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index d73323dedd..5b9ae08140 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -773,6 +773,8 @@ let register_global ?(force = false) g i loc rem = | `Wasm -> true | `JavaScript -> false then ( + (* Register a compilation unit (Wasm) *) + assert (not force); let name = match g.named_value.(i) with | None -> assert false @@ -786,6 +788,8 @@ let register_global ?(force = false) g i loc rem = :: rem) else if force || g.is_exported.(i) then + (* Register an exception (if force = true), or a compilation unit + (Javascript) *) let args = match g.named_value.(i) with | None -> [] @@ -807,11 +811,13 @@ let get_global state instrs i loc = 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 @@ -821,12 +827,22 @@ let get_global state instrs i loc = | `Wasm -> false | `JavaScript -> true then ( + (* 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 = CONST(%d)@." Var.print x i; g.vars.(i) <- Some x; x, state, instrs) else + (* 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 -> @@ -3135,6 +3151,7 @@ let from_channel ic = | _ -> raise Magic_number.(Bad_magic_number (to_string magic))) 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) -> @@ -3177,6 +3194,7 @@ let predefined_exceptions () = match Config.target () with | `JavaScript -> [] | `Wasm -> + (* Also make the exception available to the generated code *) [ ( Let ( Var.fresh () , Prim (Extern "caml_set_global", [ Pc (String name); Pv exn ]) ) From 8543d08ed75853f362401dfc20cc04d30139ab90 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Mon, 23 Sep 2024 17:46:11 +0200 Subject: [PATCH 18/32] Wasm: do not generate JavaScript strings for predefined exceptions --- compiler/lib/parse_bytecode.ml | 6 +++++- 1 file changed, 5 insertions(+), 1 deletion(-) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 5b9ae08140..ecffba808a 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -795,7 +795,11 @@ let register_global ?(force = false) g i loc rem = | None -> [] | Some name -> Code.Var.name (access_global g i) name; - [ Pc (NativeString (Native_string.of_string name)) ] + [ Pc + (match Config.target () with + | `JavaScript -> NativeString (Native_string.of_string name) + | `Wasm -> String name) + ] in ( Let ( Var.fresh () From b19481f6d826844e72ecad7228f622fb572c58c2 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 24 Sep 2024 17:50:34 +0200 Subject: [PATCH 19/32] CR --- .../js_of_ocaml_compiler_dynlink.ml | 4 +- compiler/lib/code.ml | 18 ++++----- compiler/lib/driver.ml | 37 +++++++------------ compiler/lib/eval.ml | 5 ++- compiler/lib/flow.ml | 12 ++++++ 5 files changed, 42 insertions(+), 34 deletions(-) diff --git a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml index 583323ab62..d98e70651e 100644 --- a/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml +++ b/compiler/lib-dynlink/js_of_ocaml_compiler_dynlink.ml @@ -26,7 +26,9 @@ let normalize_bytecode code = Bytes.to_string b let () = - Config.set_target `JavaScript; + (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/code.ml b/compiler/lib/code.ml index f67b2615ce..3835f2e5fd 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -870,13 +870,18 @@ let invariant { blocks; start; _ } = assert (not (Var.ISet.mem defs x)); Var.ISet.add defs x) in - let check_prim_arg = function - | Pc (NativeInt _ | Int32 _) -> + let check_constant = function + | NativeInt _ | Int32 _ -> assert ( match Config.target () with | `Wasm -> true | _ -> false) - | Pc _ | Pv _ -> () + | 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 _ -> () @@ -885,12 +890,7 @@ let invariant { blocks; start; _ } = | Closure (l, cont) -> List.iter l ~f:define; check_cont cont - | Constant (NativeInt _ | Int32 _) -> - assert ( - match Config.target () with - | `Wasm -> true - | _ -> false) - | Constant _ -> () + | Constant c -> check_constant c | Prim (_, args) -> List.iter ~f:check_prim_arg args | Special _ -> () in diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 64dfbb75ac..c6e550f7ee 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 @@ -194,14 +202,13 @@ let generate ~exported_runtime ~wrap_with_fun ~warn_on_unhandled_effect - ~deadcode_sentinal - ((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 @@ -670,14 +677,6 @@ let link_and_pack ?(standalone = true) ?(wrap_with_fun = `Iife) ?(link = `No) p |> coloring |> check_js -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 - } - let optimize ~profile p = let deadcode_sentinal = (* If deadcode is disabled, this field is just fresh variable *) @@ -704,22 +703,14 @@ let optimize ~profile p = { program; variable_uses; trampolined_calls; in_cps; deadcode_sentinal } let full ~standalone ~wrap_with_fun ~profile ~link ~source_map ~formatter d p = - let { program; variable_uses; trampolined_calls; in_cps; deadcode_sentinal } = - optimize ~profile p - in + 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 - ~deadcode_sentinal + 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 ((program, variable_uses), trampolined_calls, in_cps) in - source_map + emit formatter optimized_code let full_no_source_map ~formatter ~standalone ~wrap_with_fun ~profile ~link d p = let (_ : Source_map.t option) = diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 86f068e4cd..634496137c 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -435,7 +435,10 @@ let eval_instr ~target info ((x, loc) as i) = , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> match c, target with | Some ((Int _ | NativeString _) as c), _ -> Pc c - | Some ((Int32 _ | NativeInt _) as c), `Wasm -> Pc c + | Some (Int32 _ | NativeInt _), `Wasm -> + (* Avoid duplicating the constant here as it would cause an + allocation *) + arg | Some (Int32 _ | NativeInt _), `JavaScript -> invalid_arg "Constant of type Int32 or NativeInt unexpected in the \ diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 9943166836..1859210c30 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -349,8 +349,20 @@ 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 + | String _, String _, `Wasm -> + false (* Strings are boxed in Wasm and are possibly different objects *) | Int _, Float _, _ | Float _, Int _, _ -> false + | 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 _, _ From a236900371762202bcaf6fdd9350a142cdf56424 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 21:37:40 +0200 Subject: [PATCH 20/32] small refactor --- compiler/lib/flow.ml | 23 +++++++---------------- 1 file changed, 7 insertions(+), 16 deletions(-) diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 1859210c30..bf7b079c0c 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -352,11 +352,10 @@ let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = | NativeString _, NativeString _, `Wasm -> false (* Native strings are boxed (JavaScript objects) in Wasm and are - possibly different objects *) + possibly different objects *) | String a, String b, `JavaScript -> Config.Flag.use_js_string () && String.equal a b | String _, String _, `Wasm -> false (* Strings are boxed in Wasm and are possibly different objects *) - | Int _, Float _, _ | Float _, Int _, _ -> false | Int32 _, Int32 _, `Wasm -> false (* [Int32]s are boxed in Wasm and are possibly different objects *) | Int32 _, Int32 _, `JavaScript -> assert false @@ -364,20 +363,12 @@ let constant_identical ~(target : [ `JavaScript | `Wasm ]) a b = 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 From 7448ac933031e4f5c130505c3d45c44d7c9ec8b2 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 21:39:54 +0200 Subject: [PATCH 21/32] small refactor --- compiler/lib/code.ml | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 3835f2e5fd..e48b3f2712 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -856,6 +856,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); @@ -873,7 +874,7 @@ let invariant { blocks; start; _ } = let check_constant = function | NativeInt _ | Int32 _ -> assert ( - match Config.target () with + match target with | `Wasm -> true | _ -> false) | String _ | NativeString _ | Float _ | Float_array _ | Int _ | Int64 _ From 861f6f5ba7d37fdb984e3b93a2e496c9899a8880 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 21:46:34 +0200 Subject: [PATCH 22/32] small refactor --- compiler/lib/driver.ml | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index c6e550f7ee..4d2aa5ba90 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -691,9 +691,9 @@ let optimize ~profile p = +> exact_calls ~deadcode_sentinal profile +> effects ~deadcode_sentinal +> map_fst - (match Config.target () with - | `JavaScript -> if Config.Flag.effects () then Fun.id else Generate_closure.f - | `Wasm -> Fun.id) + (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...@."; From e3d197511716f97cee0172be46340a359f9aeb7e Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 21:52:12 +0200 Subject: [PATCH 23/32] small refactor --- compiler/lib/eval.ml | 5 +---- 1 file changed, 1 insertion(+), 4 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 634496137c..4745a05a5c 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -439,10 +439,7 @@ let eval_instr ~target info ((x, loc) as i) = (* Avoid duplicating the constant here as it would cause an allocation *) arg - | Some (Int32 _ | NativeInt _), `JavaScript -> - invalid_arg - "Constant of type Int32 or NativeInt unexpected in the \ - JavaScript backend" + | Some (Int32 _ | NativeInt _), `JavaScript -> assert false | Some (Float _ as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript when Config.Flag.use_js_string () -> Pc c From 41bf7455d0a93b720fac2be84f808d7e7e21c3c2 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 22:33:21 +0200 Subject: [PATCH 24/32] small refactoring of parse_bytecode --- compiler/lib/parse_bytecode.ml | 197 ++++++++++++++++----------------- 1 file changed, 93 insertions(+), 104 deletions(-) diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index ecffba808a..650ccf0200 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -767,48 +767,44 @@ let access_global g i = x let register_global ?(force = false) g i loc rem = - if g.is_exported.(i) - && - match Config.target () with - | `Wasm -> true - | `JavaScript -> false - then ( - (* 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) - else if force || g.is_exported.(i) - then - (* 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 Config.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 - else 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 state instrs i loc = State.size_globals state (i + 1); @@ -825,37 +821,33 @@ let get_global state instrs i loc = 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 Config.target () with - | `Wasm -> false - | `JavaScript -> true - then ( - (* 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 = CONST(%d)@." Var.print x i; - g.vars.(i) <- Some x; - x, state, instrs) else - (* 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 -> + 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.Map.empty @@ -3162,44 +3154,41 @@ let predefined_exceptions () = 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 Config.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 Config.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 Config.target () with - | `JavaScript -> [] + | `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 -> - (* Also make the exception available to the generated code *) [ ( 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 ) From 9f66948ad78cb491d279b91431420d9dcd398942 Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 22:48:27 +0200 Subject: [PATCH 25/32] small refactor --- compiler/lib/stdlib.ml | 19 ++++++++----------- 1 file changed, 8 insertions(+), 11 deletions(-) diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index d2186c7a92..5fef39c9c2 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -378,11 +378,10 @@ module Int31 : sig val of_nativeint_warning_on_overflow : nativeint -> t - val to_int32 : t -> int32 - val of_int32_warning_on_overflow : int32 -> t - val to_int : t -> int + val to_int32 : t -> int32 + end = struct type t = int32 @@ -441,20 +440,18 @@ end = struct let logxor = int_binop Int32.logxor - let shift_op wrap truncate f x y = + let shift_op f x y = (* Limit the shift offset to [0, 31] *) - wrap (f (truncate x) (y land 0x1f)) + wrap (f x (y land 0x1f)) - let shift_left = shift_op wrap Fun.id Int32.shift_left + let shift_left = shift_op Int32.shift_left - let shift_right = shift_op wrap Fun.id Int32.shift_right + let shift_right = shift_op Int32.shift_right - let shift_right_logical = - shift_op wrap (fun i -> Int32.logand i 0x7fffffffl) Int32.shift_right_logical + let shift_right_logical a b = + shift_op Int32.shift_right_logical (Int32.logand a 0x7fffffffl) b let to_int32 (x : t) : int32 = x - - let to_int (x : t) = Int32.to_int x end module Option = struct From aa0ae8be1c701dff7e9974d84227e2fa38c2e31d Mon Sep 17 00:00:00 2001 From: Hugo Heuzard Date: Tue, 24 Sep 2024 23:18:08 +0200 Subject: [PATCH 26/32] small refactor --- compiler/lib/stdlib.ml | 1 - 1 file changed, 1 deletion(-) diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 5fef39c9c2..bb01e08dab 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -381,7 +381,6 @@ module Int31 : sig val of_int32_warning_on_overflow : int32 -> t val to_int32 : t -> int32 - end = struct type t = int32 From 191b917c51766c7830b9412ec3c7570ce5d88026 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Wed, 25 Sep 2024 10:54:24 +0200 Subject: [PATCH 27/32] CR --- compiler/lib/eval.ml | 6 +++--- compiler/lib/ocaml_compiler.ml | 10 ++++++++-- compiler/lib/parse_bytecode.ml | 12 +++++++++--- 3 files changed, 20 insertions(+), 8 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 4745a05a5c..433d4d656b 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -434,13 +434,13 @@ let eval_instr ~target info ((x, loc) as i) = ( prim , List.map2 prim_args prim_args' ~f:(fun arg (c : constant option) -> match c, target with - | Some ((Int _ | NativeString _) as c), _ -> Pc c - | Some (Int32 _ | NativeInt _), `Wasm -> + | 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 _ as c), `JavaScript -> Pc c + | Some ((Float _ | NativeString _) as c), `JavaScript -> Pc c | Some (String _ as c), `JavaScript when Config.Flag.use_js_string () -> Pc c | Some _, _ diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 21a524c774..12a9f859dc 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -31,9 +31,15 @@ let rec constant_of_const c : Code.constant = | ((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) -> Int i + | Const_base (Const_int32 i) -> ( + match Config.target () with + | `JavaScript -> Int i + | `Wasm -> Int32 i) | Const_base (Const_int64 i) -> Int64 i - | Const_base (Const_nativeint i) -> Int (Int32.of_nativeint_warning_on_overflow i) + | Const_base (Const_nativeint i) -> ( + match Config.target () with + | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `Wasm -> NativeInt i) | Const_immstring s -> String s | Const_float_array sl -> let l = List.map ~f:(fun f -> float_of_string f) sl in diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index 650ccf0200..c9a9f07b46 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -490,10 +490,16 @@ end = struct else if tag = Obj.custom_tag then match ident_of_custom x with - | Some name when same_ident name ident_32 -> Int (Obj.magic x : int32) - | Some name when same_ident name ident_native -> + | Some name when same_ident name ident_32 -> ( + let i : int32 = Obj.magic x in + 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 - Int (Int32.of_nativeint_warning_on_overflow i) + match Config.target () with + | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `Wasm -> NativeInt i) | Some name when same_ident name ident_64 -> Int64 (Obj.magic x : int64) | Some name -> failwith From abb8540198977bce9ca95ebf980ff214d268b441 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 14:15:26 +0200 Subject: [PATCH 28/32] Add Int31 tests --- compiler/tests-num/dune | 9 ++ compiler/tests-num/test_int31.ml | 194 +++++++++++++++++++++++++++++++ dune-project | 1 + js_of_ocaml-compiler.opam | 1 + 4 files changed, 205 insertions(+) create mode 100644 compiler/tests-num/test_int31.ml diff --git a/compiler/tests-num/dune b/compiler/tests-num/dune index 6cb923a8d5..5d63162e7b 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,14 @@ (flags (:standard -linkall -w -3-7-33-35-37 -safe-string -no-strict-sequence))) +(library + (name test_int31) + (modules test_int31) + (inline_tests) + (preprocess + (pps ppx_expect)) + (libraries js_of_ocaml-compiler qcheck)) + (rule (target main.referencejs) (deps main.bc.js) diff --git a/compiler/tests-num/test_int31.ml b/compiler/tests-num/test_int31.ml new file mode 100644 index 0000000000..42f8db81b9 --- /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 = r_int32))); + [%expect ""] diff --git a/dune-project b/dune-project index 39d190fe65..92fc0c470b 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/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index 6c9ba412f2..7cea43512c 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 d2e8bd6d85edf3bd982807fff096e9a177e27944 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 16:04:20 +0200 Subject: [PATCH 29/32] CR: Update compiler/tests-num/dune Co-authored-by: hhugo --- compiler/tests-num/dune | 1 + 1 file changed, 1 insertion(+) diff --git a/compiler/tests-num/dune b/compiler/tests-num/dune index 5d63162e7b..9322dbda78 100644 --- a/compiler/tests-num/dune +++ b/compiler/tests-num/dune @@ -12,6 +12,7 @@ (name test_int31) (modules test_int31) (inline_tests) + (enabled_if %{lib-available:qcheck}) (preprocess (pps ppx_expect)) (libraries js_of_ocaml-compiler qcheck)) From ece9f794ba88d0c26e14c417151c31f924cfe0b3 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 16:07:29 +0200 Subject: [PATCH 30/32] Fix tested property --- compiler/tests-num/test_int31.ml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/compiler/tests-num/test_int31.ml b/compiler/tests-num/test_int31.ml index 42f8db81b9..2b4743dd0d 100644 --- a/compiler/tests-num/test_int31.ml +++ b/compiler/tests-num/test_int31.ml @@ -190,5 +190,5 @@ let%expect_test _ = (* 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 = r_int32))); + && (Int.equal i 0 --> Int32.(r_int31 = x_int32))); [%expect ""] From 92108c7a7bc8d25edf2b4e5799e311a3828d46d7 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 16:21:26 +0200 Subject: [PATCH 31/32] Upgrade Dune lang to 3.15 --- dune-project | 2 +- dune-workspace.dev | 2 +- js_of_ocaml-compiler.opam | 2 +- js_of_ocaml-lwt.opam | 2 +- js_of_ocaml-ppx.opam | 2 +- js_of_ocaml-ppx_deriving_json.opam | 2 +- js_of_ocaml-toplevel.opam | 2 +- js_of_ocaml-tyxml.opam | 2 +- js_of_ocaml.opam | 2 +- 9 files changed, 9 insertions(+), 9 deletions(-) diff --git a/dune-project b/dune-project index 92fc0c470b..e7880e1cd8 100644 --- a/dune-project +++ b/dune-project @@ -1,4 +1,4 @@ -(lang dune 3.7) +(lang dune 3.15) (using menhir 2.0) (name js_of_ocaml) diff --git a/dune-workspace.dev b/dune-workspace.dev index a21211017e..0f4dc203a3 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: diff --git a/js_of_ocaml-compiler.opam b/js_of_ocaml-compiler.opam index 7cea43512c..d8fee92ae9 100644 --- a/js_of_ocaml-compiler.opam +++ b/js_of_ocaml-compiler.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08" & < "5.4"} "num" {with-test} "ppx_expect" {>= "v0.14.2" & with-test} diff --git a/js_of_ocaml-lwt.opam b/js_of_ocaml-lwt.opam index b0cc7c1784..040e9c1009 100644 --- a/js_of_ocaml-lwt.opam +++ b/js_of_ocaml-lwt.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} diff --git a/js_of_ocaml-ppx.opam b/js_of_ocaml-ppx.opam index 72e581304d..7e65f4f2db 100644 --- a/js_of_ocaml-ppx.opam +++ b/js_of_ocaml-ppx.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "ppxlib" {>= "0.15.0"} diff --git a/js_of_ocaml-ppx_deriving_json.opam b/js_of_ocaml-ppx_deriving_json.opam index 90cdfe507d..23afe4fa25 100644 --- a/js_of_ocaml-ppx_deriving_json.opam +++ b/js_of_ocaml-ppx_deriving_json.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "ppxlib" {>= "0.15"} diff --git a/js_of_ocaml-toplevel.opam b/js_of_ocaml-toplevel.opam index 7b2a882fcf..6e0e3d675c 100644 --- a/js_of_ocaml-toplevel.opam +++ b/js_of_ocaml-toplevel.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml-compiler" {= version} "ocamlfind" {>= "1.5.1"} diff --git a/js_of_ocaml-tyxml.opam b/js_of_ocaml-tyxml.opam index 737f3d26d4..0feed79e0e 100644 --- a/js_of_ocaml-tyxml.opam +++ b/js_of_ocaml-tyxml.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml" {= version} "js_of_ocaml-ppx" {= version} diff --git a/js_of_ocaml.opam b/js_of_ocaml.opam index 284b04bc3e..b3300ecde4 100644 --- a/js_of_ocaml.opam +++ b/js_of_ocaml.opam @@ -12,7 +12,7 @@ homepage: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" doc: "https://ocsigen.org/js_of_ocaml/latest/manual/overview" bug-reports: "https://github.com/ocsigen/js_of_ocaml/issues" depends: [ - "dune" {>= "3.7"} + "dune" {>= "3.15"} "ocaml" {>= "4.08"} "js_of_ocaml-compiler" {= version} "ppxlib" {>= "0.15"} From 226d865689a7e9239aa781794cdef8f8aebdf0e2 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Thu, 26 Sep 2024 22:27:05 +0200 Subject: [PATCH 32/32] Fix after #1692 --- compiler/lib/ocaml_compiler.ml | 3 ++- compiler/lib/parse_bytecode.ml | 3 ++- 2 files changed, 4 insertions(+), 2 deletions(-) diff --git a/compiler/lib/ocaml_compiler.ml b/compiler/lib/ocaml_compiler.ml index 12a9f859dc..ba16dae2a4 100644 --- a/compiler/lib/ocaml_compiler.ml +++ b/compiler/lib/ocaml_compiler.ml @@ -37,8 +37,9 @@ let rec constant_of_const c : Code.constant = | `Wasm -> Int32 i) | Const_base (Const_int64 i) -> Int64 i | Const_base (Const_nativeint i) -> ( + let i = Int32.of_nativeint_warning_on_overflow i in match Config.target () with - | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `JavaScript -> Int i | `Wasm -> NativeInt i) | Const_immstring s -> String s | Const_float_array sl -> diff --git a/compiler/lib/parse_bytecode.ml b/compiler/lib/parse_bytecode.ml index c9a9f07b46..c8e7cfc5d3 100644 --- a/compiler/lib/parse_bytecode.ml +++ b/compiler/lib/parse_bytecode.ml @@ -497,8 +497,9 @@ end = struct | `Wasm -> Int32 i) | Some name when same_ident name ident_native -> ( let i : nativeint = Obj.magic x in + let i = Int32.of_nativeint_warning_on_overflow i in match Config.target () with - | `JavaScript -> Int (Int32.of_nativeint_warning_on_overflow i) + | `JavaScript -> Int i | `Wasm -> NativeInt i) | Some name when same_ident name ident_64 -> Int64 (Obj.magic x : int64) | Some name ->