Avoid polymorphic comparison in backend (ocaml-flambda#3649)

Author: xclerc

backend/afl_instrument.ml

@@ -14,6 +14,7 @@
 
 (* Insert instrumentation for afl-fuzz *)
 
+open! Int_replace_polymorphic_compare
 open Cmm
 
 module V = Backend_var

backend/amd64/emit.ml

@@ -45,18 +45,6 @@ open! Branch_relaxation
 
 let _label s = D.label ~typ:QWORD s
 
-let is_linux = function
-  | S_linux -> true
-  | _ -> false
-
-let is_macosx = function
-  | S_macosx -> true
-  | _ -> false
-
-let is_win64 = function
-  | S_win64 -> true
-  | _ -> false
-
 (* Override proc.ml *)
 
 let int_reg_name =

backend/branch_relaxation.ml

@@ -14,6 +14,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
 open Linear
 
 module Make (T : Branch_relaxation_intf.S) = struct

backend/cmm.ml

@@ -13,6 +13,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
+
 type machtype_component = Cmx_format.machtype_component =
   | Val
   | Addr

backend/cmm_builtins.ml

@@ -13,6 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
 open Cmm
 open Cmm_helpers
 open Arch
@@ -52,7 +53,7 @@ let if_operation_supported op ~f =
   match Proc.operation_supported op with true -> Some (f ()) | false -> None
 
 let if_operation_supported_bi bi op ~f =
-  if bi = Primitive.Unboxed_int64 && size_int = 4
+  if Primitive.equal_unboxed_integer bi Primitive.Unboxed_int64 && size_int = 4
   then None
   else if_operation_supported op ~f
 
@@ -85,13 +86,14 @@ let clz ~arg_is_non_zero bi arg dbg =
   let op = Cclz { arg_is_non_zero } in
   if_operation_supported_bi bi op ~f:(fun () ->
       let res = Cop (op, [make_unsigned_int bi arg dbg], dbg) in
-      if bi = Primitive.Unboxed_int32 && size_int = 8
+      if Primitive.equal_unboxed_integer bi Primitive.Unboxed_int32
+         && size_int = 8
       then Cop (Caddi, [res; Cconst_int (-32, dbg)], dbg)
       else res)
 
 let ctz ~arg_is_non_zero bi arg dbg =
   let arg = make_unsigned_int bi arg dbg in
-  if bi = Primitive.Unboxed_int32 && size_int = 8
+  if Primitive.equal_unboxed_integer bi Primitive.Unboxed_int32 && size_int = 8
   then
     (* regardless of the value of the argument [arg_is_non_zero], always set the
        corresponding field to [true], because we make it non-zero below by
@@ -798,7 +800,10 @@ let builtin_even_if_not_annotated = function
 
 let extcall ~dbg ~returns ~alloc ~is_c_builtin ~effects ~coeffects ~ty_args name
     typ_res args =
-  if not returns then assert (typ_res = typ_void);
+  if not returns
+  then
+    assert (
+      Misc.Stdlib.Array.equal Cmm.equal_machtype_component typ_res typ_void);
   let default =
     Cop
       ( Cextcall

backend/cmm_helpers.ml

@@ -15,6 +15,8 @@
 
 [@@@ocaml.warning "+a-4-9-40-41-42-44-45"]
 
+(* CR-soon xclerc for xclerc: try to add open!
+   Int_replace_polymorphic_compare *)
 module V = Backend_var
 module VP = Backend_var.With_provenance
 open Cmm

backend/cmm_invariants.ml

@@ -14,6 +14,8 @@
 
 [@@@ocaml.warning "-40"]
 
+open! Int_replace_polymorphic_compare
+
 module Int = Numbers.Int
 
 (* Check a number of continuation-related invariants *)

backend/cmmgen_state.ml

@@ -17,6 +17,8 @@
 
 [@@@ocaml.warning "+a-4-30-40-41-42"]
 
+open! Int_replace_polymorphic_compare
+
 module S = Misc.Stdlib.String
 
 type ustructured_constant =

backend/emitaux.ml

@@ -15,6 +15,8 @@
 
 (* Common functions for emitting assembly code *)
 
+open! Int_replace_polymorphic_compare
+
 type error =
   | Stack_frame_too_large of int
   | Stack_frame_way_too_large of int
@@ -62,16 +64,21 @@ let femit_symbol out s = output_string out (symbol_to_string s)
 let emit_symbol s = femit_symbol !output_channel s
 
 let femit_string_literal out s =
+  let between x low high =
+    Char.compare x low >= 0 && Char.compare x high <= 0
+  in
   let last_was_escape = ref false in
   femit_string out "\"";
   for i = 0 to String.length s - 1 do
     let c = s.[i] in
-    if c >= '0' && c <= '9'
+    if between c '0' '9'
     then
       if !last_was_escape
       then Printf.fprintf out "\\%o" (Char.code c)
       else output_char out c
-    else if c >= ' ' && c <= '~' && c <> '"' (* '"' *) && c <> '\\'
+    else if between c ' ' '~'
+            && (not (Char.equal c '"' (* '"' *)))
+            && not (Char.equal c '\\')
     then (
       output_char out c;
       last_was_escape := false)
@@ -221,7 +228,7 @@ let emit_frames a =
     type t = bool * Debuginfo.Dbg.t
 
     let equal ((rs1 : bool), dbg1) (rs2, dbg2) =
-      rs1 = rs2 && Debuginfo.Dbg.compare dbg1 dbg2 = 0
+      Bool.equal rs1 rs2 && Debuginfo.Dbg.compare dbg1 dbg2 = 0
 
     let hash (rs, dbg) = Hashtbl.hash (rs, Debuginfo.Dbg.hash dbg)
   end) in
@@ -362,8 +369,8 @@ let emit_frames a =
       in
       let info =
         if is_fully_packable
-        then fully_pack_info rs d (rest <> [])
-        else partially_pack_info rs d (rest <> [])
+        then fully_pack_info rs d (not (Misc.Stdlib.List.is_empty rest))
+        else partially_pack_info rs d (not (Misc.Stdlib.List.is_empty rest))
       in
       let loc =
         if is_fully_packable
@@ -398,7 +405,7 @@ let emit_frames a =
 
 let isprefix s1 s2 =
   String.length s1 <= String.length s2
-  && String.sub s2 0 (String.length s1) = s1
+  && String.equal (String.sub s2 0 (String.length s1)) s1
 
 let is_generic_function name =
   List.exists
@@ -531,7 +538,7 @@ let reduce_heap_size ~reset =
     then float !Flambda_backend_flags.heap_reduction_threshold
     else Float.infinity
   in
-  if major_words > heap_reduction_threshold
+  if Float.compare major_words heap_reduction_threshold > 0
   then
     Profile.record_call "compact" (fun () ->
         reset ();

backend/fdo_info.ml

@@ -12,6 +12,8 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
+
 type info =
   {
     dbg: Debuginfo.t;

backend/generic_fns.ml

@@ -10,6 +10,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
 open Cmm
 open Cmm_helpers
 module CU = Compilation_unit
@@ -117,7 +118,8 @@ module Tbl0 = struct
   let entries t : Cmx_format.generic_fns =
     let sorted_keys tbl =
       let keys = Hashtbl.fold (fun k () acc -> k :: acc) tbl [] in
-      List.sort compare keys
+      (* CR-soon xclerc for xclerc: avoid polymorphic compare *)
+      List.sort Stdlib.compare keys
     in
     { curry_fun = sorted_keys t.curry;
       apply_fun = sorted_keys t.apply;

backend/linear.ml

@@ -14,6 +14,8 @@
 (**************************************************************************)
 
 (* Transformation of Mach code into a list of pseudo-instructions. *)
+open! Int_replace_polymorphic_compare
+
 type label = Cmm.label
 
 type instruction =

backend/operation.ml

@@ -26,6 +26,8 @@
 
 [@@@ocaml.warning "+a-4-9-40-41-42"]
 
+open! Int_replace_polymorphic_compare [@@ocaml.warning "-66"]
+
 type trap_stack =
   | Uncaught
   | Specific_trap of Cmm.trywith_shared_label * trap_stack

backend/printcmm.ml

@@ -15,6 +15,7 @@
 
 (* Pretty-printing of C-- code *)
 
+open! Int_replace_polymorphic_compare
 open Format
 open Cmm
 

backend/printlinear.ml

@@ -15,6 +15,7 @@
 
 (* Pretty-printing of linearized machine code *)
 
+open! Int_replace_polymorphic_compare
 open Format
 open Linear
 

backend/printoperation.ml

@@ -1,5 +1,6 @@
 [@@@ocaml.warning "+a-4-9-40-41-42"]
 
+open! Int_replace_polymorphic_compare
 open Format
 
 let operation ?(print_reg = Printreg.reg) (op : Operation.t) arg ppf res =

backend/printreg.ml

@@ -17,6 +17,7 @@
 
 [@@@ocaml.warning "+a-4-9-40-41-42"]
 
+open! Int_replace_polymorphic_compare [@@ocaml.warning "-66"]
 open Format
 open! Reg
 

backend/reg.ml

@@ -13,6 +13,7 @@
 (*                                                                        *)
 (**************************************************************************)
 
+open! Int_replace_polymorphic_compare
 open Cmm
 
 type irc_work_list =
@@ -199,7 +200,7 @@ let reset() =
      soft pseudo-registers *)
   if !first_virtual_reg_stamp = -1 then begin
     first_virtual_reg_stamp := !currstamp;
-    assert (!reg_list = []) (* Only hard regs created before now *)
+    assert (Misc.Stdlib.List.is_empty !reg_list) (* Only hard regs created before now *)
   end;
   currstamp := !first_virtual_reg_stamp;
   reg_list := []

backend/vectorize_utils.ml

@@ -1,5 +1,6 @@
 [@@@ocaml.warning "+a-40-42"]
 
+open! Int_replace_polymorphic_compare [@@ocaml.warning "-66"]
 open Arch
 
 module Width_in_bits = struct

backend/x86_binary_emitter.ml

@@ -14,6 +14,7 @@
 
 [@@@ocaml.warning "+A-4-9-69"]
 
+open! Int_replace_polymorphic_compare
 open X86_ast
 open X86_proc
 module String = Misc.Stdlib.String
@@ -275,11 +276,13 @@ let eval_const b current_pos cst =
       (*(X86_gas.string_of_constant cst)*) (Printexc.to_string e);
     raise e
 
-let is_imm32L n = n < 0x8000_0000L && n >= -0x8000_0000L
+let is_imm32L n = Int64.compare n 0x8000_0000L < 0 && Int64.compare n (-0x8000_0000L) >= 0
 
-let is_imm8L x = x < 128L && x >= -128L
+let is_imm8L x = Int64.compare x 128L < 0 && Int64.compare x (-128L) >= 0
 
-let is_imm16L n = n < 32768L && n >= -32768L
+let is_imm16L n = Int64.compare n 32768L < 0 && Int64.compare n (-32768L) >= 0
+
+let is_x86 = function | X86 -> true | X64 -> false
 
 let rd_of_regf regf =
   match regf with
@@ -380,14 +383,14 @@ let record_reloc b offset_from_section_beginning kind =
 
 let declare_label b s =
   let sy = get_symbol b s in
-  assert (sy.sy_pos = None);
+  assert (Option.is_none sy.sy_pos);
   let pos = Buffer.length b.buf in
   sy.sy_pos <- Some pos
 
 let buf_opcodes b opcodes =
   ListLabels.iter ~f:(fun opcode -> buf_int8 b opcode) opcodes
 
-let arch64 = Config.architecture = "amd64"
+let arch64 = String.equal Config.architecture "amd64"
 
 let emit_rex b rexcode =
   if arch64 && rexcode <> 0 then buf_int8 b (rexcode lor rex)
@@ -478,7 +481,7 @@ let emit_prefix_modrm b opcodes rm reg ~prefix =
       let idx_reg = idx in
       let idx = rd_of_reg64 idx in
       if scale = 0 then (
-        assert (base = None && arch = X86);
+        assert (Option.is_none base && (is_x86 arch));
         match offset with
         | OImm8 _ -> assert false
         | OImm32 (sym, offset) ->
@@ -1455,7 +1458,7 @@ let emit_reloc_jump near_opcodes far_opcodes b loc symbol =
       in
 
       (*      Printf.printf "%s/%i: backward  togo_short=%Ld\n%!" symbol loc togo_short; *)
-      if togo_short >= -128L && togo_short < 128L then (
+      if Int64.compare togo_short (-128L)  >= 0 && Int64.compare togo_short 128L < 0 then (
         buf_opcodes b near_opcodes;
         buf_int8L b togo_short)
       else (
@@ -1480,7 +1483,7 @@ let emit_reloc_jump near_opcodes far_opcodes b loc symbol =
         Printf.printf "%s/%i: short\n%!" symbol loc;
 *)
       let force_far =
-        Int64.of_int ((target_loc - loc) * !instr_size) >= 120L
+        Int64.compare (Int64.of_int ((target_loc - loc) * !instr_size)) 120L >= 0
         || IntSet.mem loc !forced_long_jumps
       in
       if force_far then (
@@ -2164,8 +2167,8 @@ let assemble_line b loc ins =
     | External (_, _) -> ()
     | Set (_, _) -> assert false
     | Section _ -> assert false
-    | Mode386 -> assert (system = S_win32)
-    | Model _ -> assert (system = S_win32)
+    | Mode386 -> assert (is_win32 system)
+    | Model _ -> assert (is_win32 system)
     | Cfi_startproc -> ()
     | Cfi_endproc -> ()
     | Cfi_adjust_cfa_offset _ -> ()

backend/x86_dsl.ml

@@ -21,6 +21,7 @@
 *)
 
 
+open! Int_replace_polymorphic_compare
 open X86_ast
 open X86_proc