Random heuristics for testing greedy regalloc (oxcaml#2276)

Author: TheNumbat

backend/regalloc/regalloc_gi.ml

@@ -68,6 +68,7 @@ let priority_heuristics : Reg.t -> Interval.t -> int =
  fun _reg itv ->
   match Lazy.force Priority_heuristics.value with
   | Priority_heuristics.Interval_length -> Interval.length itv
+  | Priority_heuristics.Random_for_testing -> Priority_heuristics.random ()
 
 let make_hardware_registers_and_prio_queue (cfg_with_infos : Cfg_with_infos.t) :
     Hardware_registers.t * prio_queue =
@@ -111,8 +112,8 @@ let max_rounds = 32
 (* CR xclerc for xclerc: the `round` parameter is temporary; this is an hybrid
    version of "greedy" using the `rewrite` function from IRC when it needs to
    spill. *)
-let rec main : round:int -> State.t -> Cfg_with_infos.t -> unit =
- fun ~round state cfg_with_infos ->
+let rec main : round:int -> flat:bool -> State.t -> Cfg_with_infos.t -> unit =
+ fun ~round ~flat state cfg_with_infos ->
   if round > max_rounds
   then
     fatal "register allocation was not succesful after %d rounds (%s)"
@@ -122,11 +123,6 @@ let rec main : round:int -> State.t -> Cfg_with_infos.t -> unit =
     log ~indent:0 "main, round #%d" round;
     log_cfg_with_infos ~indent:0 cfg_with_infos);
   if gi_debug then log ~indent:0 "updating spilling costs";
-  let flat =
-    match Lazy.force Spilling_heuristics.value with
-    | Flat_uses -> true
-    | Hierarchical_uses -> false
-  in
   update_spill_cost cfg_with_infos ~flat ();
   State.iter_introduced_temporaries state ~f:(fun (reg : Reg.t) ->
       reg.Reg.spill_cost <- reg.Reg.spill_cost + 10_000);
@@ -232,7 +228,7 @@ let rec main : round:int -> State.t -> Cfg_with_infos.t -> unit =
         ~spilled_nodes:(List.map spilled_nodes ~f:fst)
     with
     | false -> if gi_debug then log ~indent:1 "(end of main)"
-    | true -> main ~round:(succ round) state cfg_with_infos)
+    | true -> main ~round:(succ round) ~flat state cfg_with_infos)
 
 let run : Cfg_with_infos.t -> Cfg_with_infos.t =
  fun cfg_with_infos ->
@@ -261,7 +257,13 @@ let run : Cfg_with_infos.t -> Cfg_with_infos.t =
        work list and set the field to unknown. *)
     let (_ : bool) = rewrite state cfg_with_infos ~spilled_nodes in
     Cfg_with_infos.invalidate_liveness cfg_with_infos);
-  main ~round:1 state cfg_with_infos;
+  let flat =
+    match Lazy.force Spilling_heuristics.value with
+    | Flat_uses -> true
+    | Hierarchical_uses -> false
+    | Random_for_testing -> Spilling_heuristics.random ()
+  in
+  main ~round:1 ~flat state cfg_with_infos;
   if gi_debug then log_cfg_with_infos ~indent:1 cfg_with_infos;
   Regalloc_rewrite.postlude
     (module State)

backend/regalloc/regalloc_gi_utils.ml

@@ -5,6 +5,8 @@ module DLL = Flambda_backend_utils.Doubly_linked_list
 
 let gi_debug = true
 
+let gi_rng = Random.State.make [| 4; 6; 2 |]
+
 let bool_of_param param_name =
   bool_of_param ~guard:(gi_debug, "gi_debug") param_name
 
@@ -43,11 +45,17 @@ let log_cfg_with_infos : indent:int -> Cfg_with_infos.t -> unit =
 
 (* CR xclerc for xclerc: add more heuristics *)
 module Priority_heuristics = struct
-  type t = Interval_length
+  type t =
+    | Interval_length
+    | Random_for_testing
 
-  let all = [Interval_length]
+  let all = [Interval_length; Random_for_testing]
+
+  let to_string = function
+    | Interval_length -> "interval_length"
+    | Random_for_testing -> "random"
 
-  let to_string = function Interval_length -> "interval_length"
+  let random () = Random.State.int gi_rng 10_000
 
   let value =
     let available_heuristics () =
@@ -64,6 +72,7 @@ module Priority_heuristics = struct
       | Some id -> (
         match String.lowercase_ascii id with
         | "interval_length" | "interval-length" -> Interval_length
+        | "random" -> Random_for_testing
         | _ ->
           fatal "unknown heuristics %S (possible values: %s)" id
             (available_heuristics ())))
@@ -75,13 +84,24 @@ module Selection_heuristics = struct
     | First_available
     | Best_fit
     | Worst_fit
+    | Random_for_testing
 
-  let all = [First_available; Best_fit; Worst_fit]
+  let all = [First_available; Best_fit; Worst_fit; Random_for_testing]
 
   let to_string = function
     | First_available -> "first_available"
     | Best_fit -> "best_fit"
     | Worst_fit -> "worst_fit"
+    | Random_for_testing -> "random"
+
+  let include_in_random = function
+    | Random_for_testing | Worst_fit -> false
+    | First_available | Best_fit -> true
+
+  let random =
+    let all = List.filter all ~f:include_in_random in
+    let len = List.length all in
+    fun () -> List.nth all (Random.State.int gi_rng len)
 
   let value =
     let available_heuristics () =
@@ -100,6 +120,7 @@ module Selection_heuristics = struct
         | "first_available" | "first-available" -> First_available
         | "best_fit" | "best-fit" -> Best_fit
         | "worst_fit" | "worst-fit" -> Worst_fit
+        | "random" -> Random_for_testing
         | _ ->
           fatal "unknown heuristics %S (possible values: %s)" id
             (available_heuristics ())))
@@ -109,12 +130,16 @@ module Spilling_heuristics = struct
   type t =
     | Flat_uses
     | Hierarchical_uses
+    | Random_for_testing
 
-  let all = [Flat_uses; Hierarchical_uses]
+  let all = [Flat_uses; Hierarchical_uses; Random_for_testing]
 
   let to_string = function
     | Flat_uses -> "flat_uses"
     | Hierarchical_uses -> "hierarchical_uses"
+    | Random_for_testing -> "random"
+
+  let random () = Random.State.bool gi_rng
 
   let value =
     let available_heuristics () =
@@ -132,6 +157,7 @@ module Spilling_heuristics = struct
         match String.lowercase_ascii id with
         | "flat_uses" | "flat-uses" -> Flat_uses
         | "hierarchical_uses" | "hierarchical-uses" -> Hierarchical_uses
+        | "random" -> Random_for_testing
         | _ ->
           fatal "unknown heuristics %S (possible values: %s)" id
             (available_heuristics ())))
@@ -705,7 +731,14 @@ module Hardware_registers = struct
   let find_available : t -> Reg.t -> Interval.t -> available =
    fun t reg interval ->
     let with_no_overlap =
-      match Lazy.force Selection_heuristics.value with
+      let heuristic =
+        match Lazy.force Selection_heuristics.value with
+        | Selection_heuristics.Random_for_testing ->
+          Selection_heuristics.random ()
+        | heuristic -> heuristic
+      in
+      match heuristic with
+      | Selection_heuristics.Random_for_testing -> assert false
       | Selection_heuristics.First_available ->
         if gi_debug
         then

backend/regalloc/regalloc_gi_utils.mli

@@ -21,12 +21,16 @@ val log_body_and_terminator :
 val log_cfg_with_infos : indent:int -> Cfg_with_infos.t -> unit
 
 module Priority_heuristics : sig
-  type t = Interval_length
+  type t =
+    | Interval_length
+    | Random_for_testing
 
   val all : t list
 
   val to_string : t -> string
 
+  val random : unit -> int
+
   val value : t Lazy.t
 end
 
@@ -35,23 +39,29 @@ module Selection_heuristics : sig
     | First_available
     | Best_fit
     | Worst_fit
+    | Random_for_testing
 
   val all : t list
 
   val to_string : t -> string
 
+  val random : unit -> t
+
   val value : t Lazy.t
 end
 
 module Spilling_heuristics : sig
   type t =
     | Flat_uses
     | Hierarchical_uses
+    | Random_for_testing
 
   val all : t list
 
   val to_string : t -> string
 
+  val random : unit -> bool
+
   val value : t Lazy.t
 end