(**********************************************************************)
(* (c) Greg Morrisett, Steve Zdancewic                                *)
(*     June 1998, all rights reserved.                                *)
(**********************************************************************)

(* regifg.ml
 *
 * The data structure for interference graphs.
 *)

open Utilities
open Identifier
open Set
open Tal
open Cfg

let debug = false
let debugdo s = if debug then 
  print_string (s^"\n")
else ()


type ident = identifier

type range_status =
    Initial            (* The initial set of un-processed live-ranges *)
  | Simplify           (* Those suitable for removal from the graph. These are *)
                       (* non-move-related nodes of degree < n *)
  | Freeze             (* Move-related nodes that eventually will either be *)
                       (* coalesced, spilled or given up on (i.e. simplified) *)
  | Splitable          (* Live-ranges that are not move-related, have high *)
                       (* degree, and are cross-call. *)
  | Spillable          (* Simple live-ranges that are candidates for spilling. *)
                       (* Non-move-related nodes of degree >= n *) 
  | Virtual            (* This live-range is not really in the graph.  It is *)
                       (* contained in a compound live-range *)
  | Machine            (* Only machine registers are assigned this status *)
  | Stack              (* On the stack, ready for coloring *)
  | Spilled            (* Live-ranges that are definitely spilled *)

type move_status =
    Active             (* Candidates for coalescing.  Connected lr's satisfy *)
                       (* either Briggs' or George's criteria *)
  | Inactive           (* Moves whose source and destination registers lie *)
                       (* within different atomic live-ranges of the same *)
                       (* compound live-range *)
  | Processed          (* Moves that have been coalesced or can't be coalesced *)
                       (* due to constraints.  Also those that were involved *)
                       (* with a split operation *)
  | Frozen             (* Moves that don't yet satisfy Briggs' or George's *)
                       (* criteria but may after some simplification steps. *)

(* The type of a move instruction: Mov dest src *)
type move = {dest: reg;            (* The destination register *)
	     src: reg;             (* The source register *)
	     block: identifier;    (* The code block containing the move *)
	     proc: identifier;     (* The function containing the move *)
	     index: int;           (* The index of the Mov in the vector *)
	     mutable status: move_status}

let compare_moves m1 m2 = 
  let c = id_compare m1.block m2.block in
  if c = 0 then m1.index - m2.index else c

type live_node =
  (* A simple, connected set of virtual registers including precolored regs. *)
  (* Pre-colored registers are given Simple nodes, but the register is *)
  (* implicit--not really in the set.  Instead, that info is stored in the pre *)
  (* field of the live range. *)
    Simple of reg set  
  (* A cross-call live-range is a single register that is live across a call *)
  (* edge. *)
  | CrossCall of reg 
  (* A compound live-range is a collection of atomic (simple or cross-call) *)
  (* live ranges, along with a set of moves that should be broken when the *)
  (* compound live-range is split.  *)
  | Compound of ident set

type live_range = {
    id: ident;  (* The indentifier for this live-range *)
    mutable parent: ident option;  (* Id of the compound node containing it *)
    mutable info: live_node;  (* The register information stored at this node *)
    mutable pre: ident option;(* The LR may contain a precolored reg *)
    mutable moves: move set;  (* The moves associated with this live-range *)
    mutable state: range_status;  (* The set where the live-range currently is *)
    (* The adjacency set. The adjacency list of a Virtual live-range may *)
    (* have either Actual or Virtual live-ranges in it.  The adjacency list *)
    (* of an Actual live-range is guaranteed to have only other Actuals in it. *)
    (* The degree of a node is the cardinality of its adj set. *)
    mutable adj: ident set;
    
    (* After the live-range has been spilled, we need to know exactly which *)
    (* registers it was adjacent to at the time of spillage, so keep this info *)
    mutable adj_regs: reg set option
  } 

(* There are two conceptual kinds of live-ranges: Those that are actually *)
(* participating in the interference graph, Actual live-ranges, and those *)
(* that are kept around because they may potentially need to be split, Virtual *)
(* live-ranges.  For the purposes of calculating interference and degree, etc. *)
(* it is important to use the Actual live-range of a given register.  The *)
(* virtual live-ranges are needed for splitting and coalescing. *)
    
let compare_live_ranges l1 l2 = id_compare l1.id l2.id

type if_graph = {
    (* The mapping from regs to the idents for the Atomic live-range that *)
    (* they're in. To get the actual live range, lookup the parent in lr.*)
    (* See the description of precolored registers below for the reason for *)
    (* the function ident argument *)
    mutable atomic: (reg, ident) Dict.dict;  
    mutable atomic_precolor: ((reg*ident), ident) Dict.dict;

    (* The interference matrix.  It includes both Actual and Virtual ranges *)
    mutable matrix: Bitmatrix.bit_matrix;

    (* The map from identifiers to live-ranges (both Actual and Virtual) *)
    mutable lr: (ident, live_range) Dict.dict;  
    
    n: int;                  (* The number of available colors *)
    (* The set of machine register live-range id's *)
    mutable precolored: ident set;
    (* Map from precolored id's to physical registers *)
    mutable physical: (ident, reg) Dict.dict;
    
    (* The following are mutually disjoint sets of live-ranges. *)
    mutable initial: ident set;    (* Before initialization takes place *)
    mutable simplify: ident set;   (* Low-degree, suitable for simplification *)
    mutable freeze: ident set;     (* Move-related, for spilling or coalescing *)
    mutable splitable: ident set;  (* High-degree, cross-call, possible split *)
    mutable spillable: ident set;  (* High-degree, possible spills *)
    mutable virt: ident set;       (* Virtual live-ranges *)
    mutable stack: ident list;     (* The stack of removed live-ranges *)
    mutable simple_spills: ident list; (* Real spills, after coloring *)
    mutable cc_spills: ident list; (* Real spills cross call *)

    (* The following are sets of move instructions *)
    mutable active: move set;     (* Moves that are considered for coalescing *)
    mutable inactive: move set;   (* Moves that are between two virtual lr's *)
    mutable processed: move set;  (* Moves that have already been processed *)
    mutable frozen: move set  (* Moves the may be considered for coalescing *)
  } 

(* About precolored (machine) registers: *)
(* Since we are doing interprocedural register allocation, we need to be able *)
(* to distinguish between two uses of the same physical register by two *)
(* distinct procedures, otherwise the coalescing phase of the allocation would *)
(* join two simple live-ranges from different procedures if they share a *)
(* physical register, which breaks the invariant that simple live-ranges are *)
(* contained in a single function.  To do this, we introduce a new "copy" of *)
(* each physical register for each function in the program. *)
(* To avoid the extra overhead of storing the interference edges between these *)
(* multiple copies of the physical registers, which would require *)
(* 64*(#procs)^2 edges in the interference graph, we do not store edges *)
(* between physical registers in the graph.  We do, however, store edges *)
(* between physical and virtual registers. To maintain this information, *)
(* we need to keep a map from reg * function ident -> lr ident. *)
(* For coalescing purposes, physical registers are compatible iff they *)
(* represent (potentially different instantiations of) the same register. *)


(* Some useful constants and functions*)

(* The set of machine registers *)
let machine = Set.from_list compare_regs
    [Eax; Ebx; Ecx; Edx; Esi; Edi; Ebp; Esp]
let ereg = Set.empty compare_regs   (* Empty register set *)
let eid = Set.empty id_compare (* Empty ident set *)
let emove = Set.empty compare_moves (* Empty move set *)
let sid = Set.singleton id_compare  (* Singleton ident set creator *)
let sreg = Set.singleton compare_regs (* Singleton reg set creator *)

let id_equal id1 id2 = (id_compare id1 id2) = 0

let cc_lr_to_reg lr =
  match lr.info with
    CrossCall r -> r
  | _ -> failwith "ifg.ml: cc_lr_to_reg called on invalid lr"

(* Converts physical registers to strings, fails on virtual registers.  Not *)
(* really needed, it's simply used to give the idents for physical registers *)
(* more meaningful names when debugging.  Calls to this function can safely be *)
(* eliminated (and replaced by "" for instance). *)
let reg_to_str r =
  match r with
    Eax -> "Eax"
  | Ebx -> "Ebx"
  | Ecx -> "Ecx"
  | Edx -> "Edx"
  | Esi -> "Esi"
  | Edi -> "Edi"
  | Ebp -> "Ebp"
  | Esp -> "Esp"
  | Virt id -> id_to_string id

(* Takes an ifg, register and function identifier and returns the identifier *)
(* for the atomic live-range containing that register. Fails if the register *)
(* is not found in the atomic set. *)
let regid ifg r f =                       
  match r with
    Virt id -> 
      (try
      	Dict.lookup ifg.atomic r
      with Dict.Absent -> failwith ("regid: "^(Identifier.id_to_string id)))
  | _ -> (try 
      Dict.lookup ifg.atomic_precolor (r, f)
  with Dict.Absent -> failwith ("regid: "^(reg_to_str r)))
      	
(* Takes an ifg, register, and function identifier and returns the identifier *)
(* for the atomic live-range containing it.  If there is no such identifier, *)
(* generate a new one. Adds the ident to ifg.precolored if it's a machine *)
(* register. *)
let new_regid ifg r f =
  try
    regid ifg r f
  with Failure _ -> 
    match r with 
      Virt _ -> begin 
	let id = id_new "Atom" in
      	ifg.atomic <- Dict.insert ifg.atomic r id;
      	id
      end
    | _ -> let id = id_new (reg_to_str r) in begin
	ifg.precolored <- insert ifg.precolored id;
	ifg.physical <- Dict.insert ifg.physical id r;
	ifg.atomic_precolor <- Dict.insert ifg.atomic_precolor (r,f) id;
	id
    end

let precol ifg = member ifg.precolored

let phys_to_int r =
  match r with
    Eax -> 0
  | Ebx -> 1
  | Ecx -> 2
  | Edx -> 3
  | Esi -> 4
  | Edi -> 5
  | Ebp -> 6
  | Esp -> 7
  | _ -> failwith "ifg.ml: phys_to_int: virtual register"

(* Converts a given precolored register id to an integer *)
let reg_to_int ifg id =
  try let r = Dict.lookup ifg.physical id in
  phys_to_int r
  with Dict.Absent ->
    failwith "ifg.ml: reg_to_int: id not found"

(* Converts a given integer to a machine register *)
let int_to_reg i = 
  match i with
    0 -> Eax
  | 1 -> Ebx
  | 2 -> Ecx
  | 3 -> Edx
  | 4 -> Esi
  | 5 -> Edi
  | 6 -> Ebp
  | 7 -> Esp
  | _ -> failwith "ifg.ml: int_to_reg not a valid integer"

(* Given an integer n, returns the set {0, 1, 2, ..., n-1} *)
let rec n_set n =
  match n with
    0 -> Set.empty compare
  | n -> Set.insert (n_set (n-1)) (n-1)

(* Determines whether a given live-range is actual. It is virtual *)
(* iff it has a parent, actual otherwise. *)
let actual lr =
  match lr.parent with
    Some _ -> false
  | None -> true

(* Returns the Actual or Virtual live-range for the given identifier. *)
let get_lr ifg id = try
  Dict.lookup ifg.lr id
with Dict.Absent -> failwith ("get_lr: " ^ (id_to_string id))

(* Returns the actual live-range corresponding to the given ident. *)
let get_parent ifg lr =
  match lr.parent with
    Some id' -> get_lr ifg id'  (* It was virtual, return parent. *)
  | None -> lr  (* It was actual, return this one *)

let get_actual_lr ifg id =
  get_parent ifg (get_lr ifg id)

(* Returns the ident of the actual live-range corresponding to a given ident. *)
let get_actual_id ifg id = 
  let lr = get_lr ifg id in
  match lr.parent with
    Some id' -> id'  (* It was virtual, return parent. *)
  | None -> id       (* It was already actual. *)

(* Given a register and function returns the true if the live-range containing *)
(* that register is a cross-call spill. *)
let reg_cc_spilled ifg r f = 
  let id = get_actual_id ifg (regid ifg r f) in
  List.mem id ifg.cc_spills

(* Returns the degree of the live-range lr *)
let degree lr = 
  cardinality lr.adj

(* Adds a move instruction to a given live-range's set of moves. *)
let add_move ifg lr mv =
  lr.moves <- insert lr.moves mv

(* A live-range is move-related iff it participates in a register-register *)
(* move that is either active or frozen. *)
let move_related ifg lr =
  not (is_empty (intersect lr.moves (union ifg.active ifg.frozen)))

(* Returns true if there is an interference edge between two live-ranges, *)
(* false otherwise. *)
let adjacent ifg lr1 lr2 = 
  (* Check to see if both lr's are precolored *)
  match (lr1.pre, lr2.pre) with
    (* If so, check to see if they represent different registers *)
    (Some id1, Some id2) -> not ((reg_to_int ifg id1) = ( reg_to_int ifg id2))
    (* Otherwise check the bitmatrix *)
  | _ -> Bitmatrix.get ifg.matrix lr1.id lr2.id

(* Adds id2 to the set of adjacent live-ranges for lr1. If both are precolored *)
(* then don't bother *)
let insert_adjset ifg lr1 id2 =
  let id1 = lr1.id in
  if (precol ifg id1)&(precol ifg id2) then ()
  else lr1.adj <- Set.insert lr1.adj id2
    
(* Adds a single edge between two given live-ranges.*)
let add_edge ifg lr1 lr2 =
  let id1 = lr1.id in
  let id2 = lr2.id in
  (* Don't add the edge if the live-ranges are equal or both precolored *)
  if (not (id_equal id1 id2)) & (not((precol ifg id1)&(precol ifg id2))) then
    begin
      Bitmatrix.set ifg.matrix id1 id2;  (* Add the edge to the bitmatrix *)
      Bitmatrix.set ifg.matrix id2 id1;
      insert_adjset ifg lr1 id2;        (* Add the nodes to the adjacency sets *)
      insert_adjset ifg lr2 id1;
    end
  else ()	

let add_edge_id ifg lr1 id =
  add_edge ifg lr1 (get_lr ifg id)

(* Removes id2 from the set of adjacent live-ranges for lr1. *)
let delete_adjset ifg lr1 id2 =
  let id1 = lr1.id in
  if (precol ifg id1)&(precol ifg id2) then ()
  else lr1.adj <- Set.delete lr1.adj id2
  
(* Deletes an edge between two given live-ranges. Is a no-op if they aren't *)
(* already adjacent. *)
let delete_edge ifg lr1 lr2 =
  let id1 = lr1.id in
  let id2 = lr2.id in
  if (not (id_equal id1 id2)) & (not((precol ifg id1)&(precol ifg id2)))&
     (adjacent ifg lr1 lr2) then
    begin
      Bitmatrix.clear ifg.matrix id1 id2;  (* Put a zero in the bitmatrix *)
      Bitmatrix.clear ifg.matrix id2 id1;
      delete_adjset ifg lr1 id2;
      delete_adjset ifg lr2 id1;
    end

let delete_edge_id ifg lr1 id =
  delete_edge ifg lr1 (get_lr ifg id)

let compare_reg_id (r1, id1) (r2, id2) =
  let c = compare_regs r1 r2 in
  if c = 0 then id_compare id1 id2 else c

let empty_ifg n = {
  atomic = Dict.empty compare_regs;
  atomic_precolor = Dict.empty compare_reg_id;
  matrix = Bitmatrix.create ();
  lr = Dict.empty id_compare;
  n = n;
  precolored = eid;
  physical = Dict.empty id_compare;
  initial = eid;
  simplify = eid;
  freeze = eid;
  splitable = eid;
  spillable = eid;
  virt = eid;
  stack = [];
  simple_spills = [];
  cc_spills = [];
  active = emove;
  inactive = emove;
  processed = emove;
  frozen = emove
} 

(* Builds an interference graph from a control-flow graph and the number of *)
(* colors to use.  Each virtual register is represented by a single live-range.*)
(* Assumes that liveness analysis has been performed on the control flow graph.*)
(* Puts all live-ranges into the initial set and all register to register *)
(* moves into the active set. *)
let build cfg n = 
  let ifg = empty_ifg n in 
  let add_nodes b =
    (* Calculate the set of registers live across Call or Return edges. *)
    (* There's no need to make machine registers cross call, since in order *)
    (* for the code to typecheck, the caller and callee must agree on which *)
    (* physical register is being used.  Thus we don't include machine regs *)
    (* in the cross call set. *)
    let find_cc_regs e s =
      match e with
	(_, CallEdge, l) -> union s (Cfg.get_args cfg l)
      |	(_, Return, _) -> union s (Cfg.get_rets cfg b.fun_lab)
      |	_ -> s
    in
    let cross_call = Set.diff (Set.fold find_cc_regs b.succ ereg) machine in
    (* Adds a new live-range to the ifg *)
    let add_lr r = 
      let id = new_regid ifg r b.fun_lab in
      if (member ifg.initial id) then 
	() (* It's already a node in the graph *)
      else (* we need to make a new live-range *)
	let lr = 
	  {id = id;
	   parent = None;
	   (* Only non-machine registers will be made cross-call *)
	   info = if member cross_call r then CrossCall (r) else Simple (sreg r);
	   moves = Set.empty compare_moves;
	   pre = if precol ifg id then Some id else None;
	   state = Initial;
	   adj = eid;
	   adj_regs = None;
	 }
	in begin
	  ifg.lr <- Dict.insert ifg.lr id lr;
	  ifg.initial <- insert ifg.initial id
	end
    in 
    begin
      Array.iter (fun i -> let (def,use) = Cfginstr.def_use i in 
      begin
	(* Add the live-ranges for each of the defined registers and each used *)
	(* machine register.  If the instruction is Setcc then add live-ranges *)
	(* for Esi, Edi, and Ebp. *)
	Set.app add_lr (union def (intersect use machine));
	(match i with
	  Setcc (_, _) -> Set.app add_lr 
	      (Set.from_list compare_regs [Esi;Edi;Ebp])
	| _ -> ());
      end
      ) b.code;
      (* Also have to add a live-range for each register live-in to the block *)
      Set.app add_lr b.live_in;
    end      
  in
  let add_edges b =
    (* Process a single instruction given the live_out set of registers *)
    let build_instr i (live_out, n) =
      let (def, use) = Cfginstr.def_use i in
      let live_in = diff live_out def in
      let (use',def') = 
	if Cfginstr.is_move i then 
	  let mv = {dest=(choose def); 
		    src=(choose use);
		    block=b.lab;
		    proc=b.fun_lab;
		    index=n;
		    status=Active} in 
	  begin
	    ifg.active <- insert ifg.active mv;
	    Set.app (fun r -> add_move ifg 
		(get_lr ifg (regid ifg r b.fun_lab)) mv) 
	      (union def use);
	    (* Check to see whether the destination register of the MOV is live *)
	    (* if not then remove the source register from the live-in set. *)
(*	    if not (member live_out mv.dest) && not (member live_out mv.src) then 
	      	(delete use mv.src, delete def mv.dest) *)
(*	    else if (member live_out mv.dest) && (member live_out mv.src) then
  (use, delete def mv.dest) *)
	  (*  else (use, def) *)
	    (use, def)
	  end
	else (use, def)
      in begin
	(* Add the interference edges *)
	Set.app (fun r1 -> Set.app 
	    (fun r2 -> begin
	      add_edge ifg (get_lr ifg (regid ifg r1 b.fun_lab))
		(get_lr ifg (regid ifg r2 b.fun_lab));
	      end
		)  live_in) def; (* (intersect def' live_out); *)
	(* CHANGED: def to (intersect def live_out) to prune dead registers *)

	(* The registers Esi, Edi and Ebp can't be used in an r8 position *)
	(* So add edges between them and the registers defined by such instrs. *)
	(match i with
	  Setcc (_, _) -> begin
	    Set.app (fun r -> List.iter 
	      	(fun physical -> 
	    	  add_edge ifg (get_lr ifg (regid ifg r b.fun_lab))
		    (get_lr ifg (new_regid ifg physical b.fun_lab)))
	      	[Esi; Edi; Ebp]) def
	  end
	| _ -> ());
	(union live_in use', n-1)
      end
    in begin
      vector_fold_rev build_instr b.code (b.live_out, Array.length b.code-1);
      ()
    end
  in
  begin
    Cfg.app add_nodes cfg;   (* Add the live-range nodes to the ifg *)
    Cfg.app add_edges cfg;   (* Add the interference edges *)
    debugdo "ifg.ml: finished build";
    ifg
  end


(* Just a bunch of utility functions for printing regalloc dumps *)
let form = Format.std_formatter 
let opt = {Talpp.style=Talpp.MASM; Talpp.kinds=false; Talpp.cons=false} 
let space () = Format.pp_print_string form " " 
let ps = Format.pp_print_string form 
let pi = Format.pp_print_int form 
let nl = Format.pp_force_newline form 
let preg = Talpp.print_reg form opt 
let ppflush = Format.pp_print_flush form 

let print_regmap d = begin
  Dict.app_dict (fun r1 r2 -> begin preg r1; ps " => "; preg r2; nl(); end) d;
  ppflush ();
end

let p_idset1 =Set.app (fun id -> begin ps (id_to_string id); space ()end)
  
(* flag1 = dump set info *)
(* flag2 = dump matrix *)
(* flag3 = include precolored & virtual in matrix dump, regsets *)
(* flag4 = print lr info *)
(* flag5 = dump adjacencies *)
let print_ifg ifg flag1 flag2 flag3 flag4 flag5 =
  let pm mv = begin ps "MOV "; preg mv.dest; space(); preg mv.src end in
  let p_id id = 
    let lr = get_lr ifg id in
    begin
      ps (id_to_string id); space ();
      if actual lr then ps "A " else ps "V ";
      (match lr.info with
	Simple rset -> begin ps "S( "; Set.app (fun r -> (preg r; space())) rset;
	  ps ")"; end
      |	CrossCall r -> begin ps "CC( "; preg r; ps " )"; end
      |	Compound(ids) -> begin ps "Cmp( "; p_idset1 ids; ps " )"; end);
      (match lr.pre with
	None -> ()
      |	Some id -> begin ps " PRE: "; preg (Dict.lookup ifg.physical id); end);
      nl();
    end
  in
  let p_idset2 = Set.app p_id in
  let p_stack = List.iter p_id in
  let p_moveset = Set.app (fun mv -> begin pm mv; nl()end) in
  let p_idset = if flag4 then p_idset2 else p_idset1 in
  let dump_sets () =
    begin
      ps "=================SETS================="; nl();
      ps "Initial:"; nl ();
      p_idset ifg.initial; nl ();
      ps "Simplify:"; nl ();
      p_idset ifg.simplify; nl ();
      ps "Freeze:"; nl ();
      p_idset ifg.freeze; nl ();
      ps "Splitable:"; nl ();
      p_idset ifg.splitable; nl ();
      if flag3 then begin 
	ps "Virtual:"; nl ();
      	p_idset ifg.virt; nl ();
      end;
      ps "Spillable:"; nl ();
      p_idset ifg.spillable; nl ();
      ps "Stack:"; nl ();
      p_stack ifg.stack; nl ();
      ps "-----------------------"; nl ();
      ps "Active:"; nl ();
      p_moveset ifg.active; nl ();
      ps "Inactive:"; nl ();
      p_moveset ifg.inactive; nl ();
      ps "Frozen:"; nl ();
      p_moveset ifg.frozen; nl ();
      ps "Processed:"; nl ();
      p_moveset ifg.processed; nl ();
    end
  in 
  let dump_matrix () =
    (* Get the ids of every live-range in the map *)
    let ids = Dict.fold_dict (fun id _ s -> Set.insert s id ) ifg.lr eid in
    begin
      ps "================MATRIX================"; nl();
      space();space();space();space();
      Set.app (fun id -> begin ps (id_to_string id); space () end) ids;
      nl (); ps "deg ";
      Set.app (fun id -> begin space();pi (degree (get_lr ifg id));space();
	space() end)
	ids;
      nl ();
      Set.app (fun id1 -> begin ps (id_to_string id1); space ();
	Set.app (fun id2 -> if (Bitmatrix.get ifg.matrix id1 id2) then 
	  ps " 1  " 
	else
	  ps " 0  ") ids;
	nl ();
	end) ids;
      nl ();
    end
  in
  let dump_adj () = 
    let ids = Dict.fold_dict (fun id _ s -> Set.insert s id ) ifg.lr eid in
    begin
      ps "=================ADJS================="; nl();
      Set.app (fun id -> begin ps (id_to_string id); ps " == "; p_idset1
	  (get_lr ifg id).adj; nl (); end) ids;
      nl ();
  end
  in begin
    if flag1 then dump_sets () else ();
    if flag2 then dump_matrix () else ();
    if flag5 then dump_adj () else ();
    Format.pp_print_flush form ();
  end

(* Deletes a live-range from its current set *)
let delete_lr_from_set ifg lr =
  match lr.state with
    Initial -> ifg.initial <- delete ifg.initial lr.id
  | Simplify -> ifg.simplify <- delete ifg.simplify lr.id
  | Freeze -> ifg.freeze <- delete ifg.freeze lr.id
  | Splitable -> ifg.splitable <- delete ifg.splitable lr.id
  | Spillable -> ifg.spillable <- delete ifg.spillable lr.id
  | Virtual -> ifg.virt <- delete ifg.virt lr.id
  | Machine -> () (* failwith "ifg.ml: delete_from set impossible" *)
  | Stack -> () (*failwith "ifg.ml: delete_lr_from_set Stack shouldn't happen" *)
  | Spilled -> failwith "ifg.ml: delete_lr_from_set Spilled shouldn't happen"

(* Moves a live-range from one set to another *)
let change_lr_state ifg lr state =
  if lr.state = state then () else
  begin
    (* delete it from it's current set *)
    delete_lr_from_set ifg lr;
    (* add it to the new one *)
    lr.state <- state;
    match state with
      Initial -> ifg.initial <- insert ifg.initial lr.id
    | Simplify -> ifg.simplify <- insert ifg.simplify lr.id
    | Freeze -> ifg.freeze <- insert ifg.freeze lr.id
    | Splitable -> ifg.splitable <- insert ifg.splitable lr.id
    | Spillable -> ifg.spillable <- insert ifg.spillable lr.id
    | Virtual -> ifg.virt <- insert ifg.virt lr.id
    | Machine -> () (*failwith"ifg.ml: change_lr_state invalid state (Machine)"*)
    | Stack -> ifg.stack <- lr.id :: ifg.stack
    | Spilled -> (match lr.info with
	Simple _ -> ifg.simple_spills <- lr.id :: ifg.simple_spills
      |	CrossCall _ -> ifg.cc_spills <- lr.id :: ifg.cc_spills
      |	_ -> failwith "ifg.ml: change_lr_state tried to spill Compound lr") 
  end
  
(* Deletes a move from its current set *)
let delete_mv_from_set ifg mv =
  match mv.status with
    Active -> ifg.active <- delete ifg.active mv
  | Inactive -> ifg.inactive <- delete ifg.inactive mv
  | Processed -> ifg.processed <- delete ifg.processed mv
  | Frozen -> ifg.frozen <- delete ifg.frozen mv

(* Moves a move instruction from one set to another *)
let change_mv_status ifg mv status =
  if mv.status = status then () else
  begin
    (* delete it from its current set *)
    delete_mv_from_set ifg mv;
    (* Add it to the new set *)
    mv.status <- status;
    match status with
      Active -> ifg.active <- insert ifg.active mv
    | Inactive -> ifg.inactive <- insert ifg.inactive mv
    | Processed -> ifg.processed <- insert ifg.processed mv
    | Frozen -> ifg.frozen <- insert ifg.frozen mv
  end

(* Returns true if the given live-range is compound, i.e. splitable *)
let compound lr =
  match lr.info with
    Simple _ -> false    
  | CrossCall _ -> false
  | Compound _ -> true

(* Given an id for a live-range, categorizes the live-range into the proper *)
(* working set. Always sort_moves before sorting nodes since a live-range *)
(* may not be move-related after sorting moves. *)
let sort_node ifg id = begin
(*  print_string "sort_begin"; print_newline (); *)
  let lr = get_actual_lr ifg id in
  match lr.state with
    (Stack | Spilled | Machine) -> ()  (* This node won't move *)
  | (Initial | Simplify | Freeze | Splitable | Spillable) ->
      if precol ifg lr.id then
	change_lr_state ifg lr Machine
      else if move_related ifg lr then
	(* Any move-related live-range is in the Freeze set *)
	change_lr_state ifg lr Freeze
      else if degree lr < ifg.n then
	(* It's a candidate for simplification *)
	change_lr_state ifg lr Simplify
      else if compound lr then
	(* It's a splitable node *)
	change_lr_state ifg lr Splitable
      else (* Otherwise it's a spill candidate *)
      	change_lr_state ifg lr Spillable
  | Virtual -> failwith "ifg.ml: sort_node called on virtual live-range"
end

(* Given an id for a live-range, categorizes the live-range into the proper *)
(* working set for coalescing spill slots. Always spill_sort_moves before *)
(* sorting nodes since a live-range may not be move-related after sorting *)
(* moves. *)
let spill_sort_node ifg id = begin
(*  print_string "spill_sort_node"; print_newline (); *)
  let lr = get_actual_lr ifg id in
  match lr.state with
    Stack -> () (* This node won't move *)
  | (Splitable | Spillable | Spilled | Machine) ->
      failwith "ifg.ml: spill_sort_node called on invalid live-range"
  | (Initial | Simplify | Freeze) ->
      if precol ifg lr.id then
	failwith "ifg.ml: spill_sort_node called on precolored live-range"
      else if move_related ifg lr then
	(* Any move-related live-range is in the Freeze set *)
	change_lr_state ifg lr Freeze
      else (* Otherwise it's a simplify candidate *)
      	change_lr_state ifg lr Simplify
  | Virtual -> failwith "ifg.ml: sort_node called on virtual live-range"
end

let same_precolor ifg lr1 lr2 = 
  match (lr1.pre, lr2.pre) with
    (Some id1, Some id2) -> (reg_to_int ifg id1) = (reg_to_int ifg id2)
  | _ -> true

(* Pre-colored register color-compatibility check:  live-range A can't         *)
(* be coalesced with live-range B if A is precolored and B is adjacent to the  *)
(* another live-range with the same color as A.  (And symmetrically...)        *)
let compatible ifg lr1 lr2 = 
  let color_conflict = ref false in
  let check_nbr lr id =
    let lr' = get_actual_lr ifg id in
    if (same_precolor ifg lr lr') then color_conflict := true else ()
  in begin
    Set.app (check_nbr lr1) lr2.adj;
    Set.app (check_nbr lr2) lr1.adj;
    (not !color_conflict) & (same_precolor ifg lr1 lr2)
  end

(* Brigg's coalescing criterion: live-ranges A and B can be coalesced if the   *)
(* resulting node AB will have fewer than n neighbors of significant (>= n)    *)
(* degree.                                                                     *)
let briggs ifg lr1 lr2 =
  let k = ref 0 in
  let check_nbr id = 
    let lr' = get_actual_lr ifg id in
    if (degree lr') > ifg.n then incr k else ();
  in begin 
    Set.app check_nbr lr2.adj;
    Set.app check_nbr lr1.adj;
    (!k < ifg.n)
  end

(* George's coalescing criterion: live-ranges A and B can be coalaseced if *)
(* for every neighbor T of A, either T already interferes with B or T is of *)
(* insignificant degree (< n).  Note that this uses the adjacency list of *)
(* only the first argument. *)
let george ifg lr1 lr2 =
  let check_nbr id b = 
    let lr = get_actual_lr ifg id in
    ((adjacent ifg lr lr2) || ((degree lr) < ifg.n)) & b
  in
  Set.fold check_nbr lr1.adj true

(* Returns true if two live-ranges can be coalesced according to the Briggs *)
(* and George heuristics.  If both live-ranges are pre-colored they must be *)
(* compatible.  If one of them is a machine register, we use the George test *)
(* since it requires only one adjacency list.  If neither is a machine reg, we *)
(* use both Briggs' and George's heuristics. *)
let conservative ifg lr1 lr2 = begin
(*  print_string "conservative"; print_newline (); *)
(*  match (precol ifg lr1.id, precol ifg lr2.id) with
    (true, true) -> (reg_to_int ifg lr1.id) = (reg_to_int ifg lr2.id)
  | (false, true) -> george ifg lr1 lr2 
  | (true, false) -> george ifg lr2 lr1 
  | (false, false) -> (* They aren't machine registers, so use both tests *)*)
  (compatible ifg lr1 lr2) & ((briggs ifg lr1 lr2) || (george ifg lr1 lr2))
end

(* Given a move instruction, categorizes it depending on whether it meets the *)
(* conservative heuristics for coalescing. *)
let sort_move ifg mv = begin
(*  print_string "sort_move"; print_newline (); *)
  let lr1 = get_lr ifg (regid ifg mv.dest mv.proc) in
  let lr2 = get_lr ifg (regid ifg mv.src mv.proc) in
  match mv.status with
    Processed -> ()  (* Once processed, a move is no longer used *)
  | (Active | Frozen | Inactive) ->
      if (adjacent ifg lr1 lr2) || (id_equal lr1.id lr2.id) then
	(* This move can never be coalesced, or already has been *)
	change_mv_status ifg mv Processed
      else if (not (actual lr1 || actual lr2)) & (lr1.parent = lr2.parent) then 
	(* This move connects two virtual lr's in the same compound lr *)
	change_mv_status ifg mv Inactive
      else if conservative ifg (get_parent ifg lr1) (get_parent ifg lr2) then
	(* This passes the coalescable heuristics *)
	change_mv_status ifg mv Active
      else
	change_mv_status ifg mv Frozen
end

(* Given a move instruction, determines whether it can be used for coalescing *)
(* spill slots and puts it in the appropriate set. *)
let spill_sort_move ifg mv = begin
  let lr1 = get_lr ifg (regid ifg mv.dest mv.proc) in
  let lr2 = get_lr ifg (regid ifg mv.src mv.proc) in
  match mv.status with
    Processed -> ()  (* Once processed, a move is no longer used *)
  | Frozen -> failwith "ifg.ml: spill_sort_move shouldn't get frozen moves"
  | (Active | Inactive) ->
      if (adjacent ifg lr1 lr2) || (id_equal lr1.id lr2.id) then
	(* This move can never be coalesced, or already has been *)
	change_mv_status ifg mv Processed
      else if (not (actual lr1 || actual lr2)) & (lr1.parent = lr2.parent) then 
	(* This move connects two virtual lr's in the same compound lr *)
	change_mv_status ifg mv Inactive
      else (* We always coalesce moves if possible to avoid extra copying *)
	change_mv_status ifg mv Active
end
  
exception NoSpills

let spill_regs ifg lrs =
  let rec lr_to_regs id s =
    let lr = get_lr ifg id in
    match lr.info with
      Simple regs -> Set.union s regs
    | CrossCall r -> Set.insert s r
    | Compound ids -> Set.fold (fun id' s -> lr_to_regs id' s) ids s
  in
  Set.fold lr_to_regs lrs ereg

let spill_ifg ifg regs =
  let sp_ifg = {atomic=ifg.atomic;
		atomic_precolor=ifg.atomic_precolor;
		matrix=Bitmatrix.create ();
		lr=ifg.lr;
		n=0;
		precolored=ifg.precolored;
		physical=ifg.physical;
		initial=eid;
		simplify=eid;
		freeze=eid;
		splitable=eid;
		spillable=eid;
		virt=ifg.virt;
		stack=[];
		simple_spills=[];
		cc_spills=[];
		active=Set.empty compare_moves;
		inactive=Set.empty compare_moves;
		processed=Set.empty compare_moves;
		frozen=Set.empty compare_moves}
  in
  let f = id_new "spill_ifg: BOGUS" in
  let lrs = Set.fold (fun r s -> insert s (get_actual_id sp_ifg 
					     (regid sp_ifg r f)))
      (diff regs machine) eid 
  in 
  let spills = Set.intersect 
      (Set.union (Set.from_list id_compare ifg.simple_spills)
	 (Set.from_list id_compare ifg.cc_spills))
      lrs in
  let add_if_spilled ifg' id =
    if Set.member spills id then
      let lr = get_actual_lr ifg' id in begin
(*      print_string ("HERE: inserting "^(Identifier.id_to_string id)); *)
(*      print_newline(); *)
      	lr.state <- Initial;
      	ifg'.initial <- (insert ifg'.initial id);
      	Set.app (fun id -> add_edge ifg' lr (get_actual_lr ifg' id)) lr.adj;
      	Set.app (fun mv -> 
	  let id1 = get_actual_id ifg' (regid ifg' mv.dest mv.proc) in
	  let id2 = get_actual_id ifg' (regid ifg' mv.src mv.proc) in
	  match (member spills id1, member spills id2) with
	    (true, true) -> change_mv_status ifg' mv Active
          | _ -> change_mv_status ifg' mv Processed) lr.moves;
      end
    else ()
  in
  if Set.is_empty spills then
    raise NoSpills
  else   begin
    List.iter (add_if_spilled sp_ifg) (List.rev ifg.simple_spills);
    Set.app (spill_sort_move sp_ifg) sp_ifg.active;
    Set.app (spill_sort_node sp_ifg) sp_ifg.initial;
    (sp_ifg, spill_regs ifg spills)
  end
      
(* Takes an already built interference graph and initializes the appropriate *)
(* sets of live-ranges and move instructions *)
let initialize_sets ifg =
  begin
    Set.app (sort_move ifg) ifg.active;
    Set.app (sort_node ifg) ifg.initial;
  end
    
(* The following aid in controlling the register allocation loop. *)
let simplifiable ifg =
  not (is_empty ifg.simplify)

let coalescable ifg =
  not (is_empty ifg.active)

let freezable ifg =
  not (is_empty ifg.freeze)

let splitable ifg =
  not (is_empty ifg.splitable)

let spillable ifg =
  not (is_empty ifg.spillable)

let actual_spills ifg =
  match (ifg.simple_spills, ifg.cc_spills) with
    ([],[]) -> false
  | _ -> true

(* Returns a set containing the registers that are neighbors of a lr *)
(* It walks over each compound neighbor and throws its children into the set *)
let primitive_nbrs ifg lr1 =
  let collect id s =
    let lr2 = get_actual_lr ifg id in
    match lr2.info with
     Simple regs -> if member lr2.adj lr1.id then union s regs else s
    | CrossCall r -> if member lr2.adj lr1.id then insert s r else s
    | Compound s' -> Set.fold (fun id set -> let child = get_lr ifg id in
                                 if member child.adj lr1.id then 
				   match child.info with
				     Simple regs -> union set regs
				   | CrossCall r -> insert set r
				   | _ -> failwith "ifg.ml: primitive_nbrs"
				 else set) s' s
  in
  Set.fold collect lr1.adj ereg

(* Removes a live-range from the graph, pushing it onto the colorable stack. *)
(* Maintain the invariant that once a live-range has been simplified, its *)
(* adjaceny set contains the identifiers for all registers it was adjacent to *)
(* at the time of the spill. *)
let simplify ifg =
  (* Pick a node in the graph *)
  let id = choose ifg.simplify in
  let lr = get_actual_lr ifg id in
  let nbrs = lr.adj in
  (* deletes id1 from all adj sets of live-range id2 both virtual and actual *)
  let delete_deep id1 id2 =
    let lr2 = get_lr ifg id2 in begin
      delete_adjset ifg lr2 id1;
      match lr2.info with
	(Simple _ | CrossCall _) -> ()
      |	Compound s -> Set.app (fun id -> delete_adjset ifg (get_lr ifg id) id1) s
    end
  in
  begin
    debugdo ("##simplify: " ^ (id_to_string id));
    (* Move it from the simplify list to the stack *)
    change_lr_state ifg lr Stack;
    (* Change the adjacency set of this node to include all REGISTERS that *)
    (* are adjacent to it, in case a compound neighbor gets split in the *)
    (* future. *)
    lr.adj_regs <- Some (primitive_nbrs ifg lr);
    (* Remove this live-range from its nbrs' adjacency sets *)
    Set.app (delete_deep lr.id) nbrs;
    (* Re-sort the neighbors of this node into the proper sets *)
    Set.app (sort_node ifg) nbrs;
  end

(* Removes a live-range from the graph, pushing it onto the colorable stack. *)
let simplify_spills ifg =
  (* Pick a node in the graph *)
  let id = choose ifg.simplify in
  let lr = get_actual_lr ifg id in
  let nbrs = lr.adj in
  begin
    debugdo ("##simplify_spills: "^(id_to_string id));
    (* Move it from the simplify list to the stack *)
    change_lr_state ifg lr Stack;
    lr.adj_regs <- Some (primitive_nbrs ifg lr);
    (* Remove this live-range from its nbrs' adjacency sets *)
    Set.app (delete_edge_id ifg lr) nbrs;
    (* We don't have to re-sort neighbors because there can be no changes *)
  end

let merge_pre ifg pre1 pre2 =
  match (pre1, pre2) with
    (None, None) -> None
  | (Some id, None) -> Some id
  | (None, Some id) -> Some id
  | (Some id1, Some id2) -> 
      if (reg_to_int ifg id1) = (reg_to_int ifg id2) then Some id1 
      else failwith "ifg.ml: merge_pre"

let change_atomic ifg id r f = 
  match r with 
    Virt _ ->
      begin
    	ifg.atomic <- Dict.delete ifg.atomic r;
    	ifg.atomic <- Dict.insert ifg.atomic r id;
      end
  | _ ->
      begin
    	ifg.atomic_precolor <- Dict.delete ifg.atomic_precolor (r,f);
    	ifg.atomic_precolor <- Dict.insert ifg.atomic_precolor (r,f) id;
      end


let coalesce_ss ifg mv lr1 lr2 s1 s2 sm sn =
  let nbrs = lr2.adj in
  begin 
    debugdo ("##coalesce_ss: " ^ (id_to_string lr1.id) ^ " " ^ 
		  (id_to_string lr2.id));
    (* We union the two nodes, putting the result into node lr1 *)
    lr1.info <- Simple (union s1 s2);
    lr1.pre <- merge_pre ifg lr1.pre lr2.pre;
    lr1.moves <- union lr1.moves lr2.moves;
    (* Then we delete all the edges associated with lr2 *)
    Set.app (delete_edge_id ifg lr2) nbrs;
    (* And add them to the edges associated with lr1 *)
    Set.app (add_edge_id ifg lr1) nbrs;
    (* We change the mapping for the registers contained in lr2 *)
    Set.app (fun r -> change_atomic ifg lr1.id r mv.block) s2;
    (* Delete lr2 from the the set of nodes *)
    delete_lr_from_set ifg lr2;
    (* Change the move to be processed *)
    change_mv_status ifg mv Processed;
    (* Re-sort the moves for this node and re-sort the neighbors *)
    Set.app (sm ifg) lr1.moves;
    Set.app (sn ifg) lr1.adj;
    sn ifg lr1.id;
  end

let coalesce_create_lr ifg mv lr1 lr2 regs =
  begin
    debugdo ("##coalesce_create_lr: " ^ (id_to_string lr1.id) ^ " " ^ 
		  (id_to_string lr2.id));
    (* We need to create a compound node containing the two live-ranges *)
    let newlr = {id = id_new "Comp";
		 parent = None;
		 info = Compound (Set.from_list id_compare [lr1.id; lr2.id]);
		 pre = merge_pre ifg lr1.pre lr2.pre;
		 moves = union lr1.moves lr2.moves;
		 state = Initial;
		 adj = eid;
		 adj_regs = None
	       } 
    in begin
      (* Set the parent field of the sub-ranges *)
      lr1.parent <- Some newlr.id;
      lr2.parent <- Some newlr.id;
      (* Delete the lr1.id from the adj lists of its nbrs.  Same for lr2 *)
      Set.app (fun id -> delete_adjset ifg (get_lr ifg id) lr1.id) lr1.adj;
      Set.app (fun id -> delete_adjset ifg (get_lr ifg id) lr2.id) lr2.adj;
      (* Add the union of the edges to the new live-range *)
      Set.app (add_edge_id ifg newlr) (union lr1.adj lr2.adj);
      (* Change the move to be processed *)
      change_mv_status ifg mv Processed;
      (* Move the virtual live-ranges into the right set *)
      change_lr_state ifg lr1 Virtual;
      change_lr_state ifg lr2 Virtual;
      (* Add the new node to the ifg *)
      ifg.lr <- Dict.insert ifg.lr newlr.id newlr;
      (* Re-sort the moves for this node and re-sort the neighbors *)
      Set.app (sort_move ifg) lr1.moves;
      Set.app (sort_node ifg) lr1.adj;
      sort_node ifg lr1.id;
    end
  end

(* Coalesces two atomic actual live-ranges into a single actual live-range *)
let coalesce_act_act ifg mv lr1 lr2 =
  let (lr1, lr2) = 
    if precol ifg lr1.id then begin
(*      print_string "swapping precolor for second..."; print_newline (); *)
      (lr2, lr1)
    end
    else (lr1, lr2)
  in
  match (lr1.info, lr2.info) with
    (Simple s1, Simple s2) -> 
        coalesce_ss ifg mv lr1 lr2 s1 s2 sort_move sort_node
  | (CrossCall r1, Simple s1) -> 
      coalesce_create_lr ifg mv lr1 lr2 (insert s1 r1)
  | (Simple s1, CrossCall r1) -> 
      coalesce_create_lr ifg mv lr1 lr2 (insert s1 r1)
  | (CrossCall r1, CrossCall r2) ->
      coalesce_create_lr ifg mv lr1 lr2 (Set.from_list compare_regs [r1;r2])
  | _ -> failwith "ifg.ml: coalesce_act_act shouldn't happen"

(* Coalesces the actual live-range lr1 with the virtual live-range lr2 *)
let coalesce_act_virt ifg mv lr1 lr2 =
  let parent = get_actual_lr ifg lr2.id in
  let children = match parent.info with
    Compound c -> c
  | _ -> failwith "ifg.ml: coalesce_act_virt parent not compound"
  in
  begin
    debugdo ("##coalesce_act_virt: " ^ (id_to_string lr1.id) ^ " " ^ 
		  (id_to_string lr2.id)); 
    (* Delete the lr1.id from the adj sets of its nbrs. *)
    Set.app (fun id -> delete_adjset ifg (get_lr ifg id) lr1.id) lr1.adj;
    (* Add lr1's edges to the parent live-range *)
    Set.app (add_edge_id ifg parent) lr1.adj;
    (* Change lr1's parent to be parent *)
    lr1.parent <- Some parent.id;
    (* Set the pre field of the parent *)
    parent.pre <- merge_pre ifg parent.pre lr1.pre;
    (* Add lr1's moves to the parent node *)
    parent.moves <- union parent.moves lr1.moves;
    (* Change the move to be processed *)
    change_mv_status ifg mv Processed;
    (* Change lr1 to be virtual *)
    change_lr_state ifg lr1 Virtual;
    (* Now get the new info for the parent *)
    let children' =
      match (lr1.info, lr2.info) with
      	(Simple s1, Simple s2) -> begin
	  (* In this case, we have to merge the two children too *)
	  lr2.info <- Simple (union s1 s2);
	  lr2.pre <- merge_pre ifg lr1.pre lr2.pre;
	  lr2.moves <- union lr1.moves lr2.moves;
	  lr2.adj <- union lr1.adj lr2.adj;
	  (* Add the edges of lr1 to lr2 *)
	  Set.app (insert_adjset ifg lr2) lr1.adj;
	  (* Change the mapping of registers contained in lr1 *)
	  Set.app (fun r -> change_atomic ifg lr2.id r mv.block) s1;
	  (* Delete lr1 from the set of nodes *)
	  delete_lr_from_set ifg lr1;
	  children
      	end
      |	_ -> insert children lr1.id
    in
    (* Set the parent info *)
    parent.info <- Compound children';
    (* Re-sort the moves for the parent node and re-sort the neighbors *)
    Set.app (sort_move ifg) parent.moves;
    Set.app (sort_node ifg) parent.adj;
    sort_node ifg parent.id;
  end

(* Coalesces the parents of two virtual live-ranges into p1, may coalesce the *)
(* virtual live-ranges if they're both simple. *)
let coalesce_virt_virt ifg mv lr1 lr2 =
  let p1 = get_actual_lr ifg lr1.id in
  let p2 = get_actual_lr ifg lr2.id in
  let adj2 = p2.adj in
  let c1 = match p1.info with
    Compound c -> c
  | _ -> failwith "ifg.ml: coalesce_virt_virt p1 not compound"
  in
  let c2 = match p2.info with
    Compound c -> c
  | _ -> failwith "ifg.ml: coalesce_virt_virt p2 not compound"
  in
  begin
    debugdo ("##coalesce_virt_virt: " ^ (id_to_string lr1.id) ^ " " ^ 
		  (id_to_string lr2.id));
    (* Merge the parents into the live-range given by p1 *)
    p1.pre <- merge_pre ifg p1.pre p2.pre;
    p1.moves <- union p1.moves p2.moves;
    (* Delete the edges associated with p2 *)
    Set.app (delete_edge_id ifg p2) adj2;
    (* And add them to the edges associated with p1 *)
    Set.app (add_edge_id ifg p1) adj2;
    (* Delete p2 from the set of live-ranges *)
    delete_lr_from_set ifg p2;
    (* Change the children of p2 to have p1 as parent *)
    Set.app (fun id -> let lr = get_lr ifg id in lr.parent <- Some p1.id) c2;
    (* Change the move to be processed *)
    change_mv_status ifg mv Processed;
    (* If the two atomic live-ranges are simple, merge them *)
    (* The children are the union of the two parents' children, the moves *)
    (* to be broken are the union plus the move we are now considering. *)
    let children' =
      match (lr1.info, lr2.info) with
      	(Simple s1, Simple s2) -> begin
	  lr1.info <- Simple (union s1 s2);
	  lr1.pre <- merge_pre ifg lr1.pre lr2.pre;
	  lr1.moves <- union lr1.moves lr2.moves;
	  lr1.adj <- union lr1.adj lr2.adj;
	  (* Change the mapping of registers contained in lr2 *)
	  Set.app (fun r -> change_atomic ifg lr1.id r mv.block) s2;
	  (* Delete lr2 from the set of nodes, and p1's children *)
	  delete_lr_from_set ifg lr1;
	  delete (union c1 c2) lr2.id
	end
      |	_ -> union c1 c2
    in
    p1.info <- (Compound children');
    (* Re-sort the moves for the parent node and re-sort the neighbors *)
    Set.app (sort_move ifg) p1.moves;
    Set.app (sort_node ifg) p1.adj;
    sort_node ifg p1.id;
  end

(* Picks an eligible Mov instruction; prefer intra-procedural over *)
(* other kinds for coalescing. *)
(* NOTE: Picking moves in this way is optional.  It remains to be seen *)
(* whether this is better than simply doing Set.choose ifg.active *)
type move_type = Intra | Cross | Inter
let choose_move ifg =
  let move_info mv = 
    let lr1 = get_actual_lr ifg (regid ifg mv.dest mv.proc) in
    let lr2 = get_actual_lr ifg (regid ifg mv.src mv.proc) in
    match (lr1.info, lr2.info) with
      (Simple _, Simple _) -> Intra
    | (Simple _, _) -> Cross
    | (_, Simple _) -> Cross
    | (Compound _, Compound _) -> Inter
    | _ -> Cross
  in
  let move_lt m1 m2 =
    match (m1, m2) with
      (Intra, Cross) -> true
    | (Intra, Inter) -> true
    | (Cross, Inter) -> true
    | _ -> false
  in
  let pick_move mv1 (mv2, info2) =
    let info1 = move_info mv1 in
    if move_lt info1 info2 then (mv1, info1) else (mv2, info2)
  in
  let mv1 = Set.choose ifg.active in
  let (mv, _) = Set.fold pick_move ifg.active (mv1, move_info mv1)
  in
  mv

(* Coalesces two live-ranges for use with register allocation *)
let coalesce_regs ifg = begin
(*  print_string "coalesce_regs"; print_newline (); *)
  let mv = choose_move ifg in
  (* Get the Atomic live-ranges they're in *)
  let lr1 = get_lr ifg (regid ifg mv.dest mv.proc) in
  let lr2 = get_lr ifg (regid ifg mv.src mv.proc) in
  match (actual lr1, actual lr2) with
    (true, true) -> (* Neither is virtual *)
      coalesce_act_act ifg mv lr1 lr2
  | (true, false) -> (* We want to merge lr1 into the parent of lr2 *)
      coalesce_act_virt ifg mv lr1 lr2
  | (false, true) -> (* We want to merge lr2 into the parent of lr1 *)
      coalesce_act_virt ifg mv lr2 lr1
  | (false, false) -> (* We want to merge the parents and the children *)
      coalesce_virt_virt ifg mv lr1 lr2
end

(* Coalesce two live-ranges for use with slot allocation. *)
let coalesce_spills ifg = begin
  debugdo "coalesce_spills";
  let mv = choose ifg.active in
  let lr1 = get_actual_lr ifg (regid ifg mv.dest mv.proc) in
  let lr2 = get_actual_lr ifg (regid ifg mv.src mv.proc) in
  match (lr1.info, lr2.info) with
    (Simple s1, Simple s2) -> 
      coalesce_ss ifg mv lr1 lr2 s1 s2 spill_sort_move spill_sort_node
  | _ -> failwith "ifg.ml: coalesce_spills called on non-simple live-range."
end

(* Sets all of the moves associated with a given live-range to Processed, *)
(* resorts any affected nodes. *)
let kill_moves ifg lr = begin
  (* Set all of this live-range's moves to Processed *)
  Set.app (fun mv -> change_mv_status ifg mv Processed) lr.moves;
  (* Re-sort the live-ranges associated with those moves - only do lr once *)
  Set.app 
    (fun mv -> 
      let id1 = get_actual_id ifg (regid ifg mv.dest mv.proc) in
      let id2 = get_actual_id ifg (regid ifg mv.src mv.proc) in
      begin
	if not (id1 = lr.id) then sort_node ifg id1 else ();
	if not (id2 = lr.id) then sort_node ifg id2 else ();
      end) lr.moves;
  end

(* Freezes moves so that they won't be considered for future coalescing *)
let freeze ifg =
  (* Pick the live-range with the smallest degree available *)
  let lr = Set.fold (fun id lr -> let lr' = get_actual_lr ifg id in 
                       if (degree lr) < (degree lr') then lr else lr') ifg.freeze
           (get_actual_lr ifg (choose ifg.freeze))
  in begin
    debugdo ("##freeze " ^ (id_to_string lr.id));
    kill_moves ifg lr;
    sort_node ifg lr.id;
  end

(* This should really use some heuristics to avoid spilling highly used regs *)  
(* Currently pick the node with maximal degree *)
let choose_spill ifg = 
  let max_deg id1 (id2, deg2) = 
    let deg1 = degree (get_actual_lr ifg id1) in
    if deg1 > deg2 then (id1, deg1) else (id2, deg2)
  in
  let (id, _) = Set.fold max_deg ifg.spillable (Set.choose ifg.spillable, -1)
  in
  id

(* Spill a live-range *)
let spill ifg =
  (* Pick the live-range to spill *)
  let lr = get_actual_lr ifg (choose_spill ifg) in
  begin  
    debugdo ("##spill " ^ (id_to_string lr.id));
    kill_moves ifg lr;
    (* Add the live-range to the list to be simplified. *)
    change_lr_state ifg lr Simplify;
  end

(* Splits a live-range into connected components each lying within a single *)
(* function.  Those atomic live-ranges that cross function calls are put *)
(* into individual live-ranges.  All the moves associated with the boundaries *)
(* of the split are frozen, so they won't be considered for coalescing *)
let split ifg =
  let lr = get_actual_lr ifg (choose ifg.splitable) in
  let children = match lr.info with
    Compound c -> c
  | _ -> failwith "ifg.ml: split live-range not compound"
  in begin 
    debugdo ("##split " ^ (id_to_string lr.id));
    (* Delete the edges associated with the parent *)
    Set.app (delete_edge_id ifg lr) lr.adj;
    (* Delete the parent from the set of live-ranges *)
    delete_lr_from_set ifg lr;
    (* Now we have to fix up the children live-ranges to turn them back into *)
    (* Actual live-ranges. *)
    Set.app (fun id ->
      let child = get_lr ifg id in
      begin
	(* Delete it's parent information *)
	child.parent <- None;
	(* Add it's id to its nbrs' adjaceny sets. *)
	Set.app (add_edge_id ifg child) child.adj;
	(* Change its status to initial *)
	change_lr_state ifg child Initial;
      end) children;
    (* Now sort the moves for the parent *)
    Set.app (sort_move ifg) lr.moves;
    (* And sort the children *)
    Set.app (sort_node ifg) children;
  end

(* Tries to color the registers using colors from cset.  If there are none *)
(* available, it calls spill_fn and then continues to try to color the graph. *)
(* Returns an ident to int map that can be converted to a reg to int map. *)
let color ifg cset spill_fn =
  let colmap = ref (Dict.empty id_compare) in
  let maxcols = ref cset in
  let color_reg id = 
    let avail = ref (!maxcols) in
    let lr1 = get_actual_lr ifg id in
    let adjacent_regs = match lr1.adj_regs with
      None -> failwith "ifg.ml: color no adjacent registers"
    | Some regs -> regs
    in
    let bogus_f = id_new "color: BOGUS" in
    (* Given an identifier, removes its color from the avail set *)
    let update_avail r =
      match r with 
	Virt _ -> 
	  let lr2 = get_actual_lr ifg (regid ifg r bogus_f) in begin
      	    (match lr2.pre with
	      None -> ()
	    | Some pre_id -> avail := Set.delete !avail (reg_to_int ifg pre_id));
	    try 
	      let used = Dict.lookup !colmap lr2.id in
	      avail := Set.delete !avail used
	    with Dict.Absent -> ();
	  end
      |	_ -> avail := Set.delete !avail (phys_to_int r)
    in begin
      Set.app update_avail adjacent_regs; (* Remove the adjacent colors *)
      if is_empty !avail then begin
	debugdo "Spilling!";
	spill_fn ifg lr1 maxcols colmap  (* Spill the live-range *)
      end else  (* Assign the color *)
	match lr1.pre with
	  None -> colmap := Dict.insert !colmap id (choose !avail)
	| Some pre_id -> 
	    let r = reg_to_int ifg pre_id in
	    if member !avail r then
	      colmap := Dict.insert !colmap id (reg_to_int ifg pre_id)
	    else failwith "ifg.ml: color forced to spill actual reg"
    end
  in begin
    List.map color_reg ifg.stack;
    ifg.stack <- [];
    !colmap
  end
  
(* Converts a live-range to int dictionary into a register to 'a dictionary *)
(* given the function from ints to 'a *)
let fix_map ifg cmap trans =
  let rec fix_lr id c newmap =
    let c' = trans c in
    let lr = get_lr ifg id in
    match lr.info with
      Simple regs -> Set.fold (fun r d -> 
	if not (member machine r) then Dict.insert d r c' else d) regs newmap
    | CrossCall r -> Dict.insert newmap r c'
    | Compound ids -> Set.fold (fun id' d -> fix_lr id' c d) ids newmap
  in
  Dict.fold_dict fix_lr cmap (Dict.empty compare_regs)

(* Attempts to color the interference graph for register usage.  If a *)
(* live-range must be spilled, it is put in the spilled set. Returns a mapping *)
(* from registers to physical registers. *)
let color_regs ifg = begin 
  debugdo "##color_regs";
  let spill_fn ifg lr maxcols colmap =
    change_lr_state ifg lr Spilled
  in
  let cmap = color ifg (n_set ifg.n) spill_fn in 
    fix_map ifg cmap int_to_reg
end

(* Colors an interference graph without spilling, tries to use the fewest *)
(* number of stack slots possible. Returns a register to int (slot index) *)
(* mapping. *)
let color_spills ifg = begin 
  debugdo "##color_slots";
  let maxslot = ref 0 in
  let spill_fn ifg lr maxcols colmap = begin
    maxcols := Set.insert !maxcols !maxslot;
    colmap := Dict.insert !colmap lr.id !maxslot;
    incr maxslot;
  end in
  let cmap = color ifg (Set.empty compare) spill_fn in
  (fix_map ifg cmap (fun x -> x), !maxslot)
end

(* EOF: regifg.ml *)
