From 89f04f0a96f33068920727b5ec3077474f5c147e Mon Sep 17 00:00:00 2001 From: Olivier Nicole Date: Fri, 2 Aug 2024 11:36:09 +0200 Subject: [PATCH] Fix bugs related to constant equality See #1659. --- CHANGES.md | 1 + compiler/lib/code.ml | 76 ++++++++++--------- compiler/lib/code.mli | 10 ++- compiler/lib/driver.ml | 1 + compiler/lib/eval.ml | 33 +++++++- compiler/lib/flow.ml | 22 +++++- compiler/lib/generate.ml | 4 +- .../lib/{constant.ml => global_constant.ml} | 0 compiler/lib/javascript.ml | 4 +- compiler/lib/linker.ml | 1 + compiler/lib/stdlib.ml | 2 +- compiler/tests-compiler/dune.inc | 15 ++++ compiler/tests-compiler/gh1659.ml | 9 +++ 13 files changed, 131 insertions(+), 47 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 a96e6e6028..930fa9d93a 100644 --- a/CHANGES.md +++ b/CHANGES.md @@ -16,6 +16,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 65590739b7..a6200d133b 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 Poly.equal a b) + | Int a, Int b -> Some (Int32.equal a b) + | Float a, Float b -> Some (Poly.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 a4edf34e99..efcb371a2c 100644 --- a/compiler/lib/code.mli +++ b/compiler/lib/code.mli @@ -185,9 +185,13 @@ type constant = | Tuple of int * constant array * array_or_not | Int of int32 -(** Guaranteed equality in terms of both OCaml [(=)]: if [constant_equal a b = - Some v], then [Poly.(=) a b = v]. This is used for optimization purposes. *) -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 both 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 86a329177a..bd218ec834 100644 --- a/compiler/lib/driver.ml +++ b/compiler/lib/driver.ml @@ -18,6 +18,7 @@ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA. *) open! Stdlib +module Constant = Global_constant let debug = Debug.find "main" diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 40df068a7d..5222e1ab22 100644 --- a/compiler/lib/eval.ml +++ b/compiler/lib/eval.ml @@ -233,12 +233,41 @@ 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 = Some 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 (Poly.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", [ 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 = if c then 1l else 0l in + let c = Constant (Int c) in + Flow.Info.update_def info x c; + [ Let (x, c), loc ]) + | _ -> [ i ]) + | Let (x, Prim (Extern "caml_js_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 diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 412af3089a..fe08441619 100644 --- a/compiler/lib/flow.ml +++ b/compiler/lib/flow.ml @@ -337,6 +337,26 @@ 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 + | 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 +372,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 fe90ba8062..0203314629 100644 --- a/compiler/lib/generate.ml +++ b/compiler/lib/generate.ml @@ -1733,7 +1733,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 @@ -1909,7 +1909,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..9c1355c7d5 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 Poly.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 Poly.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..ebda4b9a1a 100644 --- a/compiler/lib/linker.ml +++ b/compiler/lib/linker.ml @@ -19,6 +19,7 @@ *) open! Stdlib +module Constant = Global_constant type 'a pack = | Ok of 'a diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 3c197c20dd..7a36af9a18 100644 --- a/compiler/lib/stdlib.ml +++ b/compiler/lib/stdlib.ml @@ -401,7 +401,7 @@ end module Float = struct type t = float - let equal (a : float) (b : float) = + 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..55c3016841 --- /dev/null +++ b/compiler/tests-compiler/gh1659.ml @@ -0,0 +1,9 @@ +let%expect_test _ = + let prog = {| +let x = (0., 0.) = (-0., 0.);; + +Printf.printf "%B\n" x;; + |} in + Util.compile_and_run prog; + [%expect {| + true |}]