Avoid polymorphic comparison over float values (#1048)

* Add a failing test.

* Move `constant_equal` to `Code`.

* Use `Code.constant_equal` instead of polymorphic equality in join.

* Do not use polymorphic equality over `Code.constant` values.

* Add changelog entry.

* Do not use `Int64.equal` (not available in 4.02).

* Do not use `Array.iter2` (not available in 4.0{2,3,4}).

* Do not use `Int64.equal` (not available in 4.02).

* Refmt

* refactor

Co-authored-by: Hugo Heuzard <[email protected]>

Author: xclerc

CHANGES.md

@@ -12,6 +12,7 @@
             when parsing constant in the from the bytecode
 * Compiler: make sure inline doesn't loop indefinitly (#1043)
 * Compiler: fix bug generating invalid javascript for if-then construct (#1046)
+* Compiler: do not use polymorphic comparison when joining float values (#1048)
 * Lib: Rename msg to message in Worker (#1037)
 * Lib: fix graphics_js when build with separate compilation (#1029)
 

compiler/lib/code.ml

@@ -266,6 +266,43 @@ 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)
+  | IString a, IString b -> Some (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 _, IString _ | IString _, String _ -> None
+  | Int _, Float _ | Float _, Int _ -> None
+  | Tuple ((0 | 254), _, _), Float_array _ -> None
+  | Float_array _, Tuple ((0 | 254), _, _) -> None
+  | Tuple _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
+      Some false
+  | Float_array _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
+      Some false
+  | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
+  | IString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
+  | Int64 _, (String _ | IString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
+      Some false
+  | Float _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
+      Some false
+  | Int _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
+      Some false
+
 type prim_arg =
   | Pv of Var.t
   | Pc of constant

compiler/lib/code.mli

@@ -149,6 +149,8 @@ type constant =
   | Tuple of int * constant array * array_or_not
   | Int of int32
 
+val constant_equal : constant -> constant -> bool option
+
 type prim_arg =
   | Pv of Var.t
   | Pc of constant

compiler/lib/eval.ml

@@ -191,43 +191,6 @@ let is_int info x =
   | Pc (Int _) -> Y
   | Pc _ -> N
 
-let rec constant_equal a b =
-  match a, b with
-  | String a, String b -> Some (String.equal a b)
-  | IString a, IString b -> Some (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 (Poly.equal a b)
-  | Float_array a, Float_array b -> Some Poly.(a = b)
-  | Int a, Int b -> Some (Poly.equal a b)
-  | Float a, Float b -> Some (Float.equal a b)
-  | String _, IString _ | IString _, String _ -> None
-  | Int _, Float _ | Float _, Int _ -> None
-  | Tuple ((0 | 254), _, _), Float_array _ -> None
-  | Float_array _, Tuple ((0 | 254), _, _) -> None
-  | Tuple _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Float_array _) ->
-      Some false
-  | Float_array _, (String _ | IString _ | Int64 _ | Int _ | Float _ | Tuple _) ->
-      Some false
-  | String _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-  | IString _, (Int64 _ | Int _ | Float _ | Tuple _ | Float_array _) -> Some false
-  | Int64 _, (String _ | IString _ | Int _ | Float _ | Tuple _ | Float_array _) ->
-      Some false
-  | Float _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
-      Some false
-  | Int _, (String _ | IString _ | Float_array _ | Int64 _ | Tuple (_, _, _)) ->
-      Some false
-
 let eval_instr info i =
   match i with
   | Let (x, Prim (Extern ("caml_js_equals" | "caml_equal"), [ y; z ])) -> (

compiler/lib/flow.ml

@@ -330,7 +330,7 @@ let the_const_of info x =
         None
         (fun u v ->
           match u, v with
-          | Some i, Some j when Poly.(i = j) -> u
+          | Some i, Some j when Poly.(Code.constant_equal i j = Some true) -> u
           | _ -> None)
         x
   | Pc c -> Some c

compiler/lib/stdlib.ml

@@ -239,10 +239,17 @@ module Option = struct
     | Some s -> s
 end
 
+module Int64 = struct
+  include Int64
+
+  let equal (a : int64) (b : int64) = Poly.( = ) a b
+end
+
 module Float = struct
   type t = float
 
-  let equal (a : float) (b : float) = Poly.compare a b = 0
+  let 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 *)
   external classify_float : float -> fpclass = "caml_classify_float"
@@ -564,6 +571,17 @@ module Array = struct
       r := f i (Array.unsafe_get a i) !r
     done;
     !r
+
+  let equal eq a b =
+    let len_a = Array.length a in
+    if len_a <> Array.length b
+    then false
+    else
+      let i = ref 0 in
+      while !i < len_a && eq a.(!i) b.(!i) do
+        incr i
+      done;
+      !i = len_a
 end
 
 module Filename = struct

compiler/tests-jsoo/test_floats.ml

@@ -0,0 +1,27 @@
+(* Js_of_ocaml compiler
+ * http://www.ocsigen.org/js_of_ocaml/
+ * Copyright (C) 2019 Hugo Heuzard
+ *
+ * This program is free software; you can redistribute it and/or modify
+ * it under the terms of the GNU Lesser General Public License as published by
+ * the Free Software Foundation, with linking exception;
+ * either version 2.1 of the License, or (at your option) any later version.
+ *
+ * This program is distributed in the hope that it will be useful,
+ * but WITHOUT ANY WARRANTY; without even the implied warranty of
+ * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
+ * GNU Lesser General Public License for more details.
+ *
+ * You should have received a copy of the GNU Lesser General Public License
+ * along with this program; if not, write to the Free Software
+ * Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307, USA.
+ *)
+
+let%expect_test _ =
+  (* copied from https://github.com/ocaml/ocaml/pull/1794 *)
+  let z =
+    let x = -0. and y = 0. in
+    if mod_float x 1. >= 0. then x else if false then x else y
+  in
+  Printf.printf "%g\n" (1. /. z);
+  [%expect {|-inf|}]