Make IRC coalescing respect registers with multiple names (#2573)

Author: TheNumbat

.github/workflows/build.yml

@@ -71,24 +71,28 @@ jobs:
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
             build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
+            ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
             check_arch: true
 
           - name: irc_frame_pointers
             config: --enable-middle-end=flambda2 --enable-frame-pointers
             os: ubuntu-latest
             build_ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
+            ocamlparam: '_,w=-46,regalloc=irc,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=IRC_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1'
             check_arch: true
 
           - name: ls
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
             build_ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1'
+            ocamlparam: '_,w=-46,regalloc=ls,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=LS_ORDER:layout,regalloc-validate=1'
             check_arch: true
 
           - name: gi
             config: --enable-middle-end=flambda2
             os: ubuntu-latest
             build_ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1'
+            ocamlparam: '_,w=-46,regalloc=gi,regalloc-param=SPLIT_LIVE_RANGES:on,regalloc-param=GI_PRIORITY_HEURISTICS:interval-length,regalloc-param=GI_SELECTION_HEURISTICS:first-available,regalloc-param=GI_SPILLING_HEURISTICS:flat-uses,regalloc-validate=1,cfg-cse-optimize=1'
             check_arch: true
 
     env:

backend/amd64/emit.mlp

@@ -799,24 +799,23 @@ let emit_global_label s =
   emit_global_label_for_symbol lbl
 
 let move (src : Reg.t) (dst : Reg.t) =
-  if src.loc <> dst.loc then
-    begin match src.typ, src.loc, dst.typ, dst.loc with
-    | Float, Reg _, Float, Reg _
-    | Float32, Reg _, Float32, Reg _
-    | Vec128, _, Vec128, _ (* Vec128 stack slots are always aligned. *) ->
-      I.movapd (reg src) (reg dst)
-    | Float, _, Float, _ ->
-      I.movsd (reg src) (reg dst)
-    | Float32, _, Float32, _ ->
-      I.movss (reg src) (reg dst)
-    | (Int | Val | Addr), _, (Int | Val | Addr), _ ->
-      I.mov (reg src) (reg dst)
-    | (Float | Float32 | Vec128 | Int | Val | Addr), _, _, _ ->
-      Misc.fatal_errorf
-        "Illegal move between registers of differing types (%s:%a to %s:%a)\n"
-        (Reg.name src) Printcmm.machtype_component src.typ
-        (Reg.name dst) Printcmm.machtype_component dst.typ
-    end
+  let distinct = src.loc <> dst.loc in
+  begin match src.typ, src.loc, dst.typ, dst.loc with
+  | Float, Reg _, Float, Reg _
+  | Float32, Reg _, Float32, Reg _
+  | Vec128, _, Vec128, _ (* Vec128 stack slots are always aligned. *) ->
+    if distinct then I.movapd (reg src) (reg dst)
+  | Float, _, Float, _ ->
+    if distinct then I.movsd (reg src) (reg dst)
+  | Float32, _, Float32, _ ->
+    if distinct then I.movss (reg src) (reg dst)
+  | (Int | Val | Addr), _, (Int | Val | Addr), _ ->
+    if distinct then I.mov (reg src) (reg dst)
+  | (Float | Float32 | Vec128 | Int | Val | Addr), _, _, _ ->
+    Misc.fatal_errorf
+      "Illegal move between registers of differing types (%a to %a)\n"
+      Printmach.reg src Printmach.reg dst
+  end
 
 let stack_to_stack_move (src : Reg.t) (dst : Reg.t) =
   assert (src.typ = dst.typ);

backend/interf.ml

@@ -16,6 +16,17 @@
 (* Construction of the interference graph.
    Annotate pseudoregs with interference lists and preference lists. *)
 
+let check_collisions = false
+
+let assert_no_collisions set =
+  if check_collisions && (Reg.set_has_collisions set) then
+  Misc.fatal_error "live set has physical register collisions"
+
+let assert_compatible src dst =
+  if not (Reg.types_are_compatible src dst) then
+  Misc.fatal_errorf "found move between registers of incompatible types (%a to %a)"
+  Printmach.reg src Printmach.reg dst
+
 module IntPairSet =
   Hashtbl.Make(struct
     type t = int * int
@@ -79,11 +90,13 @@ let build_graph fundecl =
      do not add an interference between them if the source is still live
      afterwards. *)
   let add_interf_move src dst s =
+    assert_compatible src dst;
     Reg.Set.iter (fun r -> if r.stamp <> src.stamp then add_interf dst r) s in
 
   (* Compute interferences *)
 
   let rec interf i =
+    assert_no_collisions i.live;
     let destroyed = Proc.destroyed_at_oper i.desc in
     if Array.length destroyed > 0 then add_interf_set destroyed i.live;
     match i.desc with
@@ -126,6 +139,7 @@ let build_graph fundecl =
       float arguments in integer registers, PR#6227.) *)
 
   let add_pref weight r1 r2 =
+    assert_compatible r1 r2;
     let i = r1.stamp and j = r2.stamp in
     if i <> j
     && r1.loc = Unknown

backend/printmach.ml

@@ -39,17 +39,15 @@ let loc ?(wrap_out = fun ppf f -> f ppf) ~unknown ppf loc typ =
       wrap_out ppf (fun ppf -> fprintf ppf "ds[%i]" s)
 
 let reg ppf r =
-  if not (Reg.anonymous r) then
-    fprintf ppf "%s" (Reg.name r)
-  else
-    fprintf ppf "%s"
-      (match (r.typ : machtype_component) with
-      | Val -> "V"
-      | Addr -> "A"
-      | Int -> "I"
-      | Float -> "F"
-      | Vec128 -> "X"
-      | Float32 -> "S");
+  if not (Reg.anonymous r) then fprintf ppf "%s:" (Reg.name r);
+  fprintf ppf "%s"
+    (match (r.typ : machtype_component) with
+    | Val -> "V"
+    | Addr -> "A"
+    | Int -> "I"
+    | Float -> "F"
+    | Vec128 -> "X"
+    | Float32 -> "S");
   fprintf ppf "/%i" r.stamp;
   loc
     ~wrap_out:(fun ppf f -> fprintf ppf "[%t]" f)

backend/reg.ml

@@ -299,6 +299,15 @@ let set_of_array v =
            if i >= n then Set.empty else Set.add v.(i) (add_all(i+1))
          in add_all 0
 
+let set_has_collisions s =
+  let phys_regs = Hashtbl.create (Int.min (Set.cardinal s) 32) in
+  Set.fold (fun r acc ->
+    match r.loc with
+    | Reg id ->
+      if Hashtbl.mem phys_regs id then true
+      else (Hashtbl.add phys_regs id (); acc)
+    | Unknown | Stack _ -> acc) s false
+
 let equal_stack_location left right =
   match left, right with
   | Local left, Local right -> Int.equal left right
@@ -321,6 +330,11 @@ let equal_location left right =
   | Stack _, (Unknown | Reg _) ->
     false
 
+let same_phys_reg left right =
+  match left.loc, right.loc with
+  | Reg l, Reg r -> Int.equal l r
+  | (Reg _ | Unknown | Stack _), _ -> false
+
 let same_loc left right =
   (* CR-soon azewierzejew: This should also compare [reg_class] for [Stack
      (Local _)]. That's complicated because [reg_class] is definied in [Proc]
@@ -329,3 +343,15 @@ let same_loc left right =
 
 let same left right =
   Int.equal left.stamp right.stamp
+
+(* Two registers have compatible types if we allow moves between them.
+   Note that we never allow moves between different register classes, so this
+   condition must be at least as strict as [class left = class right]. *)
+let types_are_compatible left right =
+  match left.typ, right.typ with
+  | (Int | Val | Addr), (Int | Val | Addr)
+  | Float, Float
+  | Float32, Float32
+  | Vec128, Vec128 ->
+    true
+  | (Int | Val | Addr | Float | Float32 | Vec128), _ -> false

backend/reg.mli

@@ -113,6 +113,7 @@ val diff_set_array: Set.t -> t array -> Set.t
 val inter_set_array: Set.t -> t array -> Set.t
 val disjoint_set_array: Set.t -> t array -> bool
 val set_of_array: t array -> Set.t
+val set_has_collisions : Set.t -> bool
 
 val reset: unit -> unit
 val all_registers: unit -> t list
@@ -123,5 +124,7 @@ val mark_visited : t -> unit
 val is_visited : t -> bool
 val clear_visited_marks : unit -> unit
 
+val types_are_compatible : t -> t -> bool
+val same_phys_reg : t -> t -> bool
 val same_loc : t -> t -> bool
 val same : t -> t -> bool

backend/regalloc/regalloc_irc.ml

@@ -43,6 +43,8 @@ let build : State.t -> Cfg_with_infos.t -> unit =
       ~(move_src : Reg.t) ~(destroyed : Reg.t array) : unit =
     let destroyed = filter_fp destroyed in
     let live = Cfg_dataflow.Instr.Tbl.find liveness id in
+    if irc_debug && Reg.set_has_collisions live.across
+    then fatal "live set has physical register collisions";
     if Array.length def > 0
     then
       Reg.Set.iter
@@ -199,7 +201,13 @@ let coalesce : State.t -> unit =
     if irc_debug then log ~indent:2 "case #1/4";
     State.add_coalesced_moves state m;
     add_work_list state u)
-  else if State.is_precolored state v || State.mem_adj_set state u v
+  else if State.is_precolored state v
+          || (* We must not alias v->u if u uses the same register as a neighbor
+                of v. Simply checking whether u and v are adjacent is not
+                sufficient because the interference graph treats machine
+                registers aliased at multiple types (e.g. xmm0 at float32,
+                float, and vec128) as disjoint. *)
+          State.interferes_with_adj state v u
   then (
     if irc_debug then log ~indent:2 "case #2/4";
     State.add_constrained_moves state m;

backend/regalloc/regalloc_irc_state.ml

@@ -336,6 +336,10 @@ let[@inline] mem_adj_set state reg1 reg2 =
 
 let[@inline] adj_list _state reg = reg.Reg.interf
 
+let[@inline] interferes_with_adj state reg1 reg2 =
+  mem_adj_set state reg1 reg2
+  || List.exists reg1.Reg.interf ~f:(Reg.same_phys_reg reg2)
+
 let[@inline] add_edge state u v =
   let is_interesting_reg reg =
     match reg.Reg.loc with
@@ -466,11 +470,13 @@ let[@inline] rec find_alias state reg =
   else reg
 
 let[@inline] add_alias _state v u =
-  if not (same_reg_class v u)
+  (* We should never generate moves between registers of different types.
+     Bit-casting operations have specific instructions. *)
+  if not (Reg.types_are_compatible v u)
   then
     fatal
-      "trying to create an alias between %a and %a but they are in different \
-       classes"
+      "trying to create an alias between %a and %a but they have incompatible \
+       types"
       Printmach.reg v Printmach.reg u;
   v.Reg.irc_alias <- Some u
 

backend/regalloc/regalloc_irc_state.mli

@@ -96,6 +96,8 @@ val mem_adj_set : t -> Reg.t -> Reg.t -> bool
 
 val adj_list : t -> Reg.t -> Reg.t list
 
+val interferes_with_adj : t -> Reg.t -> Reg.t -> bool
+
 val adj_set : t -> RegisterStamp.PairSet.t
 
 val add_edge : t -> Reg.t -> Reg.t -> unit