Fix for PR#7024: CSE confuses +0.0 and -0.0PR7042

The fix consists in representing float literals by their bit patterns (int64) in the Mach and Linear intermediate languages.

A regression test was added to the test suite.

13 files changed, 57 insertions, 27 deletions

diff --git a/asmcomp/amd64/emit.mlp b/asmcomp/amd64/emit.mlp
index 1e39a9490d..4c012009e7 100644
--- a/asmcomp/amd64/emit.mlp
+++ b/asmcomp/amd64/emit.mlp
@@ -421,12 +421,11 @@ let output_epilogue f =
 let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
-  let repr = Int64.bits_of_float cst in
   try
-    List.assoc repr !float_constants
+    List.assoc cst !float_constants
   with Not_found ->
     let lbl = new_label() in
-    float_constants := (repr, lbl) :: !float_constants;
+    float_constants := (cst, lbl) :: !float_constants;
     lbl
 
 let emit_float_constant f lbl =
@@ -470,7 +469,7 @@ let emit_instr fallthrough i =
       else
         I.mov (nat n) (res i 0)
   | Lop(Iconst_float f) ->
-      begin match Int64.bits_of_float f with
+      begin match f with
       | 0x0000_0000_0000_0000L ->       (* +0.0 *)
           I.xorpd (res i 0) (res i 0)
       | _ ->
diff --git a/asmcomp/arm/emit.mlp b/asmcomp/arm/emit.mlp
index 440f4630c4..2c8ecabc96 100644
--- a/asmcomp/arm/emit.mlp
+++ b/asmcomp/arm/emit.mlp
@@ -285,13 +285,12 @@ let num_literals = ref 0
 
 (* Label a floating-point literal *)
 let float_literal f =
-  let repr = Int64.bits_of_float f in
   try
-    List.assoc repr !float_literals
+    List.assoc f !float_literals
   with Not_found ->
     let lbl = new_label() in
     num_literals := !num_literals + 2;
-    float_literals := (repr, lbl) :: !float_literals;
+    float_literals := (f, lbl) :: !float_literals;
     lbl
 
 (* Label a GOTREL literal *)
@@ -393,9 +392,8 @@ let emit_instr i =
     | Lop(Iconst_int n | Iconst_blockheader n) ->
         emit_intconst i.res.(0) (Nativeint.to_int32 n)
     | Lop(Iconst_float f) when !fpu = Soft ->
-        let bits = Int64.bits_of_float f in
-        let high_bits = Int64.to_int32 (Int64.shift_right_logical bits 32)
-        and low_bits = Int64.to_int32 bits in
+        let high_bits = Int64.to_int32 (Int64.shift_right_logical f 32)
+        and low_bits = Int64.to_int32 f in
         if is_immediate low_bits || is_immediate high_bits then begin
           let ninstr_low = emit_intconst i.res.(0) low_bits
           and ninstr_high = emit_intconst i.res.(1) high_bits in
@@ -427,7 +425,7 @@ let emit_instr i =
               let ex = ((ex + 3) land 0x07) lxor 0x04 in
               Some((sg lsl 7) lor (ex lsl 4) lor mn)
           end in
-        begin match encode (Int64.bits_of_float f) with
+        begin match encode f with
           None ->
             let lbl = float_literal f in
             `	fldd	{emit_reg i.res.(0)}, {emit_label lbl}\n`
diff --git a/asmcomp/arm64/emit.mlp b/asmcomp/arm64/emit.mlp
index bc0513940b..eec5915648 100644
--- a/asmcomp/arm64/emit.mlp
+++ b/asmcomp/arm64/emit.mlp
@@ -565,13 +565,12 @@ let emit_instr i =
     | Lop(Iconst_int n | Iconst_blockheader n) ->
         emit_intconst i.res.(0) n
     | Lop(Iconst_float f) ->
-        let b = Int64.bits_of_float f in
-        if b = 0L then
+        if f = 0L then
           `	fmov	{emit_reg i.res.(0)}, xzr\n`
-        else if is_immediate_float b then
-          `	fmov	{emit_reg i.res.(0)}, #{emit_printf "0x%Lx" b}\n`
+        else if is_immediate_float f then
+          `	fmov	{emit_reg i.res.(0)}, #{emit_printf "0x%Lx" f}\n`
         else begin
-          let lbl = float_literal b in
+          let lbl = float_literal f in
           `	adrp	{emit_reg reg_tmp1}, {emit_label lbl}\n`;
           `	ldr	{emit_reg i.res.(0)}, [{emit_reg reg_tmp1}, #:lo12:{emit_label lbl}]\n`
         end
diff --git a/asmcomp/i386/emit.mlp b/asmcomp/i386/emit.mlp
index 70b4540d9a..abc5503339 100644
--- a/asmcomp/i386/emit.mlp
+++ b/asmcomp/i386/emit.mlp
@@ -439,13 +439,12 @@ let emit_floatspecial = function
 let float_constants = ref ([] : (int64 * int) list)
 
 let add_float_constant cst =
-  let repr = Int64.bits_of_float cst in
   try
-    List.assoc repr !float_constants
+    List.assoc cst !float_constants
   with
     Not_found ->
       let lbl = new_label() in
-      float_constants := (repr, lbl) :: !float_constants;
+      float_constants := (cst, lbl) :: !float_constants;
       lbl
 
 let emit_float64_split_directive x =
@@ -502,7 +501,7 @@ let emit_instr fallthrough i =
       end else
         I.mov (nat n) (reg i.res.(0))
   | Lop(Iconst_float f) ->
-      begin match Int64.bits_of_float f with
+      begin match f with
       | 0x0000_0000_0000_0000L ->       (* +0.0 *)
           I.fldz ()
       | 0x8000_0000_0000_0000L ->       (* -0.0 *)
diff --git a/asmcomp/mach.ml b/asmcomp/mach.ml
index 3a7174763a..8a32f226f4 100644
--- a/asmcomp/mach.ml
+++ b/asmcomp/mach.ml
@@ -36,7 +36,7 @@ type operation =
   | Ispill
   | Ireload
   | Iconst_int of nativeint
-  | Iconst_float of float
+  | Iconst_float of int64
   | Iconst_symbol of string
   | Iconst_blockheader of nativeint
   | Icall_ind
diff --git a/asmcomp/mach.mli b/asmcomp/mach.mli
index 618e5e4ce7..d86fc389ba 100644
--- a/asmcomp/mach.mli
+++ b/asmcomp/mach.mli
@@ -36,7 +36,7 @@ type operation =
   | Ispill
   | Ireload
   | Iconst_int of nativeint
-  | Iconst_float of float
+  | Iconst_float of int64
   | Iconst_symbol of string
   | Iconst_blockheader of nativeint
   | Icall_ind
diff --git a/asmcomp/power/emit.mlp b/asmcomp/power/emit.mlp
index eac1231dca..320ad26ab7 100644
--- a/asmcomp/power/emit.mlp
+++ b/asmcomp/power/emit.mlp
@@ -550,11 +550,11 @@ let emit_instr i =
         begin match abi with
         | ELF32 ->
           let lbl = new_label() in
-          float_literals := (Int64.bits_of_float f, lbl) :: !float_literals;
+          float_literals := (f, lbl) :: !float_literals;
           `	addis	11, 0, {emit_upper emit_label lbl}\n`;
           `	lfd	{emit_reg i.res.(0)}, {emit_lower emit_label lbl}(11)\n`
         | ELF64v1 | ELF64v2 ->
-          let entry = TocFloat (Int64.bits_of_float f) in
+          let entry = TocFloat f in
           let lbl = label_for_tocref entry in
           if !big_toc || !Clflags.for_package <> None then begin
             `	addis	11, 2, {emit_label lbl}@toc@ha\n`;
diff --git a/asmcomp/printmach.ml b/asmcomp/printmach.ml
index 7c4679f8de..7ddc62190a 100644
--- a/asmcomp/printmach.ml
+++ b/asmcomp/printmach.ml
@@ -109,7 +109,7 @@ let operation op arg ppf res =
   | Ireload -> fprintf ppf "%a (reload)" regs arg
   | Iconst_int n
   | Iconst_blockheader n -> fprintf ppf "%s" (Nativeint.to_string n)
-  | Iconst_float f -> fprintf ppf "%F" f
+  | Iconst_float f -> fprintf ppf "%F" (Int64.float_of_bits f)
   | Iconst_symbol s -> fprintf ppf "\"%s\"" s
   | Icall_ind -> fprintf ppf "call %a" regs arg
   | Icall_imm lbl -> fprintf ppf "call \"%s\" %a" lbl regs arg
diff --git a/asmcomp/selectgen.ml b/asmcomp/selectgen.ml
index 79d95b4313..92c7b1a216 100644
--- a/asmcomp/selectgen.ml
+++ b/asmcomp/selectgen.ml
@@ -449,7 +449,7 @@ method emit_expr env exp =
       Some(self#insert_op (Iconst_blockheader n) [||] r)
   | Cconst_float n ->
       let r = self#regs_for typ_float in
-      Some(self#insert_op (Iconst_float n) [||] r)
+      Some(self#insert_op (Iconst_float (Int64.bits_of_float n)) [||] r)
   | Cconst_symbol n ->
       let r = self#regs_for typ_val in
       Some(self#insert_op (Iconst_symbol n) [||] r)
diff --git a/asmcomp/sparc/emit.mlp b/asmcomp/sparc/emit.mlp
index b29278fdf2..0a87bf4b34 100644
--- a/asmcomp/sparc/emit.mlp
+++ b/asmcomp/sparc/emit.mlp
@@ -323,7 +323,7 @@ let rec emit_instr i dslot =
         (* On UltraSPARC, the fzero instruction could be used to set a
            floating point register pair to zero. *)
         let lbl = new_label() in
-        float_constants := (lbl, Int64.bits_of_float f) :: !float_constants;
+        float_constants := (lbl, f) :: !float_constants;
         `	sethi	%hi({emit_label lbl}), %g1\n`;
         `	ldd	[%g1 + %lo({emit_label lbl})], {emit_reg i.res.(0)}\n`
     | Lop(Iconst_symbol s) ->
diff --git a/testsuite/tests/regression/pr7024/Makefile b/testsuite/tests/regression/pr7024/Makefile
new file mode 100644
index 0000000000..1cc531cf9e
--- /dev/null
+++ b/testsuite/tests/regression/pr7024/Makefile
@@ -0,0 +1,17 @@
+#########################################################################
+#                                                                       #
+#                                 OCaml                                 #
+#                                                                       #
+#           Damien Doligez, projet Gallium, INRIA Rocquencourt          #
+#                                                                       #
+#   Copyright 2013 Institut National de Recherche en Informatique et    #
+#   en Automatique.  All rights reserved.  This file is distributed     #
+#   under the terms of the Q Public License version 1.0.                #
+#                                                                       #
+#########################################################################
+
+MAIN_MODULE=pr7024
+
+BASEDIR=../../..
+include $(BASEDIR)/makefiles/Makefile.one
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/regression/pr7024/pr7024.ml b/testsuite/tests/regression/pr7024/pr7024.ml
new file mode 100644
index 0000000000..32c64c53f7
--- /dev/null
+++ b/testsuite/tests/regression/pr7024/pr7024.ml
@@ -0,0 +1,17 @@
+(***********************************************************************)
+(*                                                                     *)
+(*                                OCaml                                *)
+(*                                                                     *)
+(*          Xavier Leroy, projet Gallium, INRIA Paris-Rocquencourt     *)
+(*                                                                     *)
+(*  Copyright 2015 Institut National de Recherche en Informatique et   *)
+(*  en Automatique.  All rights reserved.  This file is distributed    *)
+(*  under the terms of the Q Public License version 1.0.               *)
+(*                                                                     *)
+(***********************************************************************)
+
+let _ =
+  let a = [| 0.0; -. 0.0 |] in
+  Printf.printf "%Lx %Lx\n"
+                (Int64.bits_of_float a.(0)) (Int64.bits_of_float a.(1))
+
diff --git a/testsuite/tests/regression/pr7024/pr7024.reference b/testsuite/tests/regression/pr7024/pr7024.reference
new file mode 100644
index 0000000000..c6a412a469
--- /dev/null
+++ b/testsuite/tests/regression/pr7024/pr7024.reference
@@ -0,0 +1 @@
+0 8000000000000000