From a40f9a01520a06e0475924d863a1a1ecd5803c78 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 27 Aug 2024 11:09:11 +0200 Subject: [PATCH 1/4] Compiler: Document non-trivial function Code.constant_equal, and fix related bugs (#1659) MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit * Document non-trivial function Code.constant_equal Co-authored-by: Jérome Vouillon * Fix bugs related to constant equality See #1659. * More static evaluation of equalities in eval * Statically evaluate caml_js_strict_equals too * Compiler: small refactoring in eval --------- Co-authored-by: Jérome Vouillon Co-authored-by: Hugo Heuzard --- compiler/lib/code.ml | 142 +++++++++--------- compiler/lib/code.mli | 10 +- compiler/lib/driver.ml | 30 ++-- compiler/lib/eval.ml | 55 +++++-- compiler/lib/flow.ml | 24 ++- compiler/lib/generate.ml | 4 +- .../lib/{constant.ml => global_constant.ml} | 0 compiler/lib/javascript.ml | 4 +- compiler/lib/linker.ml | 6 +- compiler/lib/stdlib.ml | 6 +- compiler/tests-compiler/dune.inc | 15 ++ compiler/tests-compiler/gh1659.ml | 62 ++++++++ 12 files changed, 256 insertions(+), 102 deletions(-) rename compiler/lib/{constant.ml => global_constant.ml} (100%) create mode 100644 compiler/tests-compiler/gh1659.ml diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index 591cac4c1..d9fffb4ee 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -290,75 +290,79 @@ type constant = | NativeInt of nativeint | Tuple of int * constant array * array_or_not -let rec constant_equal a b = - match a, b with - | String a, String b -> Some (String.equal a b) - | NativeString a, NativeString b -> Some (Native_string.equal a b) - | Tuple (ta, a, _), Tuple (tb, b, _) -> - if ta <> tb || Array.length a <> Array.length b - then Some false - else - let same = ref (Some true) in - for i = 0 to Array.length a - 1 do - match !same, constant_equal a.(i) b.(i) with - | None, _ -> () - | _, None -> same := None - | Some s, Some c -> same := Some (s && c) - done; - !same - | Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b) - | Int64 a, Int64 b -> Some (Int64.equal a b) - | NativeInt a, NativeInt b -> Some (Nativeint.equal a b) - | Float_array a, Float_array b -> Some (Array.equal Float.equal a b) - | Float a, Float b -> Some (Float.equal a b) - | String _, NativeString _ | NativeString _, String _ -> None - | Int _, Float _ | Float _, Int _ -> None - | Tuple ((0 | 254), _, _), Float_array _ -> None - | Float_array _, Tuple ((0 | 254), _, _) -> None - | ( Tuple _ - , ( String _ - | NativeString _ - | Int64 _ - | Int _ - | Int32 _ - | NativeInt _ - | Float _ - | Float_array _ ) ) -> Some false - | ( Float_array _ - , ( String _ - | NativeString _ - | Int64 _ - | Int _ - | Int32 _ - | NativeInt _ - | Float _ - | Tuple _ ) ) -> Some false - | ( String _ - , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> - Some false - | ( NativeString _ - , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> - Some false - | ( Int64 _ - , ( String _ - | NativeString _ - | Int _ - | Int32 _ - | NativeInt _ - | Float _ - | Tuple _ - | Float_array _ ) ) -> Some false - | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> - Some false - | ( (Int _ | Int32 _ | NativeInt _) - , (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) -> - Some false - (* Note: the following cases should not occur when compiling to Javascript *) - | Int _, (Int32 _ | NativeInt _) - | Int32 _, (Int _ | NativeInt _) - | NativeInt _, (Int _ | Int32 _) - | (Int32 _ | NativeInt _), Float _ - | Float _, (Int32 _ | NativeInt _) -> None +module Constant = struct + type t = constant + + let rec ocaml_equal a b = + match a, b with + | String a, String b -> Some (String.equal a b) + | NativeString a, NativeString b -> Some (Native_string.equal a b) + | Tuple (ta, a, _), Tuple (tb, b, _) -> + if ta <> tb || Array.length a <> Array.length b + then Some false + else + let same = ref (Some true) in + for i = 0 to Array.length a - 1 do + match !same, ocaml_equal a.(i) b.(i) with + | None, _ -> () + | _, None -> same := None + | Some s, Some c -> same := Some (s && c) + done; + !same + | Int a, Int b | Int32 a, Int32 b -> Some (Int32.equal a b) + | Int64 a, Int64 b -> Some (Int64.equal a b) + | NativeInt a, NativeInt b -> Some (Nativeint.equal a b) + | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b) + | Float a, Float b -> Some (Float.ieee_equal a b) + | String _, NativeString _ | NativeString _, String _ -> None + | Int _, Float _ | Float _, Int _ -> None + | Tuple ((0 | 254), _, _), Float_array _ -> None + | Float_array _, Tuple ((0 | 254), _, _) -> None + | ( Tuple _ + , ( String _ + | NativeString _ + | Int64 _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Float_array _ ) ) -> Some false + | ( Float_array _ + , ( String _ + | NativeString _ + | Int64 _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Tuple _ ) ) -> Some false + | ( String _ + , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> + Some false + | ( NativeString _ + , (Int64 _ | Int _ | Int32 _ | NativeInt _ | Float _ | Tuple _ | Float_array _) ) -> + Some false + | ( Int64 _ + , ( String _ + | NativeString _ + | Int _ + | Int32 _ + | NativeInt _ + | Float _ + | Tuple _ + | Float_array _ ) ) -> Some false + | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> + Some false + | ( (Int _ | Int32 _ | NativeInt _) + , (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ) -> + Some false + (* Note: the following cases should not occur when compiling to Javascript *) + | Int _, (Int32 _ | NativeInt _) + | Int32 _, (Int _ | NativeInt _) + | NativeInt _, (Int _ | Int32 _) + | (Int32 _ | NativeInt _), Float _ + | Float _, (Int32 _ | NativeInt _) -> None +end type loc = | No diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 6e8f0d0bd..1c107d75e 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -150,6 +150,8 @@ module Native_string : sig val of_string : string -> t val of_bytestring : string -> t + + val equal : t -> t -> bool end type int_kind = @@ -168,7 +170,13 @@ type constant = | NativeInt of nativeint (** Only produced when compiling to WebAssembly. *) | Tuple of int * constant array * array_or_not -val constant_equal : constant -> constant -> bool option +module Constant : sig + type t = constant + + val ocaml_equal : t -> t -> bool option + (** Guaranteed equality in terms of OCaml [(=)]: if [constant_equal a b = + Some v], then [Poly.(=) a b = v]. This is used for optimization purposes. *) +end type loc = | No diff --git a/compiler/lib/driver.ml b/compiler/lib/driver.ml index 8882829f1..bb4ce4aaf 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -241,9 +241,9 @@ let gen_missing js missing = , ( ECond ( EBin ( NotEqEq - , dot (EVar (ident Constant.global_object_)) prim + , dot (EVar (ident Global_constant.global_object_)) prim , EVar (ident_s "undefined") ) - , dot (EVar (ident Constant.global_object_)) prim + , dot (EVar (ident Global_constant.global_object_)) prim , EFun ( None , fun_ @@ -364,7 +364,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) : (EBin ( Eq , dot - (EVar (ident Constant.global_object_)) + (EVar (ident Global_constant.global_object_)) (Utf8_string.of_string_exn "jsoo_runtime") , EObj all )) , N ) @@ -375,7 +375,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) : (EVar (ident (Utf8_string.of_string_exn "Object"))) (Utf8_string.of_string_exn "assign")) [ dot - (EVar (ident Constant.global_object_)) + (EVar (ident Global_constant.global_object_)) (Utf8_string.of_string_exn "jsoo_runtime") ; EObj all ] @@ -404,7 +404,7 @@ let link' ~export_runtime ~standalone ~link (js : Javascript.statement_list) : ; rest = None } , ( dot - (EVar (ident Constant.global_object_)) + (EVar (ident Global_constant.global_object_)) (Utf8_string.of_string_exn "jsoo_runtime") , N ) ) ] ) @@ -510,27 +510,30 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_ o#get_free in let export_shim js = - if J.IdentSet.mem (J.ident Constant.exports_) freenames + if J.IdentSet.mem (J.ident Global_constant.exports_) freenames then if should_export wrap_with_fun - then var Constant.exports_ (J.EObj []) :: js + then var Global_constant.exports_ (J.EObj []) :: js else let export_node = let s = Printf.sprintf {|((typeof module === 'object' && module.exports) || %s)|} - Constant.global_object + Global_constant.global_object in let lex = Parse_js.Lexer.of_string s in Parse_js.parse_expr lex in - var Constant.exports_ export_node :: js + var Global_constant.exports_ export_node :: js else js in let old_global_object_shim js = - if J.IdentSet.mem (J.ident Constant.old_global_object_) freenames + if J.IdentSet.mem (J.ident Global_constant.old_global_object_) freenames then - var Constant.old_global_object_ (J.EVar (J.ident Constant.global_object_)) :: js + var + Global_constant.old_global_object_ + (J.EVar (J.ident Global_constant.global_object_)) + :: js else js in @@ -544,14 +547,15 @@ let pack ~wrap_with_fun ~standalone { Linker.runtime_code = js; always_required_ then expr (J.EStr (Utf8_string.of_string_exn "use strict")) :: js else js in - f [ J.ident Constant.global_object_ ] js + f [ J.ident Global_constant.global_object_ ] js in match wrap_with_fun with | `Anonymous -> expr (mk efun) | `Named name -> let name = Utf8_string.of_string_exn name in mk (sfun (J.ident name)) - | `Iife -> expr (J.call (mk efun) [ J.EVar (J.ident Constant.global_object_) ] J.N) + | `Iife -> + expr (J.call (mk efun) [ J.EVar (J.ident Global_constant.global_object_) ] J.N) in let always_required_js = (* consider adding a comments in the generated file with original diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 77eb5e332..75d655bbb 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -65,14 +65,15 @@ let float_unop (l : constant list) (f : float -> float) : constant option = | [ Int i ] -> Some (Float (f (Int32.to_float i))) | _ -> None +let bool' b = Int (if b then 1l else 0l) + +let bool b = Some (bool' b) + let float_binop_bool l f = match float_binop_aux l f with - | Some true -> Some (Int 1l) - | Some false -> Some (Int 0l) + | Some b -> bool b | None -> None -let bool b = Some (Int (if b then 1l else 0l)) - let eval_prim ~target x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) @@ -254,16 +255,51 @@ let the_cont_of info x (a : cont array) = | _ -> None) x +(* If [constant_js_equal a b = Some v], then [caml_js_equals a b = v]). *) +let constant_js_equal a b = + match a, b with + | Int i, Int j -> Some (Int32.equal i j) + | Float a, Float b -> Some (Float.ieee_equal a b) + | NativeString a, NativeString b -> Some (Native_string.equal a b) + | String a, String b when Config.Flag.use_js_string () -> Some (String.equal a b) + | Int _, Float _ | Float _, Int _ -> None + (* All other values may be distinct objects and thus different by [caml_js_equals]. *) + | String _, _ + | _, String _ + | NativeString _, _ + | _, NativeString _ + | Float_array _, _ + | _, Float_array _ + | Int64 _, _ + | _, Int64 _ + | Tuple _, _ + | _, Tuple _ -> None + let eval_instr ~target info ((x, loc) as i) = match x with - | Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> ( + | Let (x, Prim (Extern (("caml_equal" | "caml_notequal") as prim), [ y; z ])) -> ( + match the_const_of info y, the_const_of info z with + | Some e1, Some e2 -> ( + match Code.Constant.ocaml_equal e1 e2 with + | None -> [ i ] + | Some c -> + let c = + match prim with + | "caml_equal" -> c + | "caml_notequal" -> not c + | _ -> assert false + in + let c = Constant (bool' c) in + Flow.update_def info x c; + [ 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 | Some e1, Some e2 -> ( - match constant_equal e1 e2 with + match constant_js_equal e1 e2 with | None -> [ i ] | Some c -> - let c = if c then 1l else 0l in - let c = Constant (Int c) in + let c = Constant (bool' c) in Flow.update_def info x c; [ Let (x, c), loc ]) | _ -> [ i ]) @@ -299,8 +335,7 @@ let eval_instr ~target info ((x, loc) as i) = match is_int ~target info y with | Unknown -> [ i ] | (Y | N) as b -> - let b = if Poly.(b = N) then 0l else 1l in - let c = Constant (Int b) in + let c = Constant (bool' Poly.(b = Y)) in Flow.update_def info x c; [ Let (x, c), loc ]) | Let (x, Prim (Extern "%direct_obj_tag", [ y ])) -> ( diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index f5e8193ea..1212e56f0 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -322,6 +322,28 @@ let the_def_of info x = x | Pc c -> Some (Constant c) +(* 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 + (* All other values may be distinct objects and thus different by [caml_js_equals]. *) + | String _, _ + | _, String _ + | NativeString _, _ + | _, NativeString _ + | Float_array _, _ + | _, Float_array _ + | Int64 _, _ + | _, Int64 _ + | Tuple _, _ + | _, Tuple _ -> false + let the_const_of info x = match x with | Pv x -> @@ -337,7 +359,7 @@ let the_const_of info x = None (fun u v -> match u, v with - | Some i, Some j when Poly.(Code.constant_equal i j = Some true) -> u + | Some i, Some j when constant_identical i j -> u | _ -> None) x | Pc c -> Some c diff --git a/compiler/lib/generate.ml b/compiler/lib/generate.ml index 58893caae..16ff54a5e 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1861,7 +1861,7 @@ and compile_conditional st queue last loop_stack backs frontier interm = true, flush_all queue (throw_statement st.ctx cx k loc) | Stop -> let e_opt = - if st.ctx.Ctx.should_export then Some (s_var Constant.exports) else None + if st.ctx.Ctx.should_export then Some (s_var Global_constant.exports) else None in true, flush_all queue [ J.Return_statement e_opt, loc ] | Branch cont -> compile_branch st queue cont loop_stack backs frontier interm @@ -2006,7 +2006,7 @@ let generate_shared_value ctx = | Some (v, _) -> [ ( J.V v , ( J.dot - (s_var Constant.global_object) + (s_var Global_constant.global_object) (Utf8_string.of_string_exn "jsoo_runtime") , J.N ) ) ]) diff --git a/compiler/lib/constant.ml b/compiler/lib/global_constant.ml similarity index 100% rename from compiler/lib/constant.ml rename to compiler/lib/global_constant.ml diff --git a/compiler/lib/javascript.ml b/compiler/lib/javascript.ml index 633d96a86..acd03eee3 100644 --- a/compiler/lib/javascript.ml +++ b/compiler/lib/javascript.ml @@ -112,14 +112,14 @@ end = struct | FP_infinite -> if Float.(v < 0.) then "-Infinity" else "Infinity" | FP_normal | FP_subnormal -> ( let vint = int_of_float v in - if Float.equal (float_of_int vint) v + if Float.ieee_equal (float_of_int vint) v then Printf.sprintf "%d." vint else match find_smaller ~f:(fun prec -> let s = float_to_string prec v in - if Float.equal v (float_of_string s) then Some s else None) + if Float.ieee_equal v (float_of_string s) then Some s else None) ~bad:0 ~good:18 ~good_s:"max" diff --git a/compiler/lib/linker.ml b/compiler/lib/linker.ml index 5e72a0c6c..4e007ecf8 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -134,9 +134,9 @@ module Check = struct in let freename = StringSet.diff freename Reserved.keyword in let freename = StringSet.diff freename Reserved.provided in - let freename = StringSet.remove Constant.global_object freename in + let freename = StringSet.remove Global_constant.global_object freename in let freename = if has_flags then StringSet.remove "FLAG" freename else freename in - if StringSet.mem Constant.old_global_object freename && false + if StringSet.mem Global_constant.old_global_object freename && false (* Don't warn yet, we want to give a transition period where both "globalThis" and "joo_global_object" are allowed without extra noise *) @@ -145,7 +145,7 @@ module Check = struct "warning: %s: 'joo_global_object' is being deprecated, please use `globalThis` \ instead@." (loc pi); - let freename = StringSet.remove Constant.old_global_object freename in + let freename = StringSet.remove Global_constant.old_global_object freename in let defname = to_stringset free#get_def in if not (StringSet.mem name defname) then diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index f68e8cdb5..d5c7122c4 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -423,7 +423,11 @@ end module Float = struct type t = float - let equal (a : float) (b : float) = + let equal (_ : float) (_ : float) = `Use_ieee_equal_or_bitwise_equal + + let ieee_equal (a : float) (b : float) = Poly.equal a b + + let bitwise_equal (a : float) (b : float) = Int64.equal (Int64.bits_of_float a) (Int64.bits_of_float b) (* Re-defined here to stay compatible with OCaml 4.02 *) diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index 5ab5836bf..f541039ba 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -359,6 +359,21 @@ (preprocess (pps ppx_expect))) +(library + ;; compiler/tests-compiler/gh1659.ml + (name gh1659_15) + (enabled_if true) + (modules gh1659) + (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) + (inline_tests + (enabled_if true) + (deps + (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) + (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) + (flags (:standard -open Jsoo_compiler_expect_tests_helper)) + (preprocess + (pps ppx_expect))) + (library ;; compiler/tests-compiler/gh747.ml (name gh747_15) diff --git a/compiler/tests-compiler/gh1659.ml b/compiler/tests-compiler/gh1659.ml new file mode 100644 index 000000000..3607703f2 --- /dev/null +++ b/compiler/tests-compiler/gh1659.ml @@ -0,0 +1,62 @@ +let%expect_test _ = + let prog = + {| +let f a b = a = b +let () = Printf.printf "(0., 0.) = (-0., 0.) => %B\n" (f (0., 0.) (-0., 0.)) +let f a b = a = b +let () = Printf.printf "0. = -0. => %B\n" (f 0. (-0.));; +let f a b = a = b +let nan1 = 0. /. 0. +let nan2 = 0. /. 0. +let () = Printf.printf "nan = nan => %B\n" (f nan1 nan2);; + |} + in + Util.compile_and_run prog; + [%expect + {| + (0., 0.) = (-0., 0.) => true + 0. = -0. => true + nan = nan => false + |}] + +let%expect_test _ = + let prog = + {| +external equals : 'a -> 'a -> bool = "caml_js_equals";; +let () = Printf.printf "x = (0., 0.); x = x => %B\n" (let x = (0., 0.) in equals x x) +let () = Printf.printf "(0., 0.) = (0., 0.) => %B\n" (equals (0., 0.) (0., 0.)) +let () = Printf.printf "0. = -0. => %B\n" (equals 0. (-0.));; +let nan1 = 0. /. 0. +let nan2 = 0. /. 0. +let () = Printf.printf "nan = nan => %B\n" (equals nan1 nan2);; + |} + in + Util.compile_and_run prog; + [%expect + {| + x = (0., 0.); x = x => true + (0., 0.) = (0., 0.) => false + 0. = -0. => true + nan = nan => false + |}] + +let%expect_test _ = + let prog = + {| +external equals : 'a -> 'a -> bool = "caml_js_strict_equals";; +let () = Printf.printf "x = (0., 0.); x = x => %B\n" (let x = (0., 0.) in equals x x) +let () = Printf.printf "(0., 0.) = (0., 0.) => %B\n" (equals (0., 0.) (0., 0.)) +let () = Printf.printf "0. = -0. => %B\n" (equals 0. (-0.));; +let nan1 = 0. /. 0. +let nan2 = 0. /. 0. +let () = Printf.printf "nan = nan => %B\n" (equals nan1 nan2);; + |} + in + Util.compile_and_run prog; + [%expect + {| + x = (0., 0.); x = x => true + (0., 0.) = (0., 0.) => false + 0. = -0. => true + nan = nan => false + |}] From 48b465ffd94ead4ae415ec1033f1990749b4184e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 3 Sep 2024 15:36:06 +0200 Subject: [PATCH 2/4] WSOO side of ocsigen/js_of_ocaml#1659 --- compiler/lib/wasm/wa_link.ml | 14 +++++++------- 1 file changed, 7 insertions(+), 7 deletions(-) diff --git a/compiler/lib/wasm/wa_link.ml b/compiler/lib/wasm/wa_link.ml index ffb185ca8..37eed7daf 100644 --- a/compiler/lib/wasm/wa_link.ml +++ b/compiler/lib/wasm/wa_link.ml @@ -510,28 +510,28 @@ let build_runtime_arguments Javascript.call (EArrow ( Javascript.fun_ - [ Javascript.ident Constant.global_object_ ] + [ Javascript.ident Global_constant.global_object_ ] [ var - Constant.old_global_object_ - (EVar (Javascript.ident Constant.global_object_)) + Global_constant.old_global_object_ + (EVar (Javascript.ident Global_constant.global_object_)) ; var - Constant.exports_ + Global_constant.exports_ (EBin ( Or , EDot ( EDot - ( EVar (Javascript.ident Constant.global_object_) + ( EVar (Javascript.ident Global_constant.global_object_) , ANullish , Utf8_string.of_string_exn "module" ) , ANullish , Utf8_string.of_string_exn "export" ) - , EVar (Javascript.ident Constant.global_object_) )) + , EVar (Javascript.ident Global_constant.global_object_) )) ; Return_statement (Some (obj generated_js)), N ] N , true , AUnknown )) - [ EVar (Javascript.ident Constant.global_object_) ] + [ EVar (Javascript.ident Global_constant.global_object_) ] N in obj From 68bf91e36905f68283660055e87b0eff15b8814f Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=A9r=C3=B4me=20Vouillon?= Date: Fri, 20 Sep 2024 10:49:48 +0200 Subject: [PATCH 3/4] Fixes --- compiler/lib/eval.ml | 4 ++++ compiler/lib/flow.ml | 4 ++++ compiler/tests-compiler/dune.inc | 4 ++-- 3 files changed, 10 insertions(+), 2 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 75d655bbb..6ecb48fae 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -272,6 +272,10 @@ let constant_js_equal a b = | _, Float_array _ | Int64 _, _ | _, Int64 _ + | Int32 _, _ + | _, Int32 _ + | NativeInt _, _ + | _, NativeInt _ | Tuple _, _ | _, Tuple _ -> None diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 1212e56f0..95aa383a2 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -341,6 +341,10 @@ let constant_identical a b = | _, Float_array _ | Int64 _, _ | _, Int64 _ + | Int32 _, _ + | _, Int32 _ + | NativeInt _, _ + | _, NativeInt _ | Tuple _, _ | _, Tuple _ -> false diff --git a/compiler/tests-compiler/dune.inc b/compiler/tests-compiler/dune.inc index f541039ba..f1af6980a 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -362,11 +362,11 @@ (library ;; compiler/tests-compiler/gh1659.ml (name gh1659_15) - (enabled_if true) + (enabled_if (and (<> %{profile} wasm) (<> %{profile} wasm-effects))) (modules gh1659) (libraries js_of_ocaml_compiler unix str jsoo_compiler_expect_tests_helper) (inline_tests - (enabled_if true) + (enabled_if (and (<> %{profile} wasm) (<> %{profile} wasm-effects))) (deps (file %{project_root}/compiler/bin-js_of_ocaml/js_of_ocaml.exe) (file %{project_root}/compiler/bin-jsoo_minify/jsoo_minify.exe))) From 26864d1af6aae7d80ac44eab58c7c34e43a4b870 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 20 Sep 2024 15:36:17 +0200 Subject: [PATCH 4/4] Fix constant_identical for Wasm target --- compiler/lib/eval.ml | 12 +++---- compiler/lib/flow.ml | 61 ++++++++++++++++++----------------- compiler/lib/flow.mli | 8 ++--- compiler/lib/specialize_js.ml | 34 +++++++++---------- 4 files changed, 58 insertions(+), 57 deletions(-) diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 6ecb48fae..5faec48bf 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -166,14 +166,14 @@ let eval_prim ~target x = | _ -> None) | _ -> None -let the_length_of info x = +let the_length_of ~target info x = get_approx info (fun x -> match info.info_defs.(Var.idx x) with | Expr (Constant (String s)) -> Some (Int32.of_int (String.length s)) | Expr (Prim (Extern "caml_create_string", [ arg ])) - | Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int info arg + | Expr (Prim (Extern "caml_create_bytes", [ arg ])) -> the_int ~target info arg | _ -> None) None (fun u v -> @@ -282,7 +282,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 ] @@ -298,7 +298,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 ] @@ -311,7 +311,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 @@ -364,7 +364,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 95aa383a2..5cf402585 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -325,30 +325,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 @@ -363,23 +364,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 3dfb87551..23cffa5a5 100644 --- a/compiler/lib/flow.mli +++ b/compiler/lib/flow.mli @@ -54,13 +54,13 @@ val get_approx : val the_def_of : info -> Code.prim_arg -> Code.expr option -val the_const_of : info -> Code.prim_arg -> Code.constant option +val the_const_of : target:[`JavaScript | `Wasm ] -> info -> Code.prim_arg -> Code.constant option -val the_string_of : info -> Code.prim_arg -> string option +val the_string_of : target:[`JavaScript | `Wasm ] -> info -> Code.prim_arg -> string option -val the_native_string_of : info -> Code.prim_arg -> Code.Native_string.t option +val the_native_string_of : target:[`JavaScript | `Wasm ] -> info -> Code.prim_arg -> Code.Native_string.t option -val the_int : info -> Code.prim_arg -> int32 option +val the_int : target:[`JavaScript | `Wasm ] -> info -> Code.prim_arg -> int32 option val update_def : info -> Code.Var.t -> Code.expr -> unit diff --git a/compiler/lib/specialize_js.ml b/compiler/lib/specialize_js.ml index 314086521..66f1c7fa1 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 @@ -170,7 +170,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 @@ -213,7 +213,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