Initial import of l1c

[snipe.git] / codegen / colororder.sml

(* L1 Compiler
 * Gathers tiberium, fires rockets
 * Takes a interference graph and generates an ordering for coloring
 * Author: Joshua Wise <jwise@andrew.cmu.edu>
 *)

signature COLORORDER =
sig
  type tiberium = (Temp.temp * x86.oper list) list
  type rockets = Temp.temp list
  
  val colororder : tiberium -> rockets
end

structure ColorOrder :> COLORORDER =
struct
  structure T = Temp
  structure X = x86
  
  type tiberium = (Temp.temp * x86.oper list) list
  type rockets = Temp.temp list
  
  fun colororder (graph : tiberium) : rockets =
    let
      val () = print ("Ordering colors...\n");
      val initialWeights = map (fn (t, _) => (t, 0)) graph
      
      fun sortWeights weights =	(* Sort the weights such that the largest is at left, ready to be grabbed. *)
        ListMergeSort.sort (fn ((_, a), (_, b)) => a < b) weights
      
      (* Chooses one temporary to pick, and updates the weights. *)
      fun orderOne (weights : (Temp.temp * int) list) : Temp.temp * (Temp.temp * int) list =
        let
          val sorted = sortWeights weights
          val (chosen, w) = List.hd sorted	(* Grab the temp with the highest weight. *)
          val () = print ("  Chose "^(Temp.name chosen)^" with weight "^(Int.toString w)^"\n");
          val remaining = List.tl sorted
          val neighbors =	(* Grab all the neighbors for some given temp. *)
            List.hd
              (List.map (fn (_, neighbors) => neighbors)
                (List.filter (fn (t, _) => T.compare (t, chosen) = EQUAL) graph))
          val () = List.app
                     (fn (X.TEMP t) => (print ("    Neighbor "^(Temp.name t)^"\n"))
                       | (X.REG X.EAX) => (print "    Fixed color EAX\n")
                       | (X.REG X.EDX) => (print "    Fixed color EDX\n")
                       | _ => raise ErrorMsg.InternalError "Unknown neighbor type -- const?"
                     ) neighbors;
          val newWeights =
            List.map
              (fn (t, wt) =>
                (t,
                  if (List.exists 
                        (fn X.TEMP t' => (T.compare (t, t') = EQUAL)
                          | _ => false)
                        neighbors)
                    then (wt + 1)
                    else wt
                )
              ) remaining
        in
          (chosen, newWeights)
        end
      
      (* Recursively order until we run out of things to order. *)
      fun keepOrdering (nil : (Temp.temp * int) list) : Temp.temp list = nil
        | keepOrdering (weights) =
          let
            val (chosen, newWeights) = orderOne weights
          in
            chosen :: (keepOrdering newWeights)
          end
    in
      (keepOrdering initialWeights)
    end
end