From 9602504d7b58e5bc70df0ea800f3c3c2817f8ee0 Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Tue, 27 Aug 2024 11:09:11 +0200 Subject: [PATCH] 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 --- CHANGES.md | 1 + compiler/lib/code.ml | 76 ++++++++++--------- 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 +++++++++++++++ 13 files changed, 224 insertions(+), 69 deletions(-) rename compiler/lib/{constant.ml => global_constant.ml} (100%) create mode 100644 compiler/tests-compiler/gh1659.ml diff --git a/CHANGES.md b/CHANGES.md index f9fbc2d835..1d9de3f2a6 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -17,6 +17,7 @@ * Runtime: fix parsing of unsigned integers (0u2147483648) * Toplevel: fix missing primitives with separate compilation * Compiler: fix link of packed modules with separate compilation +* Fixed the static evaluation of some equalities (#1659) # 5.8.2 (2024-05-26) - Luc diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index e26ebaa808..0dda239870 100644 --- a/compiler/lib/code.ml +++ b/compiler/lib/code.ml @@ -367,42 +367,46 @@ type constant = | Tuple of int * constant array * array_or_not | Int of int32 -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 - | Int64 a, Int64 b -> Some (Int64.equal a b) - | Float_array a, Float_array b -> Some (Array.equal Float.equal a b) - | Int a, Int b -> Some (Int32.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 _ | Float _ | Float_array _) -> - Some false - | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) -> - Some false - | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false - | NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false - | Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) -> - Some false - | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> - Some false - | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> - Some false +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 + | Int64 a, Int64 b -> Some (Int64.equal a b) + | Float_array a, Float_array b -> Some (Array.equal Float.ieee_equal a b) + | Int a, Int b -> Some (Int32.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 _ | Float _ | Float_array _) -> + Some false + | Float_array _, (String _ | NativeString _ | Int64 _ | Int _ | Float _ | Tuple _) -> + Some false + | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false + | NativeString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false + | Int64 _, (String _ | NativeString _ | Int _ | Float _ | Tuple _ | Float_array _) -> + Some false + | Float _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> + Some false + | Int _, (String _ | NativeString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) -> + Some false +end type loc = | No diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 2cbbf4721b..1361302ad4 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -174,6 +174,8 @@ module Native_string : sig val of_string : string -> t val of_bytestring : string -> t + + val equal : t -> t -> bool end type constant = @@ -185,7 +187,13 @@ type constant = | Tuple of int * constant array * array_or_not | Int of int32 -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 655b396c7d..6c638469ee 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -255,9 +255,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_ @@ -380,7 +380,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 ) @@ -391,7 +391,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 ] @@ -420,7 +420,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 ) ) ] ) @@ -526,27 +526,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 @@ -560,14 +563,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 40df068a7d..10615cca24 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -65,14 +65,15 @@ let float_unop l f = | [ 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 x = match x with | Not, [ Int i ] -> bool Int32.(i = 0l) @@ -233,16 +234,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 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.Info.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.Info.update_def info x c; [ Let (x, c), loc ]) | _ -> [ i ]) @@ -268,8 +304,7 @@ let eval_instr info ((x, loc) as i) = match is_int 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.Info.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 412af3089a..85ce73cd6c 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -337,6 +337,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 -> @@ -352,7 +374,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 93cdf36cfe..a219cbee89 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1737,7 +1737,7 @@ and compile_conditional st queue ~fall_through last scope_stack : _ * _ = 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 scope_stack ~fall_through @@ -1913,7 +1913,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 e77d176190..1a13813fe1 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 1629afc5a8..fa50703f8a 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 72bd5f14ec..d67f4b0483 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 01f0f0da6a..2e5db3e098 100644 --- a/compiler/tests-compiler/dune.inc +++ b/compiler/tests-compiler/dune.inc @@ -419,6 +419,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 0000000000..3607703f22 --- /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 + |}]