Update coloring for Blarg.

[snipe.git] / codegen / colororder.sml

(* L3 Compiler
 * Takes a interference graph and generates an ordering for coloring
 * Author: Joshua Wise <jwise@andrew.cmu.edu>
 * Author: Chris Lu <czl@aundrew.cmu.edu>
 *)

signature COLORORDER =
sig
  structure OperSet : ORD_SET
    where type Key.ord_key = Blarg.oper
  structure LiveMap : ORD_MAP
    where type Key.ord_key = int
  structure TempMap : ORD_MAP
    where type Key.ord_key = Temp.temp

  type igraph = OperSet.set TempMap.map
  type ordering = Temp.temp list
  
  val colororder : Igraph.graph * Temp.temp list -> ordering
end

structure ColorOrder :> COLORORDER =
struct
  structure T = Temp
  structure X = Blarg
  
  structure OperSet = Igraph.OperSet
  structure LiveMap = Igraph.LiveMap
  structure TempMap = Igraph.TempMap
  
  type igraph = OperSet.set TempMap.map
  type ordering = Temp.temp list
  
  fun colororder (graph,temps) =
    let
      val initialWeights = TempMap.mapi (fn (t, _) => (t, 0)) graph
      
      (* Chooses one temporary to pick, and updates the weights. *)
      fun orderOne (weights : (Temp.temp * int) list) : Temp.temp * (Temp.temp * int) list =
        let
          val (chosen, w) =
            foldr
              (fn ((t1, w1), (t2, w2)) =>
                if (w2 > w1)
                then (t2, w2)
                else (t1, w1))
              (Temp.new "emarnus", ~9999)
              weights
              
          fun ditchOne f nil = nil	(* Special case of filter, which bails out after it removes one. *)
            | ditchOne f (h::l) =
              if f h
              then l
              else h::(ditchOne f l)
          val remaining = ditchOne (fn (t, w) => Temp.eq (t, chosen)) weights
          
          val neighbors =			(* Grab all the neighbors for some given temp. *)
            (OperSet.listItems
              (valOf (TempMap.find (graph, chosen))))
          val newWeights =
            List.map
              (fn (t, wt) =>
                (t,
                  if (List.exists 
                        (fn X.TEMP t' => (T.eq (t, t'))
                          | _ => 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

      val ordered = keepOrdering (TempMap.listItems initialWeights)
    in
      ordered @ (List.filter (fn a => not (List.exists (fn b => Temp.eq (a,b)) ordered)) temps)
    end
end