Compute spill costs.

Attempt coalescing between stack-allocated variables.


git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1331 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

1 files changed, 92 insertions, 8 deletions

diff --git a/backend/Coloringaux.ml b/backend/Coloringaux.ml
index 04cc1ee2..6d2ed82b 100644
--- a/backend/Coloringaux.ml
+++ b/backend/Coloringaux.ml
@@ -81,6 +81,18 @@ and movestate =
   | WorklistMoves
   | ActiveMoves
 
+(*i
+let name_of_node n =
+  match n.color with
+  | Some(R r) ->
+      begin match Machregsaux.name_of_register r with
+                | None -> "fixed-reg"
+                | Some s -> s
+      end
+  | Some(S _) -> "fixed-slot"
+  | None -> string_of_int n.ident
+*)
+
 (* The algorithm manipulates partitions of the nodes and of the moves
    according to their states, frequently moving a node or a move from
    a state to another, and frequently enumerating all nodes or all moves
@@ -266,6 +278,7 @@ let interfere n1 n2 =
 (* Add an edge to the graph.  Assume edge is not in graph already *)
 
 let addEdge n1 n2 =
+  (*i  Printf.printf "  %s -- %s;\n" (name_of_node n1) (name_of_node n2); *)
   assert (n1 != n2 && not (interfere n1 n2));
   let i1 = n1.ident and i2 = n2.ident in
   let p = if i1 < i2 then (i1, i2) else (i2, i1) in
@@ -350,7 +363,7 @@ let nodeOfReg r typenv spillcosts =
   let ty = typenv r in
   incr nextRegIdent;
   { ident = !nextRegIdent; typ = ty; regclass = class_of_type ty;
-    spillcost = (try float(Hashtbl.find spillcosts r) with Not_found -> 0.0);
+    spillcost = float(spillcosts r);
     adjlist = []; degree = 0; movelist = []; alias = None;
     color = None;
     nstate = Initial;
@@ -395,6 +408,7 @@ let build g typenv spillcosts =
     g.interf_reg_mreg ();
   (* Process the moves and insert them in worklistMoves *)
   let add_move n1 n2 =
+    (*i Printf.printf "  %s -- %s [color=\"red\"];\n" (name_of_node n1) (name_of_node n2); *)
     let m =
       { src = n1; dst = n2; mstate = WorklistMoves;
         mnext = DLinkMove.dummy; mprev = DLinkMove.dummy } in
@@ -503,6 +517,24 @@ let canConservativelyCoalesce u v =
   with Exit ->
     false
 
+(*i 
+(* Yet another coalescing criterion: all neighbors of a node are also
+   neighbors of the other node, therefore coalescing the two nodes
+   doesn't increase the number of neighbors.  This one is not
+   conservative because it can force both nodes to be spilled while
+   originally only one would be spilled.
+*)
+
+let allNeighbors u =
+  let seen = ref IntSet.empty in
+  iterAdjacent (fun n -> seen := IntSet.add n.ident !seen) u;
+  !seen
+
+let canCoalesceSubset u v =
+  let nu = allNeighbors u and nv = allNeighbors v in
+  IntSet.subset nu nv || IntSet.subset nv nu  
+*)
+
 (* The alternate criterion for precolored nodes *)
 
 let canCoalescePrecolored u v =
@@ -532,7 +564,7 @@ let rec getAlias n =
 (* Combine two nodes *)
 
 let combine u v =
-  (*i Printf.printf "Combining %s and %s\n" (name_of_node u) (name_of_node v); i*)
+  (*i Printf.printf "Combining %s and %s\n" (name_of_node u) (name_of_node v);*)
   if v.nstate = FreezeWorklist
   then DLinkNode.move v freezeWorklist coalescedNodes
   else DLinkNode.move v spillWorklist coalescedNodes;
@@ -551,6 +583,7 @@ let coalesce () =
   let m = DLinkMove.pick worklistMoves in
   let x = getAlias m.src and y = getAlias m.dst in
   let (u, v) = if y.nstate = Colored then (y, x) else (x, y) in
+  (*i Printf.printf "Attempt coalescing %s and %s\n" (name_of_node u) (name_of_node v);*)
   if u == v then begin
     DLinkMove.insert m coalescedMoves;
     addWorkList u
@@ -586,7 +619,7 @@ let freezeMoves u =
 
 let freeze () =
   let u = DLinkNode.pick freezeWorklist in
-  (*i Printf.printf "Freezing %s\n" (name_of_node u); i*)
+  (*i  Printf.printf "Freezing %s\n" (name_of_node u);*)
   DLinkNode.insert u simplifyWorklist;
   freezeMoves u
 
@@ -606,7 +639,7 @@ let selectSpill () =
       spillWorklist (DLinkNode.dummy, infinity) in
   assert (n != DLinkNode.dummy);
   DLinkNode.remove n spillWorklist;
-  (*i Printf.printf "Spilling %s\n" (name_of_node n); i*)
+  (*i Printf.printf "Spilling %s\n" (name_of_node n);*)
   freezeMoves n;
   n.nstate <- SelectStack;
   iterAdjacent decrementDegree n;
@@ -668,6 +701,25 @@ let find_reg conflicts regclass =
       | None ->
           find callee_save 0 (Array.length callee_save)
 
+(* Aggressive coalescing of stack slots.  When assigning a slot,
+   try first the slots assigned to the temporaries for which we
+   have a preference, provided no conflict occurs. *)
+
+let rec reuse_slot conflicts n mvlist =
+  match mvlist with
+  | [] -> None
+  | mv :: rem ->
+      let attempt_reuse n' =
+        match n'.color with
+        | Some(S _ as l) when not (Locset.mem l conflicts) -> Some l
+        | _ -> reuse_slot conflicts n rem in
+      let src = getAlias mv.src and dst = getAlias mv.dst in
+      if n == src then attempt_reuse dst
+      else if n == dst then attempt_reuse src
+      else reuse_slot conflicts n rem (* should not happen? *)
+
+(* If no reuse possible, assign lowest nonconflicting stack slot. *)
+
 let find_slot conflicts typ =
   let rec find curr =
     let l = S(Local(curr, typ)) in
@@ -686,7 +738,11 @@ let assign_color n =
   | Some loc ->
       n.color <- Some loc
   | None ->
-      n.color <- Some (find_slot !conflicts n.typ)
+      match reuse_slot !conflicts n n.movelist with
+      | Some loc ->
+          n.color <- Some loc
+      | None ->
+          n.color <- Some (find_slot !conflicts n.typ)
 
 (* Extract the location of a node *)
 
@@ -695,9 +751,35 @@ let location_of_node n =
   | None -> assert false
   | Some loc -> loc
 
-(* Estimate spilling costs - TODO *)
-
-let spill_costs f = Hashtbl.create 7
+(* Estimate spilling costs.  Currently, just count the number of accesses
+   to each pseudoregister.  To do: take loops into account. *)
+
+let spill_costs f =
+  let costs = ref (PTree.empty : int PTree.t) in
+  let cost r =
+    match PTree.get r !costs with None -> 0 | Some n -> n in
+  let incr r =
+    costs := PTree.set r (1 + cost r) !costs in
+  let incr_list rl =
+    List.iter incr rl in
+  let incr_ros ros =
+    match ros with Coq_inl r -> incr r | Coq_inr _ -> () in
+  let process_instr () pc i =
+    match i with
+    | Inop _ -> ()
+    | Iop(op, args, res, _) -> incr_list args; incr res
+    | Iload(chunk, addr, args, dst, _) -> incr_list args; incr dst
+    | Istore(chunk, addr, args, src, _) -> incr_list args; incr src
+    | Icall(sg, ros, args, res, _) -> incr_ros ros; incr_list args; incr res
+    | Itailcall(sg, ros, args) -> incr_ros ros; incr_list args
+    | Icond(cond, args, _, _) -> incr_list args
+    | Ijumptable(arg, _) -> incr arg
+    | Ireturn(Some r) -> incr r
+    | Ireturn None -> () in
+  incr_list f.fn_params;
+  PTree.fold process_instr f.fn_code ();
+  (* Result is cost function reg -> integer cost *)
+  cost
 
 (* This is the entry point for graph coloring. *)
 
@@ -706,7 +788,9 @@ let graph_coloring (f: coq_function) (g: graph) (env: regenv) (regs: Regset.t)
   init_regs();
   init_graph();
   Array.fill start_points 0 num_register_classes 0;
+  (*i Printf.printf "graph G {\n"; *)
   let mapping = build g env (spill_costs f) in
+  (*i Printf.printf "}\n"; *)
   List.iter assign_color (nodeOrder []);
   init_graph();  (* free data structures *)
   fun r ->