aboutsummaryrefslogtreecommitdiffstats
path: root/scheduling
diff options
context:
space:
mode:
Diffstat (limited to 'scheduling')
-rw-r--r--scheduling/InstructionScheduler.ml286
-rw-r--r--scheduling/InstructionScheduler.mli14
-rw-r--r--scheduling/RTLpathScheduleraux.ml187
3 files changed, 476 insertions, 11 deletions
diff --git a/scheduling/InstructionScheduler.ml b/scheduling/InstructionScheduler.ml
index eab0b21a..5b4c87f4 100644
--- a/scheduling/InstructionScheduler.ml
+++ b/scheduling/InstructionScheduler.ml
@@ -33,6 +33,10 @@ type latency_constraint = {
type problem = {
max_latency : int;
resource_bounds : int array;
+ live_regs_entry : Registers.Regset.t;
+ typing : RTLtyping.regenv;
+ reference_counting : ((Registers.reg, int * int) Hashtbl.t
+ * ((Registers.reg * bool) list array)) option;
instruction_usages : int array array;
latency_constraints : latency_constraint list;
};;
@@ -118,6 +122,13 @@ let vector_less_equal a b =
true
with Exit -> false;;
+(* let vector_add a b =
+ * assert ((Array.length a) = (Array.length b));
+ * for i=0 to (Array.length a)-1
+ * do
+ * b.(i) <- b.(i) + a.(i)
+ * done;; *)
+
let vector_subtract a b =
assert ((Array.length a) = (Array.length b));
for i=0 to (Array.length a)-1
@@ -257,8 +268,8 @@ let priority_list_scheduler (order : list_scheduler_order)
assert(!time >= 0);
!time
with Exit -> -1
-
in
+
let advance_time() =
begin
(if !current_time < max_time-1
@@ -267,7 +278,8 @@ let priority_list_scheduler (order : list_scheduler_order)
Array.blit problem.resource_bounds 0 current_resources 0
(Array.length current_resources);
ready.(!current_time + 1) <-
- InstrSet.union (ready.(!current_time)) (ready.(!current_time + 1));
+ InstrSet.union (ready.(!current_time))
+ (ready.(!current_time + 1));
ready.(!current_time) <- InstrSet.empty;
end);
incr current_time
@@ -334,6 +346,269 @@ let list_scheduler = priority_list_scheduler CRITICAL_PATH_ORDER;;
(* dummy code for placating ocaml's warnings *)
let _ = fun x -> priority_list_scheduler INSTRUCTION_ORDER x;;
+
+(* A scheduler sensitive to register pressure *)
+let reg_pres_scheduler (problem : problem) : solution option =
+ DebugPrint.debug_flag := true;
+ let nr_instructions = get_nr_instructions problem in
+ let successors = get_successors problem
+ and predecessors = get_predecessors problem
+ and times = Array.make (nr_instructions+1) (-1) in
+ let live_regs_entry = problem.live_regs_entry in
+
+ let available_regs = Array.copy Machregsaux.nr_regs in
+
+ let nr_types_regs = Array.length available_regs in
+
+ let thres = Array.fold_left (min)
+ (max !(Clflags.option_regpres_threshold) 0)
+ Machregsaux.nr_regs
+ in
+
+
+ let regs_thresholds = Array.make nr_types_regs thres in
+ (* placeholder value *)
+
+ let class_r r =
+ Machregsaux.class_of_type (problem.typing r) in
+
+ let live_regs = Hashtbl.create 42 in
+
+ List.iter (fun r -> let classe = Machregsaux.class_of_type
+ (problem.typing r) in
+ available_regs.(classe)
+ <- available_regs.(classe) - 1;
+ Hashtbl.add live_regs r classe)
+ (Registers.Regset.elements live_regs_entry);
+
+
+ let counts, mentions =
+ match problem.reference_counting with
+ | Some (l, r) -> l, r
+ | None -> assert false
+ in
+
+ let fold_delta i = (fun a (r, b) ->
+ a +
+ if class_r r <> i then 0 else
+ (if b then
+ if (Hashtbl.find counts r = (i, 1))
+ then 1 else 0
+ else
+ match Hashtbl.find_opt live_regs r with
+ | None -> -1
+ | Some t -> 0
+ )) in
+
+ let priorities = critical_paths successors in
+
+ let current_resources = Array.copy problem.resource_bounds in
+
+ let module InstrSet =
+ struct
+ module MSet =
+ Set.Make (struct
+ type t=int
+ let compare x y =
+ match priorities.(y) - priorities.(x) with
+ | 0 -> x - y
+ | z -> z
+ end)
+
+ let empty = MSet.empty
+ let is_empty = MSet.is_empty
+ let add = MSet.add
+ let remove = MSet.remove
+ let union = MSet.union
+ let iter = MSet.iter
+
+ let compare_regs i x y =
+ let pyi = List.fold_left (fold_delta i) 0 mentions.(y) in
+ (* print_int y;
+ * print_string " ";
+ * print_int pyi;
+ * print_newline ();
+ * flush stdout; *)
+ let pxi = List.fold_left (fold_delta i) 0 mentions.(x) in
+ match pyi - pxi with
+ | 0 -> (match priorities.(y) - priorities.(x) with
+ | 0 -> x - y
+ | z -> z)
+ | z -> z
+
+ (** t is the register class *)
+ let sched_CSR t ready usages =
+ (* print_string "looking for max delta";
+ * print_newline ();
+ * flush stdout; *)
+ let result = ref (-1) in
+ iter (fun i ->
+ if vector_less_equal usages.(i) current_resources
+ then if !result = -1 || (compare_regs t !result i > 0)
+ then result := i) ready;
+ !result
+ end
+ in
+
+ let max_time = bound_max_time problem + 5*nr_instructions in
+ let ready = Array.make max_time InstrSet.empty in
+
+ Array.iteri (fun i preds ->
+ if i < nr_instructions && preds = []
+ then ready.(0) <- InstrSet.add i ready.(0)) predecessors;
+
+ let current_time = ref 0
+ and earliest_time i =
+ try
+ let time = ref (-1) in
+ List.iter (fun (j, latency) ->
+ if times.(j) < 0
+ then raise Exit
+ else let t = times.(j) + latency in
+ if t > !time
+ then time := t) predecessors.(i);
+ assert (!time >= 0);
+ !time
+ with Exit -> -1
+ in
+
+ let advance_time () =
+ (if !current_time < max_time-1
+ then (
+ Array.blit problem.resource_bounds 0 current_resources 0
+ (Array.length current_resources);
+ ready.(!current_time + 1) <-
+ InstrSet.union (ready.(!current_time))
+ (ready.(!current_time +1));
+ ready.(!current_time) <- InstrSet.empty));
+ incr current_time
+ in
+
+ (* ALL MENTIONS TO cnt ARE PLACEHOLDERS *)
+ let cnt = ref 0 in
+
+ let attempt_scheduling ready usages =
+ let result = ref (-1) in
+ try
+ Array.iteri (fun i avlregs ->
+ (* print_string "avlregs: ";
+ * print_int i;
+ * print_string " ";
+ * print_int avlregs;
+ * print_newline ();
+ * print_string "live regs: ";
+ * print_int (Hashtbl.length live_regs);
+ * print_newline ();
+ * flush stdout; *)
+ if !cnt < 5 && avlregs <= regs_thresholds.(i)
+ then (
+ let maybe = InstrSet.sched_CSR i ready usages in
+ (* print_string "maybe\n";
+ * print_int maybe;
+ * print_newline ();
+ * flush stdout; *)
+ (if maybe > 0 &&
+ let delta =
+ List.fold_left (fold_delta i) 0 mentions.(maybe) in
+ (* print_string "delta ";
+ * print_int delta;
+ * print_newline ();
+ * flush stdout; *)
+ delta > 0
+ then
+ (vector_subtract usages.(maybe) current_resources;
+ result := maybe)
+ else incr cnt);
+ raise Exit)) available_regs;
+ InstrSet.iter (fun i ->
+ if vector_less_equal usages.(i) current_resources
+ then (
+ vector_subtract usages.(i) current_resources;
+ result := i;
+ raise Exit)) ready;
+ -1
+ with Exit ->
+ !result in
+
+ while !current_time < max_time
+ do
+ if (InstrSet.is_empty ready.(!current_time))
+ then advance_time ()
+ else
+ match attempt_scheduling ready.(!current_time)
+ problem.instruction_usages with
+ | -1 -> advance_time()
+ | i -> (assert(times.(i) < 0);
+ ((* print_string "INSTR ISSUED: ";
+ * print_int i;
+ * print_newline ();
+ * flush stdout; *)
+ cnt := 0;
+ List.iter (fun (r,b) ->
+ if b then
+ (match Hashtbl.find_opt counts r with
+ | None -> assert false
+ | Some (t, n) ->
+ Hashtbl.remove counts r;
+ if n = 1 then
+ ((* print_string "yaaaaaaaaaaaas ";
+ * print_int (Camlcoq.P.to_int r);
+ * print_newline (); *)
+ Hashtbl.remove live_regs r;
+ available_regs.(t)
+ <- available_regs.(t) + 1))
+ else
+ let t = class_r r in
+ match Hashtbl.find_opt live_regs r with
+ | None -> ((* print_string "noooooooooo ";
+ * print_int (Camlcoq.P.to_int r);
+ * print_newline (); *)
+ Hashtbl.add live_regs r t;
+ available_regs.(t)
+ <- available_regs.(t) - 1)
+ | Some i -> ()
+ ) mentions.(i));
+ times.(i) <- !current_time;
+ ready.(!current_time)
+ <- InstrSet.remove i (ready.(!current_time));
+ List.iter (fun (instr_to, latency) ->
+ if instr_to < nr_instructions then
+ match earliest_time instr_to with
+ | -1 -> ()
+ | to_time ->
+ ((* DebugPrint.debug "TO TIME %d : %d\n" to_time
+ * (Array.length ready); *)
+ ready.(to_time)
+ <- InstrSet.add instr_to ready.(to_time))
+ ) successors.(i);
+ successors.(i) <- []
+ )
+ done;
+
+ try
+ let final_time = ref (-1) in
+ for i = 0 to nr_instructions - 1 do
+ (* print_int i;
+ * flush stdout; *)
+ (if times.(i) < 0 then raise Exit);
+ (if !final_time < times.(i) + 1 then final_time := times.(i) + 1)
+ done;
+ List.iter (fun (i, latency) ->
+ let target_time = latency + times.(i) in
+ if target_time > !final_time then
+ final_time := target_time) predecessors.(nr_instructions);
+ times.(nr_instructions) <- !final_time;
+ DebugPrint.debug_flag := false;
+ Some times
+ with Exit ->
+ DebugPrint.debug "reg_pres_sched failed\n";
+ DebugPrint.debug_flag := false;
+ None
+
+;;
+
+
+
type bundle = int list;;
let rec extract_deps_to index = function
@@ -438,6 +713,12 @@ let reverse_problem problem =
{
max_latency = problem.max_latency;
resource_bounds = problem.resource_bounds;
+ live_regs_entry = Registers.Regset.empty; (* PLACEHOLDER *)
+ (* Not needed for the revlist sched, and for now we wont bother
+ with creating a reverse scheduler aware of reg press *)
+
+ typing = problem.typing;
+ reference_counting = problem.reference_counting;
instruction_usages = Array.init (nr_instructions + 1)
(fun i ->
if i=0
@@ -1259,5 +1540,6 @@ let scheduler_by_name name =
| "ilp" -> validated_scheduler cascaded_scheduler
| "list" -> validated_scheduler list_scheduler
| "revlist" -> validated_scheduler reverse_list_scheduler
+ | "regpres" -> validated_scheduler reg_pres_scheduler
| "greedy" -> greedy_scheduler
| s -> failwith ("unknown scheduler: " ^ s);;
diff --git a/scheduling/InstructionScheduler.mli b/scheduling/InstructionScheduler.mli
index fb7af3f6..b5a5463b 100644
--- a/scheduling/InstructionScheduler.mli
+++ b/scheduling/InstructionScheduler.mli
@@ -23,6 +23,16 @@ type problem = {
resource_bounds : int array;
(** An array of number of units available indexed by the kind of resources to be allocated. It can be empty, in which case the problem is scheduling without resource constraints. *)
+ live_regs_entry : Registers.Regset.t;
+ (** The set of live pseudo-registers at entry. *)
+
+ typing : RTLtyping.regenv;
+ (** Register type map. *)
+
+ reference_counting : ((Registers.reg, int * int) Hashtbl.t
+ * ((Registers.reg * bool) list array)) option;
+ (** See RTLpathScheduleraux.reference_counting. *)
+
instruction_usages: int array array;
(** At index {i i} the vector of resources used by instruction number {i i}. It must be the same length as [resource_bounds] *)
@@ -68,6 +78,10 @@ Once a clock tick is full go to the next.
@return [Some solution] when a solution is found, [None] if not. *)
val list_scheduler : problem -> solution option
+(** WIP : Same as list_scheduler, but schedules instructions which decrease
+register pressure when it gets too high. *)
+val reg_pres_scheduler : problem -> solution option
+
(** Schedule the problem using the order of instructions without any reordering *)
val greedy_scheduler : problem -> solution option
diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml
index aeed39df..f3f09954 100644
--- a/scheduling/RTLpathScheduleraux.ml
+++ b/scheduling/RTLpathScheduleraux.ml
@@ -17,7 +17,7 @@ let print_superblock (sb: superblock) code =
begin
debug "{ instructions = "; print_instructions (Array.to_list insts) code; debug "\n";
debug " liveins = "; print_ptree_regset li; debug "\n";
- debug " output_regs = "; print_regset outs; debug "}"
+ debug " output_regs = "; print_regset outs; debug "\n}"
end
let print_superblocks lsb code =
@@ -72,6 +72,168 @@ let get_superblocks code entry pm typing =
lsb
end
+(** the useful one. Returns a hashtable with bindings of shape
+ ** [(r,(t, n)], where [r] is a pseudo-register (Registers.reg),
+ ** [t] is its class (according to [typing]), and [n] the number of
+ ** times it's referenced as an argument in instructions of [seqa] ;
+ ** and an arrray containg the list of regs referenced by each
+ ** instruction, with a boolean to know whether it's as arg or dest *)
+let reference_counting (seqa : (instruction * Regset.t) array)
+ (out_regs : Registers.Regset.t) (typing : RTLtyping.regenv) :
+ (Registers.reg, int * int) Hashtbl.t *
+ (Registers.reg * bool) list array =
+ let retl = Hashtbl.create 42 in
+ let retr = Array.make (Array.length seqa) [] in
+ (* retr.(i) : (r, b) -> (r', b') -> ...
+ * where b = true if seen as arg, false if seen as dest
+ *)
+ List.iter (fun reg ->
+ Hashtbl.add retl
+ reg (Machregsaux.class_of_type (typing reg), 1)
+ ) (Registers.Regset.elements out_regs);
+ let add_reg reg =
+ match Hashtbl.find_opt retl reg with
+ | Some (t, n) -> Hashtbl.add retl reg (t, n+1)
+ | None -> Hashtbl.add retl reg (Machregsaux.class_of_type
+ (typing reg), 1)
+ in
+ let map_true = List.map (fun r -> r, true) in
+ Array.iteri (fun i (ins, _) ->
+ match ins with
+ | Iop(_,args,dest,_) | Iload(_,_,_,args,dest,_) ->
+ List.iter (add_reg) args;
+ retr.(i) <- (dest, false)::(map_true args)
+ | Icond(_,args,_,_,_) ->
+ List.iter (add_reg) args;
+ retr.(i) <- map_true args
+ | Istore(_,_,args,src,_) ->
+ List.iter (add_reg) args;
+ add_reg src;
+ retr.(i) <- (src, true)::(map_true args)
+ | Icall(_,fn,args,dest,_) ->
+ List.iter (add_reg) args;
+ retr.(i) <- (match fn with
+ | Datatypes.Coq_inl reg ->
+ add_reg reg;
+ (dest,false)::(reg, true)::(map_true args)
+ | _ -> (dest,false)::(map_true args))
+
+ | Itailcall(_,fn,args) ->
+ List.iter (add_reg) args;
+ retr.(i) <- (match fn with
+ | Datatypes.Coq_inl reg ->
+ add_reg reg;
+ (reg, true)::(map_true args)
+ | _ -> map_true args)
+ | Ibuiltin(_,args,dest,_) ->
+ let rec bar = function
+ | AST.BA r -> add_reg r;
+ retr.(i) <- (r, true)::retr.(i)
+ | AST.BA_splitlong (hi, lo) | AST.BA_addptr (hi, lo) ->
+ bar hi; bar lo
+ | _ -> ()
+ in
+ List.iter (bar) args;
+ let rec bad = function
+ | AST.BR r -> retr.(i) <- (r, false)::retr.(i)
+ | AST.BR_splitlong (hi, lo) ->
+ bad hi; bad lo
+ | _ -> ()
+ in
+ bad dest;
+ | Ijumptable (reg,_) | Ireturn (Some reg) ->
+ add_reg reg;
+ retr.(i) <- [reg, true]
+ | _ -> ()
+ ) seqa;
+ (* print_string "mentions\n";
+ * Array.iteri (fun i l ->
+ * print_int i;
+ * print_string ": [";
+ * List.iter (fun (r, b) ->
+ * print_int (Camlcoq.P.to_int r);
+ * print_string ":";
+ * print_string (if b then "a:" else "d");
+ * if b then print_int (snd (Hashtbl.find retl r));
+ * print_string ", "
+ * ) l;
+ * print_string "]\n";
+ * flush stdout;
+ * ) retr; *)
+ retl, retr
+
+
+let get_live_regs_entry (sb : superblock) code =
+ (if !Clflags.option_debug_compcert > 6
+ then debug_flag := true);
+ debug "getting live regs for superblock:\n";
+ print_superblock sb code;
+ debug "\n";
+ let seqa = Array.map (fun i ->
+ (match PTree.get i code with
+ | Some ii -> ii
+ | None -> failwith "RTLpathScheduleraux.get_live_regs_entry"
+ ),
+ (match PTree.get i sb.liveins with
+ | Some s -> s
+ | None -> Regset.empty))
+ sb.instructions in
+ let ret =
+ Array.fold_right (fun (ins, liveins) regset_i ->
+ let regset = Registers.Regset.union liveins regset_i in
+ match ins with
+ | Inop _ -> regset
+ | Iop (_, args, dest, _)
+ | Iload (_, _, _, args, dest, _) ->
+ List.fold_left (fun set reg -> Registers.Regset.add reg set)
+ (Registers.Regset.remove dest regset) args
+ | Istore (_, _, args, src, _) ->
+ List.fold_left (fun set reg -> Registers.Regset.add reg set)
+ (Registers.Regset.add src regset) args
+ | Icall (_, fn, args, dest, _) ->
+ List.fold_left (fun set reg -> Registers.Regset.add reg set)
+ ((match fn with
+ | Datatypes.Coq_inl reg -> (Registers.Regset.add reg)
+ | Datatypes.Coq_inr _ -> (fun x -> x))
+ (Registers.Regset.remove dest regset))
+ args
+ | Itailcall (_, fn, args) ->
+ List.fold_left (fun set reg -> Registers.Regset.add reg set)
+ (match fn with
+ | Datatypes.Coq_inl reg -> (Registers.Regset.add reg regset)
+ | Datatypes.Coq_inr _ -> regset)
+ args
+ | Ibuiltin (_, args, dest, _) ->
+ List.fold_left (fun set arg ->
+ let rec add reg set =
+ match reg with
+ | AST.BA r -> Registers.Regset.add r set
+ | AST.BA_splitlong (hi, lo)
+ | AST.BA_addptr (hi, lo) -> add hi (add lo set)
+ | _ -> set
+ in add arg set)
+ (let rec rem dest set =
+ match dest with
+ | AST.BR r -> Registers.Regset.remove r set
+ | AST.BR_splitlong (hi, lo) -> rem hi (rem lo set)
+ | _ -> set
+ in rem dest regset)
+ args
+ | Icond (_, args, _, _, _) ->
+ List.fold_left (fun set reg ->
+ Registers.Regset.add reg set)
+ regset args
+ | Ijumptable (reg, _)
+ | Ireturn (Some reg) ->
+ Registers.Regset.add reg regset
+ | _ -> regset
+ ) seqa sb.s_output_regs
+ in debug "live in regs: ";
+ print_regset ret;
+ debug "\n";
+ debug_flag := false;
+ ret
+
(* TODO David *)
let schedule_superblock sb code =
if not !Clflags.option_fprepass
@@ -90,15 +252,22 @@ let schedule_superblock sb code =
match predicted_successor ii with
| Some _ -> 0
| None -> 1 in
+ debug "hello\n";
+ let live_regs_entry = get_live_regs_entry sb code in
+ let seqa =
+ Array.map (fun i ->
+ (match PTree.get i code with
+ | Some ii -> ii
+ | None -> failwith "RTLpathScheduleraux.schedule_superblock"),
+ (match PTree.get i sb.liveins with
+ | Some s -> s
+ | None -> Regset.empty))
+ (Array.sub sb.instructions 0 (nr_instr-trailer_length)) in
match PrepassSchedulingOracle.schedule_sequence
- (Array.map (fun i ->
- (match PTree.get i code with
- | Some ii -> ii
- | None -> failwith "RTLpathScheduleraux.schedule_superblock"),
- (match PTree.get i sb.liveins with
- | Some s -> s
- | None -> Regset.empty))
- (Array.sub sb.instructions 0 (nr_instr-trailer_length))) with
+ seqa
+ live_regs_entry
+ sb.typing
+ (reference_counting seqa sb.s_output_regs sb.typing) with
| None -> sb.instructions
| Some order ->
let ins' =
generated by cgit (git 2.34.1) at 2024-07-07 01:28:21 +0000