Fix bugs related to constant equality

See ocsigen#1659.

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
 

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

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

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"
 

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

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

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 ) )
              ])

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"

compiler/lib/linker.ml

@@ -19,6 +19,7 @@
  *)
 
 open! Stdlib
+module Constant = Global_constant
 
 type 'a pack =
   | Ok of 'a

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 *)

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)

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 |}]