was very wrong, fixing

5 files changed, 80 insertions, 20 deletions

diff --git a/aarch64/PostpassSchedulingOracle.ml b/aarch64/PostpassSchedulingOracle.ml
index 867341ca..6f784238 100644
--- a/aarch64/PostpassSchedulingOracle.ml
+++ b/aarch64/PostpassSchedulingOracle.ml
@@ -509,7 +509,7 @@ let build_problem bb =
     resource_bounds = opweights.pipelined_resource_bounds;
     live_regs_entry = Registers.Regset.empty; (* unused here *)
     typing = (fun x -> AST.Tint);                (* unused here *)
-    pressure_deltas = [| [| |] |] ;
+    reference_counting = None;
     instruction_usages = instruction_usages bb;
     latency_constraints = latency_constraints bb;
   }
diff --git a/aarch64/PrepassSchedulingOracle.ml b/aarch64/PrepassSchedulingOracle.ml
index 19f05749..fe757c99 100644
--- a/aarch64/PrepassSchedulingOracle.ml
+++ b/aarch64/PrepassSchedulingOracle.ml
@@ -202,6 +202,7 @@ let get_simple_dependencies (opweights : opweights) (seqa : (instruction*Regset.
   !latency_constraints;;
 
 
+(** useless  *)
 let get_pressure_deltas (seqa : (instruction * Regset.t) array)
   (typing : RTLtyping.regenv)
     : int array array =
@@ -454,13 +455,13 @@ let get_alias_dependencies seqa =
  *)
 
 let define_problem (opweights : opweights) (live_entry_regs : Regset.t)
-      (typing : RTLtyping.regenv) seqa =
+      (typing : RTLtyping.regenv) reference_counting 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;
-    pressure_deltas = get_pressure_deltas seqa typing;
+    reference_counting = Some reference_counting;
       instruction_usages = Array.map (resources_of_instruction opweights) (Array.map fst seqa);
     latency_constraints =
       (* if (use_alias_analysis ())
@@ -492,7 +493,8 @@ let prepass_scheduler_by_name name problem early_ones =
   
 let schedule_sequence (seqa : (instruction*Regset.t) array)
       (live_regs_entry : Registers.Regset.t)
-      (typing : RTLtyping.regenv) =
+      (typing : RTLtyping.regenv)
+      reference =
   let opweights = OpWeights.get_opweights () in
   try
     if (Array.length seqa) <= 1
@@ -502,7 +504,8 @@ 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 typing seqa in
+      let problem = define_problem opweights live_regs_entry
+                      typing reference seqa in
       (if !Clflags.option_debug_compcert > 7
        then (print_sequence stdout (Array.map fst seqa);
              print_problem stdout problem));
diff --git a/scheduling/InstructionScheduler.ml b/scheduling/InstructionScheduler.ml
index a069de59..08349f60 100644
--- a/scheduling/InstructionScheduler.ml
+++ b/scheduling/InstructionScheduler.ml
@@ -35,7 +35,8 @@ type problem = {
   resource_bounds : int array;
   live_regs_entry : Registers.Regset.t;
   typing : RTLtyping.regenv;
-  pressure_deltas : int array array;
+  reference_counting : ((Registers.reg, int * int) Hashtbl.t
+                       * (Registers.reg list array)) option;
   instruction_usages : int array array;
   latency_constraints : latency_constraint list;
   };;
@@ -370,7 +371,7 @@ let reg_pres_scheduler (problem : problem) : solution option =
     (Registers.Regset.elements live_regs_entry);
 
   
-  let pressures = problem.pressure_deltas in
+  let pressures = [| [| |] |] in
   
   let priorities = critical_paths successors in
   
@@ -629,7 +630,7 @@ let reverse_problem problem =
        with creating a reverse scheduler aware of reg press *)
     
     typing = problem.typing;
-    pressure_deltas = [| [| |] |] ;
+    reference_counting = problem.reference_counting;
     instruction_usages = Array.init (nr_instructions + 1)
       (fun i ->
         if i=0
diff --git a/scheduling/InstructionScheduler.mli b/scheduling/InstructionScheduler.mli
index e7f9e7db..9b6f7a3c 100644
--- a/scheduling/InstructionScheduler.mli
+++ b/scheduling/InstructionScheduler.mli
@@ -29,9 +29,9 @@ type problem = {
     typing : RTLtyping.regenv;
     (** Register type map. *)
     
-    pressure_deltas : int array array;
-    (** At index (i, j), the pressure delta for instruction i, for
-    register class j. *)
+    reference_counting : ((Registers.reg, int * int) Hashtbl.t
+                       * (Registers.reg 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] *)
diff --git a/scheduling/RTLpathScheduleraux.ml b/scheduling/RTLpathScheduleraux.ml
index e04e7c23..02e0c769 100644
--- a/scheduling/RTLpathScheduleraux.ml
+++ b/scheduling/RTLpathScheduleraux.ml
@@ -72,7 +72,60 @@ let get_superblocks code entry pm typing =
     lsb
 end
 
+(** the useful one. Returns a hashtable with bindings of form 
+ ** [(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 argument regset of each instruction *)
+let reference_counting (seqa : (instruction * Regset.t) array)
+      (out_regs : Registers.Regset.t) (typing : RTLtyping.regenv) :
+      (Registers.reg, int * int) Hashtbl.t * Registers.reg list array =
+  let retl = Hashtbl.create 42 in
+  let retr = Array.make (Array.length seqa) [] in
+  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
+  Array.iteri (fun i  (ins, _) ->
+      match ins with
+      | Iop(_,args,_,_) | Iload(_,_,_,args,_,_)
+      | Icond(_,args,_,_,_) ->
+         List.iter (add_reg) args;
+         retr.(i) <- args
+      | Istore(_,_,args,src,_) ->
+         List.iter (add_reg) args;
+         add_reg src;
+         retr.(i) <- src::args
+      | Icall(_,fn,args,_,_) | Itailcall(_,fn,args) ->
+         List.iter (add_reg) args;
+         retr.(i) <- (match fn with
+                     | Datatypes.Coq_inl reg ->
+                        add_reg reg;
+                        reg::args
+                     | _ -> args)
+      | Ibuiltin(_,args,_,_) ->
+         let rec bar = function
+           | AST.BA r -> add_reg r;
+                        retr.(i) <- r::retr.(i)
+           | AST.BA_splitlong  (hi, lo) | AST.BA_addptr (hi, lo) ->
+              bar hi; bar lo
+           | _ -> ()
+         in
+         List.iter (bar) args
+      | Ijumptable (reg,_) | Ireturn (Some reg) ->
+         add_reg reg;
+         retr.(i) <- [reg]
+      | _ -> ()
+    ) seqa;
+  retl, retr
 
+  
 let get_live_regs_entry (sb : superblock) code =
   (if !Clflags.option_debug_compcert > 6
    then debug_flag := true);
@@ -164,17 +217,20 @@ let schedule_superblock sb code =
          | 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)))
+            seqa
             live_regs_entry
-            sb.typing with
+            sb.typing
+            (reference_counting seqa sb.s_output_regs sb.typing) with
     | None -> sb.instructions
     | Some order ->
        let ins' =