flambda-backend: A more consistent first-to-last order for -w53 (unused attributes) (#1658)

Author: antalsz

lambda/debuginfo.ml

@@ -231,17 +231,17 @@ let compare { dbg = dbg1; } { dbg = dbg2; } =
     | d1 :: ds1, d2 :: ds2 ->
       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
+      let c = Int.compare d1.dinfo_line d2.dinfo_line in
       if c <> 0 then c else
-      let c = compare d1.dinfo_char_end d2.dinfo_char_end in
+      let c = Int.compare d1.dinfo_char_end d2.dinfo_char_end in
       if c <> 0 then c else
-      let c = compare d1.dinfo_char_start d2.dinfo_char_start in
+      let c = Int.compare d1.dinfo_char_start d2.dinfo_char_start in
       if c <> 0 then c else
-      let c = compare d1.dinfo_start_bol d2.dinfo_start_bol in
+      let c = Int.compare d1.dinfo_start_bol d2.dinfo_start_bol in
       if c <> 0 then c else
-      let c = compare d1.dinfo_end_bol d2.dinfo_end_bol in
+      let c = Int.compare d1.dinfo_end_bol d2.dinfo_end_bol in
       if c <> 0 then c else
-      let c = compare d1.dinfo_end_line d2.dinfo_end_line in
+      let c = Int.compare d1.dinfo_end_line d2.dinfo_end_line in
       if c <> 0 then c else
       loop ds1 ds2
   in

parsing/builtin_attributes.ml

@@ -31,11 +31,7 @@ let mark_used t = Attribute_table.remove unused_attrs t
 (* [attr_order] is used to issue unused attribute warnings in the order the
    attributes occur in the file rather than the random order of the hash table
 *)
-let attr_order a1 a2 =
-  match String.compare a1.loc.loc_start.pos_fname a2.loc.loc_start.pos_fname
-  with
-  | 0 -> Int.compare a1.loc.loc_start.pos_lnum a2.loc.loc_start.pos_lnum
-  | n -> n
+let attr_order a1 a2 = Location.compare a1.loc a2.loc
 
 let unchecked_properties = Attribute_table.create 1
 let mark_property_checked txt loc =

parsing/location.ml

@@ -18,6 +18,46 @@ open Lexing
 type t = Warnings.loc =
   { loc_start: position; loc_end: position; loc_ghost: bool };;
 
+let compare_position : position -> position -> int =
+  fun
+    { pos_fname = pos_fname_1
+    ; pos_lnum = pos_lnum_1
+    ; pos_bol = pos_bol_1
+    ; pos_cnum = pos_cnum_1
+    }
+    { pos_fname = pos_fname_2
+    ; pos_lnum = pos_lnum_2
+    ; pos_bol = pos_bol_2
+    ; pos_cnum = pos_cnum_2
+    }
+  ->
+    match String.compare pos_fname_1 pos_fname_2 with
+    | 0 -> begin match Int.compare pos_lnum_1 pos_lnum_2 with
+      | 0 -> begin match Int.compare pos_bol_1 pos_bol_2 with
+        | 0 -> Int.compare pos_cnum_1 pos_cnum_2
+        | i -> i
+      end
+      | i -> i
+    end
+    | i -> i
+;;
+
+let compare
+      { loc_start = loc_start_1
+      ; loc_end = loc_end_1
+      ; loc_ghost = loc_ghost_1 }
+      { loc_start = loc_start_2
+      ; loc_end = loc_end_2
+      ; loc_ghost = loc_ghost_2 }
+  =
+  match compare_position loc_start_1 loc_start_2 with
+  | 0 -> begin match compare_position loc_end_1 loc_end_2 with
+    | 0 -> Bool.compare loc_ghost_1 loc_ghost_2
+    | i -> i
+  end
+  | i -> i
+;;
+
 let in_file name =
   let loc = { dummy_pos with pos_fname = name } in
   { loc_start = loc; loc_end = loc; loc_ghost = true }
@@ -274,6 +314,11 @@ struct
   (* non overlapping intervals *)
   type 'a t = ('a bound * 'a bound) list
 
+  let compare (fst1, snd1) (fst2, snd2) =
+    match Int.compare fst1 fst2 with
+    | 0 -> Int.compare snd1 snd2
+    | i -> i
+
   let of_intervals intervals =
     let pos =
       List.map (fun ((a, x), (b, y)) ->

parsing/location.mli

@@ -52,6 +52,14 @@ type t = Warnings.loc = {
    Else all fields are correct.
 *)
 
+(** Strict comparison: Compares all fields of the two locations, irrespective of
+    whether or not they happen to refer to the same place.  For fully-defined
+    locations within the same file, is guaranteed to return them in source
+    order; otherwise, or if given two locations that differ only in ghostiness,
+    is just guaranteed to produce a consistent order, but which one is
+    unspecified. *)
+val compare : t -> t -> int
+
 val none : t
 (** An arbitrary value of type [t]; describes an empty ghost range. *)
 

testsuite/tests/warnings/w53.compilers.reference

@@ -98,14 +98,14 @@ File "w53.ml", line 75, characters 14-25:
 75 |   type t4 [@@@immediate64] (* rejected *)
                    ^^^^^^^^^^^
 Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
-File "w53.ml", line 79, characters 32-43:
-79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
-                                     ^^^^^^^^^^^
-Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
 File "w53.ml", line 79, characters 15-24:
 79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
                     ^^^^^^^^^
 Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context
+File "w53.ml", line 79, characters 32-43:
+79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
+                                     ^^^^^^^^^^^
+Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
 File "w53.ml", line 84, characters 26-31:
 84 |   type t2 = {x : int} [@@@boxed]   (* rejected *)
                                ^^^^^
@@ -118,14 +118,14 @@ File "w53.ml", line 87, characters 17-24:
 87 |   val x : int [@@unboxed]          (* rejected *)
                       ^^^^^^^
 Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context
-File "w53.ml", line 91, characters 30-35:
-91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
-                                   ^^^^^
-Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
 File "w53.ml", line 91, characters 15-22:
 91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
                     ^^^^^^^
 Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context
+File "w53.ml", line 91, characters 30-35:
+91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
+                                   ^^^^^
+Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
 File "w53.ml", line 95, characters 21-30:
 95 |   type 'a t1 = 'a [@@principal] (* rejected *)
                           ^^^^^^^^^

testsuite/tests/warnings/w53_marshalled.compilers.reference

@@ -94,14 +94,14 @@ File "w53.ml", line 75, characters 14-25:
 75 |   type t4 [@@@immediate64] (* rejected *)
                    ^^^^^^^^^^^
 Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
-File "w53.ml", line 79, characters 32-43:
-79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
-                                     ^^^^^^^^^^^
-Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
 File "w53.ml", line 79, characters 15-24:
 79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
                     ^^^^^^^^^
 Warning 53 [misplaced-attribute]: the "immediate" attribute cannot appear in this context
+File "w53.ml", line 79, characters 32-43:
+79 |   let x = (4 [@immediate], 42 [@immediate64]) (* rejected *)
+                                     ^^^^^^^^^^^
+Warning 53 [misplaced-attribute]: the "immediate64" attribute cannot appear in this context
 File "w53.ml", line 84, characters 26-31:
 84 |   type t2 = {x : int} [@@@boxed]   (* rejected *)
                                ^^^^^
@@ -114,14 +114,14 @@ File "w53.ml", line 87, characters 17-24:
 87 |   val x : int [@@unboxed]          (* rejected *)
                       ^^^^^^^
 Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context
-File "w53.ml", line 91, characters 30-35:
-91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
-                                   ^^^^^
-Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
 File "w53.ml", line 91, characters 15-22:
 91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
                     ^^^^^^^
 Warning 53 [misplaced-attribute]: the "unboxed" attribute cannot appear in this context
+File "w53.ml", line 91, characters 30-35:
+91 |   let x = (5 [@unboxed], 42 [@boxed]) (* rejected *)
+                                   ^^^^^
+Warning 53 [misplaced-attribute]: the "boxed" attribute cannot appear in this context
 File "w53.ml", line 95, characters 21-30:
 95 |   type 'a t1 = 'a [@@principal] (* rejected *)
                           ^^^^^^^^^

tools/ocamlprof.ml

@@ -134,7 +134,7 @@ let init_rewrite modes mod_name =
   end
 
 let final_rewrite add_function =
-  to_insert := List.sort (fun x y -> compare (snd x) (snd y)) !to_insert;
+  to_insert := List.sort (fun x y -> Int.compare (snd x) (snd y)) !to_insert;
   prof_counter := 0;
   List.iter add_function !to_insert;
   copy (in_channel_length !inchan);

typing/stypes.ml

@@ -65,8 +65,8 @@ let record_phrase loc =
    same upper bound -> sorted by decreasing lower bound
 *)
 let cmp_loc_inner_first loc1 loc2 =
-  match compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
-  | 0 -> compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
+  match Int.compare loc1.loc_end.pos_cnum loc2.loc_end.pos_cnum with
+  | 0 -> Int.compare loc2.loc_start.pos_cnum loc1.loc_start.pos_cnum
   | x -> x
 ;;
 let cmp_ti_inner_first ti1 ti2 =