Fix uses of polymorphic comparison in Flambda 2

middle_end/flambda2/algorithms/dune

@@ -7,5 +7,5 @@
  (flags
   (:standard -principal))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries ocamlcommon))

middle_end/flambda2/algorithms/lmap.ml

@@ -78,7 +78,7 @@ module Make (T : Thing) : S with type key = T.t = struct
 
   let empty = []
 
-  let is_empty m = m = []
+  let is_empty m = match m with [] -> true | _ :: _ -> false
 
   let add k v m = (k, v) :: m
 
@@ -147,9 +147,9 @@ module Make (T : Thing) : S with type key = T.t = struct
   let of_seq m = List.of_seq m
 
   let print_assoc print_key print_datum ppf l =
-    if l = []
-    then Format.fprintf ppf "{}"
-    else
+    match l with
+    | [] -> Format.fprintf ppf "{}"
+    | _ :: _ ->
       Format.fprintf ppf "@[<hov 1>{%a}@]"
         (Format.pp_print_list ~pp_sep:Format.pp_print_space
            (fun ppf (key, datum) ->

middle_end/flambda2/algorithms/patricia_tree.ml

@@ -12,8 +12,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open! Int_replace_polymorphic_compare
-
 (* The following is a "little endian" implementation. *)
 
 (* CR-someday mshinwell: Can we fix the traversal order by swapping endianness?

middle_end/flambda2/bound_identifiers/dune

@@ -18,7 +18,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/classic_mode_types/dune

@@ -17,7 +17,7 @@
    -open
    Flambda2_term_basics))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_identifiers

middle_end/flambda2/cmx/dune

@@ -32,7 +32,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda_backend_utils

middle_end/flambda2/compare/compare.ml

@@ -1,6 +1,5 @@
 [@@@ocaml.warning "-fragile-match"]
 
-open! Int_replace_polymorphic_compare
 open! Flambda
 
 (* General notes on comparison

middle_end/flambda2/compare/dune

@@ -24,5 +24,5 @@
    -open
    Flambda2_terms))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries ocamlcommon flambda2_algorithms flambda2_terms))

middle_end/flambda2/dune

@@ -32,7 +32,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (modules flambda2)
  (libraries
   ocamlcommon

middle_end/flambda2/from_lambda/closure_conversion.ml

@@ -16,7 +16,6 @@
 
 [@@@ocaml.warning "-fragile-match"]
 
-open! Int_replace_polymorphic_compare
 open! Flambda
 module BP = Bound_parameter
 module IR = Closure_conversion_aux.IR

middle_end/flambda2/from_lambda/closure_conversion_aux.ml

@@ -308,10 +308,10 @@ module Env = struct
     try Variable.Map.find var t.value_approximations
     with Not_found -> Value_approximation.Value_unknown
 
-  let set_path_to_root t path_to_root =
-    if path_to_root = Debuginfo.Scoped_location.Loc_unknown
-    then t
-    else { t with path_to_root }
+  let set_path_to_root t (path_to_root : Debuginfo.Scoped_location.t) =
+    match path_to_root with
+    | Loc_unknown -> t
+    | Loc_known _ -> { t with path_to_root }
 
   let path_to_root { path_to_root; _ } = path_to_root
 

middle_end/flambda2/from_lambda/dune

@@ -34,7 +34,7 @@
    -open
    Flambda2_simplify_shared))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/from_lambda/lambda_to_flambda.ml

@@ -42,7 +42,7 @@ let must_be_singleton_simple simples =
       simples
 
 let print_compact_location ppf (loc : Location.t) =
-  if loc.loc_start.pos_fname = "//toplevel//"
+  if String.equal loc.loc_start.pos_fname "//toplevel//"
   then ()
   else
     let file, line, startchar = Location.get_pos_info loc.loc_start in
@@ -1489,7 +1489,14 @@ and cps_function env ~fid ~(recursive : Recursive.t) ?precomputed_free_idents
       when tag = Obj.double_array_tag ->
       assert (
         List.for_all
-          (fun kind -> kind = Lambda.(Pboxedfloatval Pfloat64))
+          (fun (kind : Lambda.value_kind) ->
+            match kind with
+            | Pboxedfloatval Pfloat64 -> true
+            | Pboxedfloatval Pfloat32
+            (* CR mshinwell: should this unboxing apply for Pfloat32? *)
+            | Pgenval | Pintval | Pboxedintval _ | Pvariant _ | Parrayval _
+            | Pboxedvectorval _ ->
+              false)
           field_kinds);
       Some (Unboxed_float_record (List.length field_kinds))
     | Pvalue (Pboxedfloatval Pfloat64) -> Some (Unboxed_number Naked_float)

middle_end/flambda2/from_lambda/lambda_to_flambda_primitives.ml

@@ -1372,9 +1372,12 @@ let convert_lprim ~big_endian (prim : L.primitive) (args : Simple.t list list)
              (Targetint_31_63.of_int
                 ((1 lsl ((8 * size_int) - (10 + Config.reserved_header_bits)))
                 - 1))) ]
-    | Ostype_unix -> [Simple (Simple.const_bool (Sys.os_type = "Unix"))]
-    | Ostype_win32 -> [Simple (Simple.const_bool (Sys.os_type = "Win32"))]
-    | Ostype_cygwin -> [Simple (Simple.const_bool (Sys.os_type = "Cygwin"))]
+    | Ostype_unix ->
+      [Simple (Simple.const_bool (String.equal Sys.os_type "Unix"))]
+    | Ostype_win32 ->
+      [Simple (Simple.const_bool (String.equal Sys.os_type "Win32"))]
+    | Ostype_cygwin ->
+      [Simple (Simple.const_bool (String.equal Sys.os_type "Cygwin"))]
     | Backend_type ->
       [Simple Simple.const_zero] (* constructor 0 is the same as Native here *)
     | Runtime5 -> [Simple (Simple.const_bool Config.runtime5)])

middle_end/flambda2/identifiers/dune

@@ -16,7 +16,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/identifiers/int_ids.ml

@@ -14,8 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open! Int_replace_polymorphic_compare
-
 let hash_seed =
   let seed = Random.bits () in
   if seed mod 2 = 0 then seed + 1 else seed

middle_end/flambda2/identifiers/rec_info_expr0.ml

@@ -14,8 +14,6 @@
 (*                                                                        *)
 (**************************************************************************)
 
-open! Int_replace_polymorphic_compare
-
 module type S = sig
   type variable
 

middle_end/flambda2/import/dune

@@ -4,5 +4,5 @@
  (name flambda2_import)
  (instrumentation (backend bisect_ppx))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries ocamlcommon))

middle_end/flambda2/kinds/dune

@@ -14,7 +14,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/kinds/flambda_kind.ml

@@ -32,7 +32,18 @@ module Naked_number_kind = struct
     | Naked_nativeint -> Format.pp_print_string ppf "Naked_nativeint"
     | Naked_vec128 -> Format.pp_print_string ppf "Naked_vec128"
 
-  let equal (t1 : t) t2 = t1 = t2
+  let equal t1 t2 =
+    match t1, t2 with
+    | Naked_immediate, Naked_immediate -> true
+    | Naked_float, Naked_float -> true
+    | Naked_int32, Naked_int32 -> true
+    | Naked_int64, Naked_int64 -> true
+    | Naked_nativeint, Naked_nativeint -> true
+    | Naked_vec128, Naked_vec128 -> true
+    | ( ( Naked_immediate | Naked_float | Naked_int32 | Naked_int64
+        | Naked_nativeint | Naked_vec128 ),
+        _ ) ->
+      false
 end
 
 type t =

middle_end/flambda2/lattices/dune

@@ -14,7 +14,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/nominal/dune

@@ -14,7 +14,7 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries
   ocamlcommon
   flambda2_algorithms

middle_end/flambda2/nominal/name_occurrences.ml

@@ -389,43 +389,6 @@ let empty =
     newer_version_of_code_ids = For_code_ids.empty
   }
 
-let [@ocamlformat "disable"] print ppf
-      ({ names;
-         continuations;
-         continuations_with_traps;
-         continuations_in_trap_actions;
-         function_slots_in_projections;
-         value_slots_in_projections;
-         function_slots_in_declarations;
-         value_slots_in_declarations;
-         code_ids;
-         newer_version_of_code_ids } as t) =
-  if t = empty then
-    Format.fprintf ppf "no_occurrences"
-  else
-  Format.fprintf ppf "@[<hov 1>\
-      @[<hov 1>(names %a)@]@ \
-      @[<hov 1>(continuations %a)@]@ \
-      @[<hov 1>(continuations_with_traps %a)@]@ \
-      @[<hov 1>(continuations_in_trap_actions %a)@]@ \
-      @[<hov 1>(function_slots_in_projections %a)@]@ \
-      @[<hov 1>(value_slots_in_projections %a)@]@ \
-      @[<hov 1>(function_slots_in_declarations %a)@]@ \
-      @[<hov 1>(value_slots_in_declarations %a)@]@ \
-      @[<hov 1>(code_ids %a)@] \
-      @[<hov 1>(newer_version_of_code_ids %a)@]@ \
-      @]"
-    For_names.print names
-    For_continuations.print continuations
-    For_continuations.print continuations_with_traps
-    For_continuations.print continuations_in_trap_actions
-    For_function_slots.print function_slots_in_projections
-    For_value_slots.print value_slots_in_projections
-    For_function_slots.print function_slots_in_declarations
-    For_value_slots.print value_slots_in_declarations
-    For_code_ids.print code_ids
-    For_code_ids.print newer_version_of_code_ids
-
 let singleton_continuation cont =
   { empty with
     continuations = For_continuations.singleton cont Name_mode.normal
@@ -1191,3 +1154,40 @@ let increase_counts
     code_ids;
     newer_version_of_code_ids
   }
+
+let [@ocamlformat "disable"] print ppf
+      ({ names;
+         continuations;
+         continuations_with_traps;
+         continuations_in_trap_actions;
+         function_slots_in_projections;
+         value_slots_in_projections;
+         function_slots_in_declarations;
+         value_slots_in_declarations;
+         code_ids;
+         newer_version_of_code_ids } as t) =
+  if is_empty t then
+    Format.fprintf ppf "no_occurrences"
+  else
+  Format.fprintf ppf "@[<hov 1>\
+      @[<hov 1>(names %a)@]@ \
+      @[<hov 1>(continuations %a)@]@ \
+      @[<hov 1>(continuations_with_traps %a)@]@ \
+      @[<hov 1>(continuations_in_trap_actions %a)@]@ \
+      @[<hov 1>(function_slots_in_projections %a)@]@ \
+      @[<hov 1>(value_slots_in_projections %a)@]@ \
+      @[<hov 1>(function_slots_in_declarations %a)@]@ \
+      @[<hov 1>(value_slots_in_declarations %a)@]@ \
+      @[<hov 1>(code_ids %a)@] \
+      @[<hov 1>(newer_version_of_code_ids %a)@]@ \
+      @]"
+    For_names.print names
+    For_continuations.print continuations
+    For_continuations.print continuations_with_traps
+    For_continuations.print continuations_in_trap_actions
+    For_function_slots.print function_slots_in_projections
+    For_value_slots.print value_slots_in_projections
+    For_function_slots.print function_slots_in_declarations
+    For_value_slots.print value_slots_in_declarations
+    For_code_ids.print code_ids
+    For_code_ids.print newer_version_of_code_ids

middle_end/flambda2/numbers/dune

@@ -12,5 +12,5 @@
    -open
    Flambda2_ui))
  (ocamlopt_flags
-  (:standard -O3))
+  (:standard -O3 -open Int_replace_polymorphic_compare))
  (libraries ocamlcommon flambda2_algorithms flambda2_ui))

middle_end/flambda2/numbers/numeric_types.ml

@@ -72,22 +72,6 @@ module Int16 = struct
   let to_int t = t
 end
 
-module Float = struct
-  type t = float
-
-  include Container_types.Make (struct
-    type t = float
-
-    let compare x y = Stdlib.compare x y
-
-    let hash f = Hashtbl.hash f
-
-    let equal (i : float) j = i = j
-
-    let print = Format.pp_print_float
-  end)
-end
-
 module Float_by_bit_pattern = struct
   let create f = Int64.bits_of_float f
 

middle_end/flambda2/numbers/numeric_types.mli

@@ -50,8 +50,6 @@ module Int16 : sig
   val to_int : t -> int
 end
 
-module Float : Container_types.S with type t = float
-
 module Float_by_bit_pattern : sig
   (** Floating point numbers whose comparison and equality relations are the
       usual [Int64] relations on the bit patterns of the floats. This in

middle_end/flambda2/numbers/one_bit_fewer.ml

@@ -39,6 +39,8 @@ module type S = sig
 
   val ( <= ) : t -> t -> bool
 
+  val ( >= ) : t -> t -> bool
+
   val ( < ) : t -> t -> bool
 
   val bottom_byte_to_int : t -> int
@@ -144,9 +146,11 @@ module Make (I : S) : S with type t = I.t = struct
 
   let ( <= ) = I.( <= )
 
+  let ( >= ) = I.( >= )
+
   let ( < ) = I.( < )
 
-  let is_in_range n = n >= min_value && n <= max_value
+  let is_in_range n = I.( >= ) n min_value && I.( <= ) n max_value
 
   let bottom_byte_to_int = I.bottom_byte_to_int
 

middle_end/flambda2/numbers/one_bit_fewer.mli

@@ -25,6 +25,8 @@ module type S = sig
 
   val ( <= ) : t -> t -> bool
 
+  val ( >= ) : t -> t -> bool
+
   val ( < ) : t -> t -> bool
 
   val bottom_byte_to_int : t -> int