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 d8a4e48e2..5892f8dc1 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -66,14 +66,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) @@ -255,16 +256,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 ]) @@ -300,8 +336,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 d0a610d90..8195a7cb9 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 + |}]