Skip to content

HTTPS clone URL

Subversion checkout URL

You can clone with HTTPS or Subversion.

Download ZIP
Browse files

Reflecting commit 14916 on version/4.02:

PR#6442: prevent re-sharing of "+0.0" and "-0.0".


git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14917 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02
  • Loading branch information...
commit 53886a08e2a47e25aab8e19116b22c64a30b2d97 1 parent 5791532
Xavier Leroy xavierleroy authored
Showing with 72 additions and 3 deletions.
  1. +62 −0 asmcomp/clambda.ml
  2. +7 −0 asmcomp/clambda.mli
  3. +3 −3 asmcomp/compilenv.ml
62 asmcomp/clambda.ml
View
@@ -86,3 +86,65 @@ type value_approximation =
| Value_unknown
| Value_const of uconstant
| Value_global_field of string * int
+
+(* Comparison functions for constants. We must not use Pervasives.compare
+ because it compares "0.0" and "-0.0" equal. (PR#6442) *)
+
+let compare_floats x1 x2 =
+ Int64.compare (Int64.bits_of_float x1) (Int64.bits_of_float x2)
+
+let rec compare_float_lists l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | [], _::_ -> -1
+ | _::_, [] -> 1
+ | h1::t1, h2::t2 ->
+ let c = compare_floats h1 h2 in
+ if c <> 0 then c else compare_float_lists t1 t2
+
+let compare_constants c1 c2 =
+ match c1, c2 with
+ | Uconst_ref(lbl1, c1), Uconst_ref(lbl2, c2) -> String.compare lbl1 lbl2
+ (* Same labels -> same constants.
+ Different labels -> different constants, even if the contents
+ match, because of string constants that must not be
+ reshared. *)
+ | Uconst_int n1, Uconst_int n2 -> Pervasives.compare n1 n2
+ | Uconst_ptr n1, Uconst_ptr n2 -> Pervasives.compare n1 n2
+ | Uconst_ref _, _ -> -1
+ | Uconst_int _, Uconst_ref _ -> 1
+ | Uconst_int _, Uconst_ptr _ -> -1
+ | Uconst_ptr _, _ -> 1
+
+let rec compare_constant_lists l1 l2 =
+ match l1, l2 with
+ | [], [] -> 0
+ | [], _::_ -> -1
+ | _::_, [] -> 1
+ | h1::t1, h2::t2 ->
+ let c = compare_constants h1 h2 in
+ if c <> 0 then c else compare_constant_lists t1 t2
+
+let rank_structured_constant = function
+ | Uconst_float _ -> 0
+ | Uconst_int32 _ -> 1
+ | Uconst_int64 _ -> 2
+ | Uconst_nativeint _ -> 3
+ | Uconst_block _ -> 4
+ | Uconst_float_array _ -> 5
+ | Uconst_string _ -> 6
+
+let compare_structured_constants c1 c2 =
+ match c1, c2 with
+ | Uconst_float x1, Uconst_float x2 -> compare_floats x1 x2
+ | Uconst_int32 x1, Uconst_int32 x2 -> Int32.compare x1 x2
+ | Uconst_int64 x1, Uconst_int64 x2 -> Int64.compare x1 x2
+ | Uconst_nativeint x1, Uconst_nativeint x2 -> Nativeint.compare x1 x2
+ | Uconst_block(t1, l1), Uconst_block(t2, l2) ->
+ let c = t1 - t2 (* no overflow possible here *) in
+ if c <> 0 then c else compare_constant_lists l1 l2
+ | Uconst_float_array l1, Uconst_float_array l2 ->
+ compare_float_lists l1 l2
+ | Uconst_string s1, Uconst_string s2 -> String.compare s1 s2
+ | _, _ -> rank_structured_constant c1 - rank_structured_constant c2
+ (* no overflow possible here *)
7 asmcomp/clambda.mli
View
@@ -86,3 +86,10 @@ type value_approximation =
| Value_unknown
| Value_const of uconstant
| Value_global_field of string * int
+
+(* Comparison functions for constants *)
+
+val compare_structured_constants:
+ ustructured_constant -> ustructured_constant -> int
+val compare_constants:
+ uconstant -> uconstant -> int
6 asmcomp/compilenv.ml
View
@@ -30,9 +30,9 @@ let global_infos_table =
module CstMap =
Map.Make(struct
type t = Clambda.ustructured_constant
- let compare = Pervasives.compare
- (* could use a better version, comparing on the
- first arg of Uconst_ref *)
+ let compare = Clambda.compare_structured_constants
+ (* PR#6442: it is incorrect to use Pervasives.compare on values of type t
+ because it compares "0.0" and "-0.0" equal. *)
end)
type structured_constants =
Please sign in to comment.
Something went wrong with that request. Please try again.