Another scheduler

3 files changed, 204 insertions, 1 deletions

diff --git a/driver/Driver.ml b/driver/Driver.ml
index fa187f26..4f43d7c9 100644
--- a/driver/Driver.ml
+++ b/driver/Driver.ml
@@ -210,7 +210,7 @@ Processing options:
   -mtune=         Type of CPU (for scheduling on some architectures)
   -fprepass      Perform prepass scheduling (only on some architectures) [on]
   -fprepass= <optim> Perform postpass scheduling with the specified optimization [list]
-                   (<optim>=list: list scheduling, <optim>=revlist: reverse list scheduling, <optim>=regpres: list scheduling aware of register pressure, <optim>=zigzag: zigzag scheduling, <optim>=ilp: ILP, <optim>=greedy: just packing bundles)
+                   (<optim>=list: list scheduling, <optim>=revlist: reverse list scheduling, <optim>=regpres: list scheduling aware of register pressure, <optim>=regpres_bis: variant of regpres, <optim>=zigzag: zigzag scheduling, <optim>=ilp: ILP, <optim>=greedy: just packing bundles)
   -regpres-threshold n   With `-fprepass= regpres`, set threshold value for number of free registers before trying to decrease register pressure
   -fpostpass     Perform postpass scheduling (only for K1 architecture) [on] 
   -fpostpass= <optim> Perform postpass scheduling with the specified optimization [list]
diff --git a/scheduling/InstructionScheduler.ml b/scheduling/InstructionScheduler.ml
index cd924825..99002c36 100644
--- a/scheduling/InstructionScheduler.ml
+++ b/scheduling/InstructionScheduler.ml
@@ -602,6 +602,206 @@ let reg_pres_scheduler (problem : problem) : solution option =
 ;;
 
 
+(********************************************************************)
+
+let reg_pres_scheduler_bis (problem : problem) : solution option =
+  DebugPrint.debug_flag := true;
+  Printf.printf "\nNEW\n\n";
+  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 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 a (r, b) =
+    a + (if b then
+           match Hashtbl.find_opt counts r with
+           | Some (_, 1) -> 1
+           | _ -> 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 compare_pres x y =
+    let pdy = List.fold_left (fold_delta) 0 mentions.(y) in
+    let pdx = List.fold_left (fold_delta) 0 mentions.(x) in
+    match pdy - pdx with
+    | 0 -> x - y
+    | z -> z
+  in
+  
+  let module InstrSet =
+    Set.Make (struct
+        type t = int
+        let compare x y =
+          match priorities.(y) - priorities.(x) with
+          | 0 -> x - y
+          | z -> z
+      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 () =
+    (* Printf.printf "ADV\n"; 
+     * flush stdout; *)
+    (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
+
+  
+  let attempt_scheduling ready usages =
+    let result = ref [] in
+    try
+      InstrSet.iter (fun i ->
+          if vector_less_equal usages.(i) current_resources
+          then
+            if !result = [] || priorities.(i) = priorities.(List.hd (!result))
+            then
+              result := i::(!result)
+            else raise Exit
+        ) ready;
+      if !result <> [] then raise Exit;
+      -1
+    with
+      Exit ->
+      let mini =  List.fold_left (fun a b ->
+                      if a = -1 || compare_pres a b > 0
+                      then b else a
+                    ) (-1) !result in
+      vector_subtract usages.(mini) current_resources;
+      mini
+  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 -> (
+        Printf.printf "ISSUED: %d\nREADY: " i;
+        InstrSet.iter (fun i -> Printf.printf "%d " i)
+          ready.(!current_time);
+        Printf.printf "\nSUCC: ";
+        List.iter (fun (i, l) -> Printf.printf "%d " i)
+          successors.(i);
+        Printf.printf "\n\n";
+        flush stdout;
+        assert(times.(i) < 0);
+        times.(i) <- !current_time;
+        ready.(!current_time)
+        <- InstrSet.remove i (ready.(!current_time));
+        (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
+                     (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 -> (Hashtbl.add live_regs r t;
+                        (* available_regs.(t)
+                         * <- available_regs.(t) - 1 *))
+               | Some i -> ()
+           ) mentions.(i));
+        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;;
 
@@ -1535,5 +1735,6 @@ let scheduler_by_name name =
   | "list" -> validated_scheduler list_scheduler
   | "revlist" -> validated_scheduler reverse_list_scheduler
   | "regpres" -> validated_scheduler reg_pres_scheduler
+  | "regpres_bis" -> validated_scheduler reg_pres_scheduler_bis
   | "greedy" -> greedy_scheduler
   | s -> failwith ("unknown scheduler: " ^ s);;
diff --git a/scheduling/InstructionScheduler.mli b/scheduling/InstructionScheduler.mli
index b5a5463b..48c7bc09 100644
--- a/scheduling/InstructionScheduler.mli
+++ b/scheduling/InstructionScheduler.mli
@@ -81,6 +81,8 @@ 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
+
+val reg_pres_scheduler_bis : problem -> solution option
   
 (** Schedule the problem using the order of instructions without any reordering *)
 val greedy_scheduler : problem -> solution option