diff --git a/CHANGES.md b/CHANGES.md index 1ae6f5ebc7..9b5a46451d 100644 --- a/CHANGES.md +++ b/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) diff --git a/compiler/lib/code.ml b/compiler/lib/code.ml index aa84a77f37..995cb3ebdf 100644 --- a/compiler/lib/code.ml +++ b/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 diff --git a/compiler/lib/code.mli b/compiler/lib/code.mli index 0f29bc9550..9390f7b0d4 100644 --- a/compiler/lib/code.mli +++ b/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 diff --git a/compiler/lib/eval.ml b/compiler/lib/eval.ml index 2a694917e4..c1e5dd171c 100644 --- a/compiler/lib/eval.ml +++ b/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 ])) -> ( diff --git a/compiler/lib/flow.ml b/compiler/lib/flow.ml index 9cf193793e..0373aec6e0 100644 --- a/compiler/lib/flow.ml +++ b/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 diff --git a/compiler/lib/stdlib.ml b/compiler/lib/stdlib.ml index 1648cb8a40..2d41605ae8 100644 --- a/compiler/lib/stdlib.ml +++ b/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 diff --git a/compiler/tests-jsoo/test_floats.ml b/compiler/tests-jsoo/test_floats.ml new file mode 100644 index 0000000000..9a6f355d8f --- /dev/null +++ b/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|}]