open Gen;; open Spim;; open Smallset;; open Liveness;; let colors = List.length registers;; let assign_colors nodes = let spilled = ref [] in let all_colors = of_list registers in let color n = match n.color with | Some _ -> () | None -> let rec used = function [] -> [] | h::t -> match h.color with None -> used t | Some c -> c :: used t in let ok_colors = to_list (diff all_colors (of_list (used n.adj))) in match ok_colors with [] -> spilled := n :: !spilled | c::_ -> n.color <- Some c in List.iter color nodes; !spilled ;; let main code = let nodes, moves = Liveness.interference registers (Liveness.flow code) in let spilled = assign_colors nodes in spilled, nodes ;; let rewrite_instr frame spilled = let rec map = function [] -> [] | u :: rest -> (u, Frame.alloc_local frame) :: map rest in let spilled_map = map spilled in let rec mapi f = function [] -> [], [] | u::t -> let code, reg = mapi f t in try let i = List.assoc u spilled_map in let u' = new_temp() in f i u' :: code, u' :: reg with Not_found -> code, u :: reg in let rec patch = function | Ass.Oper (op, s, d, l, c) -> let s_code, s' = mapi load_sp_offset s in let d_code, d' = mapi store_sp_offset d in s_code @ (Ass.Oper (op, s', d', l, c) :: d_code) | Ass.Move (op, s, d) -> let s_code, s'::_ = mapi load_sp_offset [s] in let d_code, d'::_ = mapi store_sp_offset [d] in s_code @ (Ass.Move (op, s', d') :: d_code) | instr -> [instr] in patch;; let rewrite frame spilled code = List.concat (List.map (rewrite_instr frame spilled) code);; let rec remove_moves = function [] -> [] | Ass.Move (instr, s, d) as op :: t when s = d -> remove_moves t | op :: t -> op :: remove_moves t ;; let fix_size f adjust code = let size = Frame.frame_size f in let instr = (Frame.frame_size_label f)^"="^(string_of_int size) in Ass.Oper (instr, [], [], None,[]) :: code ;; let register_map nodes = let map = Hashtbl.create 13 in let f r = match r.color with Some c -> Hashtbl.add map r.temp c | _ -> () in List.iter f nodes; map ;; let assign_registers_instr map = let reg r = try Hashtbl.find map r with Not_found -> r in function | Ass.Oper (op, s, d, l, c) -> Ass.Oper (op, List.map reg s, List.map reg d, l, c) | Ass.Move (op, s, d) -> Ass.Move (op, reg s, reg d) | instr -> instr ;; let assign_registers map code = List.map (assign_registers_instr map) code;; exception Spill_spilled;; let first_spilled = ref (Gen.new_temp());; let check_spilled u = if Gen.temp_int u.temp > Gen.temp_int !first_spilled then raise Spill_spilled (* erreur fatal: risque de boucler. on ne devrait jamais avoir besoin de spiller un auxilliaire. il faut peut être passer à une allocation plus fine, ou en tous cas, mieux choisir les candidats au spil... *) ;; let rec alloc (frame, adjust, code) = let spilled, all_nodes = main code in List.iter check_spilled spilled; match spilled with [] -> fix_size frame adjust (remove_moves (assign_registers (register_map all_nodes) code)) | _ -> let new_code = rewrite frame (List.map (fun t -> t.temp) spilled) code in alloc (frame, adjust, new_code) ;; let program p = first_spilled := Gen.new_temp(); List.concat ((p.prelude :: alloc p.main) :: List.map alloc p.procedures);;