Fix IRC and Greedy allocators (arm64)

.github/workflows/build.yml

@@ -78,6 +78,24 @@ jobs:
             config: --enable-middle-end=flambda2 --disable-warn-error
             os: macos-latest
 
+          - name: flambda2_macos_arm64_irc
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=irc'
+            ocamlparam: '_,w=-46,regalloc=irc'
+
+          - name: flambda2_macos_arm64_ls
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=ls'
+            ocamlparam: '_,w=-46,regalloc=ls'
+
+          - name: flambda2_macos_arm64_gi
+            config: --enable-middle-end=flambda2 --disable-warn-error
+            os: macos-latest
+            build_ocamlparam: '_,w=-46,regalloc=gi'
+            ocamlparam: '_,w=-46,regalloc=gi'
+
           - name: irc
             config: --enable-middle-end=flambda2
             os: ubuntu-latest

backend/regalloc/regalloc_gi.ml

@@ -83,13 +83,15 @@ let make_hardware_registers_and_prio_queue (cfg_with_infos : Cfg_with_infos.t) :
   Reg.Tbl.iter
     (fun reg interval ->
       match reg.loc with
-      | Reg _ ->
+      | Reg _ -> (
         if gi_debug
         then (
           log ~indent:1 "pre-assigned register %a" Printreg.reg reg;
           log ~indent:2 "%a" Interval.print interval);
-        let hardware_reg = Hardware_registers.of_reg hardware_registers reg in
-        Hardware_register.add_non_evictable hardware_reg reg interval
+        match Hardware_registers.of_reg hardware_registers reg with
+        | None -> ()
+        | Some hardware_reg ->
+          Hardware_register.add_non_evictable hardware_reg reg interval)
       | Unknown ->
         let priority = priority_heuristics reg interval in
         if gi_debug

backend/regalloc/regalloc_gi_utils.ml

@@ -596,14 +596,16 @@ module Hardware_registers = struct
               assigned = []
             }))
 
-  let of_reg (t : t) (reg : Reg.t) : Hardware_register.t =
+  let of_reg (t : t) (reg : Reg.t) : Hardware_register.t option =
     match reg.loc with
     | Reg reg_index ->
       let reg_class : int = Proc.register_class reg in
       let reg_index_in_class : int =
         reg_index - Proc.first_available_register.(reg_class)
       in
-      t.(reg_class).(reg_index_in_class)
+      if reg_index_in_class < Array.length t.(reg_class)
+      then Some t.(reg_class).(reg_index_in_class)
+      else None
     | Unknown -> fatal "`Unknown` location (expected `Reg _`)"
     | Stack _ -> fatal "`Stack _` location (expected `Reg _`)"
 

backend/regalloc/regalloc_gi_utils.mli

@@ -190,7 +190,7 @@ module Hardware_registers : sig
 
   val make : unit -> t
 
-  val of_reg : t -> Reg.t -> Hardware_register.t
+  val of_reg : t -> Reg.t -> Hardware_register.t option
 
   val find_available : t -> Reg.t -> Interval.t -> available
 end

backend/regalloc/regalloc_irc.ml

@@ -4,44 +4,40 @@ open! Regalloc_utils
 open! Regalloc_irc_utils
 module State = Regalloc_irc_state
 
-(* Remove the frame pointer from the passed array if present, returning the
-   passed array otherwise *)
-let filter_fp : Reg.t array -> Reg.t array =
+let filter_unavailable : Reg.t array -> Reg.t array =
  fun regs ->
-  let is_fp (reg : Reg.t) : bool =
+  let is_available (reg : Reg.t) : bool =
     match reg.loc with
-    | Unknown -> false
+    | Unknown -> true
     | Reg r ->
       let reg_class = Proc.register_class reg in
       r - Proc.first_available_register.(reg_class)
-      >= Proc.num_available_registers.(reg_class)
-    | Stack _ -> false
+      < Proc.num_available_registers.(reg_class)
+    | Stack _ -> true
   in
-  let len = Array.length regs in
-  let idx = ref 0 in
-  while !idx < len && not (is_fp regs.(!idx)) do
-    incr idx
-  done;
-  if !idx >= len
+  let num_available =
+    Array.fold_left regs ~init:0 ~f:(fun acc reg ->
+        if is_available reg then succ acc else acc)
+  in
+  if num_available = Array.length regs
   then regs
-  else if len = 1
-  then [||]
   else
-    let new_regs = Array.make (pred len) regs.(0) in
-    Array.blit ~src:regs ~src_pos:0 ~dst:new_regs ~dst_pos:0 ~len:!idx;
-    Array.blit ~src:regs ~src_pos:(succ !idx) ~dst:new_regs ~dst_pos:!idx
-      ~len:(len - !idx - 1);
-    new_regs
-
-let filter_fp regs = if Config.with_frame_pointers then filter_fp regs else regs
+    let res = Array.make num_available Reg.dummy in
+    let idx = ref 0 in
+    Array.iter regs ~f:(fun reg ->
+        if is_available reg
+        then (
+          res.(!idx) <- reg;
+          incr idx));
+    res
 
 let build : State.t -> Cfg_with_infos.t -> unit =
  fun state cfg_with_infos ->
   if irc_debug then log ~indent:1 "build";
   let liveness = Cfg_with_infos.liveness cfg_with_infos in
   let add_edges_live (id : Instruction.id) ~(def : Reg.t array)
       ~(move_src : Reg.t) ~(destroyed : Reg.t array) : unit =
-    let destroyed = filter_fp destroyed in
+    let destroyed = filter_unavailable 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";
@@ -91,8 +87,8 @@ let build : State.t -> Cfg_with_infos.t -> unit =
         let live = Cfg_dataflow.Instr.Tbl.find liveness first_id in
         Reg.Set.iter
           (fun reg1 ->
-            Array.iter (filter_fp Proc.destroyed_at_raise) ~f:(fun reg2 ->
-                State.add_edge state reg1 reg2))
+            Array.iter (filter_unavailable Proc.destroyed_at_raise)
+              ~f:(fun reg2 -> State.add_edge state reg1 reg2))
           (Reg.Set.remove Proc.loc_exn_bucket live.before))
 
 let make_work_list : State.t -> unit =