(* Adapted from Pottier's PP compiler *)

let colour_graph globals int_fun liveafter =
  (* Build an interference graph for this function, and color
     it. Define a function that allows consulting the coloring. *)

  let uses = Uses.examine_internal globals int_fun in

  let module G = struct
    let graph = Build.build globals int_fun uses liveafter
    let uses =
     (fun r ->
       Glue.int_of_matitapos
        (Identifiers.lookup_safe PreIdentifiers.RegisterTag uses r))
    let verbose = false
(*
    let () =
      if verbose then
	Printf.printf "Starting hardware register allocation for %s.\n" f
*)
  end in

  let module C = Coloring.Color (G) in

  let lookup r =
    Untrusted_interference.Vertex.Map.find (Untrusted_interference.lookup G.graph r) C.coloring
  in

  (* Restrict the interference graph to concern spilled vertices only,
     and color it again, this time using stack slots as colors. *)

  let module H = struct
    let graph = Untrusted_interference.droph (Untrusted_interference.restrict G.graph (fun v ->
      match Untrusted_interference.Vertex.Map.find v C.coloring with
      | Coloring.Spill ->
	  true
      | Coloring.Color _ ->
	  false
    ))
    let verbose = false
(*
    let () =
      if verbose then
	Printf.printf "Starting stack slot allocation for %s.\n" f
*)
  end in

  let module S = Spill.Color (H) in

  (* Define a new function that consults both colorings at once. *)

  let lookup r =
   match r with
      Types.Inl r ->
       (match lookup r with
       | Coloring.Spill ->
	   Interference.Decision_spill (Glue.matitanat_of_int (Untrusted_interference.Vertex.Map.find (Untrusted_interference.lookup H.graph r) S.coloring))
       | Coloring.Color color ->
	   Interference.Decision_colour color)
    | Types.Inr r -> Interference.Decision_colour r
  in

   { Interference.colouring = lookup; 
     spilled_no = Glue.matitanat_of_int S.locals
   }