ocaml · damiendoligez · Jul 11, 2018 · Jun 1, 2018 · Jun 1, 2018 · Jun 1, 2018
diff --git a/.depend b/.depend
@@ -1718,6 +1718,11 @@ middle_end/inlining_transforms.cmi : middle_end/base_types/variable.cmi \
     middle_end/inlining_decision_intf.cmi \
     middle_end/inline_and_simplify_aux.cmi middle_end/flambda.cmi \
     middle_end/debuginfo.cmi middle_end/base_types/closure_id.cmi
+middle_end/int_replace_polymorphic_compare.cmo : \
+    middle_end/int_replace_polymorphic_compare.cmi
+middle_end/int_replace_polymorphic_compare.cmx : \
+    middle_end/int_replace_polymorphic_compare.cmi
+middle_end/int_replace_polymorphic_compare.cmi :
 middle_end/internal_variable_names.cmo : parsing/location.cmi \
     bytecomp/lambda.cmi middle_end/internal_variable_names.cmi
 middle_end/internal_variable_names.cmx : parsing/location.cmx \

diff --git a/Changes b/Changes
@@ -161,6 +161,9 @@ Working version
 - GPR#1747: type_cases: always propagate.
   (Thomas Refis, review by Jacques Garrigue)
 
+- GPR#1811: shadow the polymorphic comparison in the middle-end
+  (Xavier Clerc, review by Pierre Chambart)
+
 - GPR#1833: allow non-val payloads in CMM Ccatch handlers
   (Simon Fowler, review by Xavier Clerc)
 

diff --git a/Makefile b/Makefile
@@ -182,6 +182,7 @@ ASMCOMP=\
   driver/opterrors.cmo driver/optcompile.cmo
 
 MIDDLE_END=\
+  middle_end/int_replace_polymorphic_compare.cmo \
   middle_end/debuginfo.cmo \
   middle_end/base_types/tag.cmo \
   middle_end/base_types/linkage_name.cmo \

diff --git a/bytecomp/lambda.ml b/bytecomp/lambda.ml
@@ -181,6 +181,30 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
+let equal_boxed_integer x y =
+  match x, y with
+  | Pnativeint, Pnativeint
+  | Pint32, Pint32
+  | Pint64, Pint64 ->
+    true
+  | (Pnativeint | Pint32 | Pint64), _ ->
+    false
+
+let equal_primitive =
+  (* Should be implemented like [equal_value_kind] of [equal_boxed_integer],
+     i.e. by matching over the various constructors but the type has more
+     than 100 constructors... *)
+  (=)
+
+let equal_value_kind x y =
+  match x, y with
+  | Pgenval, Pgenval -> true
+  | Pfloatval, Pfloatval -> true
+  | Pboxedintval bi1, Pboxedintval bi2 -> equal_boxed_integer bi1 bi2
+  | Pintval, Pintval -> true
+  | (Pgenval | Pfloatval | Pboxedintval _ | Pintval), _ -> false
+
+
 type structured_constant =
     Const_base of constant
   | Const_pointer of int
@@ -194,17 +218,44 @@ type inline_attribute =
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
+let equal_inline_attribute x y =
+  match x, y with
+  | Always_inline, Always_inline
+  | Never_inline, Never_inline
+  | Default_inline, Default_inline ->
+    true
+  | Unroll u, Unroll v ->
+    u = v
+  | (Always_inline | Never_inline | Unroll _ | Default_inline), _ ->
+    false
+
 type specialise_attribute =
   | Always_specialise (* [@specialise] or [@specialise always] *)
   | Never_specialise (* [@specialise never] *)
   | Default_specialise (* no [@specialise] attribute *)
 
+let equal_specialise_attribute x y =
+  match x, y with
+  | Always_specialise, Always_specialise
+  | Never_specialise, Never_specialise
+  | Default_specialise, Default_specialise ->
+    true
+  | (Always_specialise | Never_specialise | Default_specialise), _ ->
+    false
+
 type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt | Variable
 
 type meth_kind = Self | Public | Cached
 
+let equal_meth_kind x y =
+  match x, y with
+  | Self, Self -> true
+  | Public, Public -> true
+  | Cached, Cached -> true
+  | (Self | Public | Cached), _ -> false
+
 type shared_code = (int * int) list
 
 type function_attribute = {

diff --git a/bytecomp/lambda.mli b/bytecomp/lambda.mli
@@ -188,6 +188,12 @@ and raise_kind =
   | Raise_reraise
   | Raise_notrace
 
+val equal_primitive : primitive -> primitive -> bool
+
+val equal_value_kind : value_kind -> value_kind -> bool
+
+val equal_boxed_integer : boxed_integer -> boxed_integer -> bool
+
 type structured_constant =
     Const_base of constant
   | Const_pointer of int
@@ -201,11 +207,18 @@ type inline_attribute =
   | Unroll of int (* [@unroll x] *)
   | Default_inline (* no [@inline] attribute *)
 
+val equal_inline_attribute : inline_attribute -> inline_attribute -> bool
+
 type specialise_attribute =
   | Always_specialise (* [@specialise] or [@specialise always] *)
   | Never_specialise (* [@specialise never] *)
   | Default_specialise (* no [@specialise] attribute *)
 
+val equal_specialise_attribute
+   : specialise_attribute
+  -> specialise_attribute
+  -> bool
+
 type function_kind = Curried | Tupled
 
 type let_kind = Strict | Alias | StrictOpt | Variable
@@ -222,6 +235,8 @@ type let_kind = Strict | Alias | StrictOpt | Variable
 
 type meth_kind = Self | Public | Cached
 
+val equal_meth_kind : meth_kind -> meth_kind -> bool
+
 type shared_code = (int * int) list     (* stack size -> code label *)
 
 type function_attribute = {

diff --git a/middle_end/alias_analysis.ml b/middle_end/alias_analysis.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type allocation_point =
   | Symbol of Symbol.t

diff --git a/middle_end/allocated_const.ml b/middle_end/allocated_const.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type t =
   | Float of float
@@ -43,13 +44,13 @@ let compare (x : t) (y : t) =
   in
   match x, y with
   | Float x, Float y -> compare_floats x y
-  | Int32 x, Int32 y -> compare x y
-  | Int64 x, Int64 y -> compare x y
-  | Nativeint x, Nativeint y -> compare x y
+  | Int32 x, Int32 y -> Int32.compare x y
+  | Int64 x, Int64 y -> Int64.compare x y
+  | Nativeint x, Nativeint y -> Nativeint.compare x y
   | Float_array x, Float_array y -> compare_float_lists x y
   | Immutable_float_array x, Immutable_float_array y -> compare_float_lists x y
-  | String x, String y -> compare x y
-  | Immutable_string x, Immutable_string y -> compare x y
+  | String x, String y -> String.compare x y
+  | Immutable_string x, Immutable_string y -> String.compare x y
   | Float _, _ -> -1
   | _, Float _ -> 1
   | Int32 _, _ -> -1

diff --git a/middle_end/augment_specialised_args.ml b/middle_end/augment_specialised_args.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module E = Inline_and_simplify_aux.Env
 module B = Inlining_cost.Benefit

diff --git a/middle_end/base_types/closure_element.ml b/middle_end/base_types/closure_element.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Variable
 

diff --git a/middle_end/base_types/closure_id.ml b/middle_end/base_types/closure_id.ml
@@ -15,5 +15,6 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Closure_element
diff --git a/middle_end/base_types/closure_origin.ml b/middle_end/base_types/closure_origin.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Closure_id
 

diff --git a/middle_end/base_types/compilation_unit.ml b/middle_end/base_types/compilation_unit.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type t = {
   id : Ident.t;

diff --git a/middle_end/base_types/export_id.ml b/middle_end/base_types/export_id.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module Id : Id_types.Id = Id_types.Id (struct end)
 module Unit_id = Id_types.UnitId (Id) (Compilation_unit)

diff --git a/middle_end/base_types/id_types.ml b/middle_end/base_types/id_types.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module type BaseId = sig
   type t

diff --git a/middle_end/base_types/linkage_name.ml b/middle_end/base_types/linkage_name.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type t = string
 

diff --git a/middle_end/base_types/mutable_variable.ml b/middle_end/base_types/mutable_variable.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Variable
 

diff --git a/middle_end/base_types/set_of_closures_id.ml b/middle_end/base_types/set_of_closures_id.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module Id : Id_types.Id = Id_types.Id (struct end)
 module Unit_id = Id_types.UnitId (Id) (Compilation_unit)

diff --git a/middle_end/base_types/set_of_closures_origin.ml b/middle_end/base_types/set_of_closures_origin.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Set_of_closures_id
 

diff --git a/middle_end/base_types/static_exception.ml b/middle_end/base_types/static_exception.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Numbers.Int
 

diff --git a/middle_end/base_types/symbol.ml b/middle_end/base_types/symbol.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 
 type t =

diff --git a/middle_end/base_types/tag.ml b/middle_end/base_types/tag.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type t = int
 
@@ -30,3 +31,5 @@ let to_int t = t
 
 let zero = 0
 let object_tag = Obj.object_tag
+
+let compare : t -> t -> int = Stdlib.compare
diff --git a/middle_end/base_types/tag.mli b/middle_end/base_types/tag.mli
@@ -25,3 +25,5 @@ val to_int : t -> int
 
 val zero : t
 val object_tag : t
+
+val compare : t -> t -> int
diff --git a/middle_end/base_types/var_within_closure.ml b/middle_end/base_types/var_within_closure.ml
@@ -15,5 +15,6 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 include Closure_element
diff --git a/middle_end/base_types/variable.ml b/middle_end/base_types/variable.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 type t = {
   compilation_unit : Compilation_unit.t;

diff --git a/middle_end/closure_conversion.ml b/middle_end/closure_conversion.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module Env = Closure_conversion_aux.Env
 module Function_decls = Closure_conversion_aux.Function_decls

diff --git a/middle_end/closure_conversion_aux.ml b/middle_end/closure_conversion_aux.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module Env = struct
   type t = {

diff --git a/middle_end/debuginfo.ml b/middle_end/debuginfo.ml
@@ -13,6 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
 open Lexing
 open Location
 
@@ -49,7 +50,7 @@ let item_from_location loc =
     dinfo_line = loc.loc_start.pos_lnum;
     dinfo_char_start = loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
     dinfo_char_end =
-      if loc.loc_end.pos_fname = loc.loc_start.pos_fname
+      if String.equal loc.loc_end.pos_fname loc.loc_start.pos_fname
       then loc.loc_end.pos_cnum - loc.loc_start.pos_bol
       else loc.loc_start.pos_cnum - loc.loc_start.pos_bol;
   }
@@ -88,7 +89,7 @@ let compare dbg1 dbg2 =
     | _ :: _, [] -> 1
     | [], _ :: _ -> -1
     | d1 :: ds1, d2 :: ds2 ->
-      let c = compare d1.dinfo_file d2.dinfo_file in
+      let c = String.compare d1.dinfo_file d2.dinfo_file in
       if c <> 0 then c else
       let c = compare d1.dinfo_line d2.dinfo_line in
       if c <> 0 then c else

diff --git a/middle_end/effect_analysis.ml b/middle_end/effect_analysis.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 let no_effects_prim (prim : Lambda.primitive) =
   match Semantics_of_primitives.for_primitive prim with

diff --git a/middle_end/extract_projections.ml b/middle_end/extract_projections.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 module A = Simple_value_approx
 module E = Inline_and_simplify_aux.Env

diff --git a/middle_end/find_recursive_functions.ml b/middle_end/find_recursive_functions.ml
@@ -15,6 +15,7 @@
 (**************************************************************************)
 
 [@@@ocaml.warning "+a-4-9-30-40-41-42"]
+open! Int_replace_polymorphic_compare
 
 let in_function_declarations (function_decls : Flambda.function_declarations)
       ~backend =