Work on new schedluer

Renamed a test file, wrote function to compute pressure deltas,
Still need to pass the info in some way; beginning of the actual
scheduler function

4 files changed, 60 insertions, 4 deletions

diff --git a/aarch64/Machregsaux.ml b/aarch64/Machregsaux.ml
index 41db3bd4..15fb08ca 100644
--- a/aarch64/Machregsaux.ml
+++ b/aarch64/Machregsaux.ml
@@ -19,3 +19,7 @@ let class_of_type = function
   | AST.Tint | AST.Tlong -> 0
   | AST.Tfloat | AST.Tsingle -> 1
   | AST.Tany32 | AST.Tany64 -> assert false
+
+(* number of available registers per class *)
+(* TODO: add this to all archs *)
+let nr_regs = [| 29; 32 |]
diff --git a/aarch64/Machregsaux.mli b/aarch64/Machregsaux.mli
index 01b0f9fd..8487a557 100644
--- a/aarch64/Machregsaux.mli
+++ b/aarch64/Machregsaux.mli
@@ -15,3 +15,5 @@
 val is_scratch_register: string -> bool
 
 val class_of_type: AST.typ -> int
+
+val nr_regs : int array
diff --git a/aarch64/PostpassSchedulingOracle.ml b/aarch64/PostpassSchedulingOracle.ml
index a9737088..834d42f5 100644
--- a/aarch64/PostpassSchedulingOracle.ml
+++ b/aarch64/PostpassSchedulingOracle.ml
@@ -507,7 +507,8 @@ let build_problem bb =
   {
     max_latency = -1;
     resource_bounds = opweights.pipelined_resource_bounds;
-    live_regs_entry = Registers.Regset.empty; (* PLACEHOLDER *)
+    live_regs_entry = Registers.Regset.empty; (* unused here *)
+    typing = (fun x -> AST.Tint);                (* unused here *)
     instruction_usages = instruction_usages bb;
     latency_constraints = latency_constraints bb;
   }
diff --git a/aarch64/PrepassSchedulingOracle.ml b/aarch64/PrepassSchedulingOracle.ml
index a743fb68..6d445f10 100644
--- a/aarch64/PrepassSchedulingOracle.ml
+++ b/aarch64/PrepassSchedulingOracle.ml
@@ -201,6 +201,52 @@ let get_simple_dependencies (opweights : opweights) (seqa : (instruction*Regset.
     end seqa;
   !latency_constraints;;
 
+let get_pressure_deltas (seqa : (instruction * Regset.t) array)
+  (typing : RTLtyping.regenv)
+    : int array array =
+  let nr_types_regs = Array.length Machregsaux.nr_regs in
+  let ret = Array.init (Array.length seqa) (fun i ->
+                Array.make nr_types_regs 0) in
+  Array.iteri (fun i (instr, liveins) -> match instr with
+      | Iop (_, args, dest, _) | Iload (_, _, _, args, dest, _) ->
+         ret.(i).(Machregsaux.class_of_type (typing dest)) <-
+           if List.mem dest args then 0
+           else 1
+      | Istore (_, _, _, src, _) ->
+         ret.(i).(Machregsaux.class_of_type (typing src)) <-
+           -1
+      | Icall (_, fn, args, dest, _) ->
+         ret.(i).(Machregsaux.class_of_type (typing dest)) <-
+           if List.mem dest
+                (match fn with
+                 | Datatypes.Coq_inl reg -> reg::args
+                 | _ -> args)
+           then 0 else 1
+      | Ibuiltin (_, args, dest, _) ->
+         let rec arg_l list = function
+           | AST.BA r -> r::list
+           | AST.BA_splitlong (hi, lo) | AST.BA_addptr (hi, lo) ->
+              arg_l (arg_l list lo) hi
+           | _ -> list
+         in
+         let l = (List.fold_left arg_l [] args) in
+         let rec dest_l = function
+           | AST.BR r ->
+              let t = Machregsaux.class_of_type (typing r) in
+              ret.(i).(t) <-
+              (if List.mem r l
+              then 0 else 1) + ret.(i).(t)
+           | AST.BR_splitlong (hi, lo) ->
+              dest_l hi;
+              dest_l lo
+           | _ -> ()
+         in
+         dest_l dest
+      | _ -> ()
+    ) seqa;
+  ret
+  
+
 let resources_of_instruction (opweights : opweights) = function
   | Inop _ -> Array.map (fun _ -> 0) opweights.pipelined_resource_bounds
   | Iop(op, inputs, output, _) ->
@@ -406,11 +452,13 @@ let get_alias_dependencies seqa =
   !deps;;
  *)
 
-let define_problem (opweights : opweights) (live_entry_regs : Regset.t) seqa =
+let define_problem (opweights : opweights) (live_entry_regs : Regset.t)
+      (typing : RTLtyping.regenv) seqa =
   let simple_deps = get_simple_dependencies opweights seqa in
   { max_latency = -1;
     resource_bounds = opweights.pipelined_resource_bounds;
     live_regs_entry = live_entry_regs;
+    typing = typing;
     instruction_usages = Array.map (resources_of_instruction opweights) (Array.map fst seqa);
     latency_constraints =
       (* if (use_alias_analysis ())
@@ -441,7 +489,8 @@ let prepass_scheduler_by_name name problem early_ones =
   | _ -> scheduler_by_name name problem
   
 let schedule_sequence (seqa : (instruction*Regset.t) array)
-  (live_regs_entry : Registers.Regset.t)=
+      (live_regs_entry : Registers.Regset.t)
+      (typing : RTLtyping.regenv) =
   let opweights = OpWeights.get_opweights () in
   try
     if (Array.length seqa) <= 1
@@ -451,7 +500,7 @@ let schedule_sequence (seqa : (instruction*Regset.t) array)
       let nr_instructions = Array.length seqa in
       (if !Clflags.option_debug_compcert > 6
        then Printf.printf "prepass scheduling length = %d\n" (Array.length seqa));
-      let problem = define_problem opweights live_regs_entry seqa in
+      let problem = define_problem opweights live_regs_entry typing seqa in
       (if !Clflags.option_debug_compcert > 7
        then (print_sequence stdout (Array.map fst seqa);
              print_problem stdout problem));