Dsatur coloring algorithm

It is not completely generic, as we need to know 
the difference between affinity and interference
edges.
This commit is contained in:
Cédric Pasteur 2011-04-21 10:44:25 +02:00
parent 3f9918b570
commit 448c163181
4 changed files with 155 additions and 73 deletions

View file

@ -206,6 +206,9 @@ let compute_live_vars eqs =
in
let env = IvarSet.fold decr_uses (InterfRead.read eq) env in
let alive_vars = IvarEnv.fold (fun iv n acc -> if n > 0 then iv::acc else acc) env [] in
Format.printf " Alive vars : %s@." (String.concat " " (List.map ivar_to_string alive_vars));
let res = (eq, alive_vars)::res in
let env = IvarSet.fold (add_uses uses) (InterfRead.def eq) env in
env, res
@ -432,17 +435,17 @@ let color_interf_graphs igs =
let record_igs, igs =
List.partition (fun ig -> is_record_type ig.g_type) igs in
(* First color interference graphs of record types *)
List.iter color record_igs;
List.iter Dcoloring.color record_igs;
(* Then update fields colors *)
List.iter color_fields igs;
(* and finish the coloring *)
List.iter color igs
List.iter Dcoloring.color igs
let print_graphs f igs =
let cpt = ref 0 in
let print_graph ig =
let s = (Names.shortname f.n_name)^ (string_of_int !cpt) in
print_graph (Names.fullname f.n_name) s ig;
Interference2dot.print_graph (Names.fullname f.n_name) s ig;
cpt := !cpt + 1
in
List.iter print_graph igs
@ -451,7 +454,7 @@ let print_graphs f igs =
from the interference graph.*)
let create_subst_lists igs =
let create_one_ig ig =
List.map (fun x -> ig.g_type, x) (values_by_color ig)
List.map (fun x -> ig.g_type, x) (Dcoloring.values_by_color ig)
in
List.flatten (List.map create_one_ig igs)
@ -466,6 +469,7 @@ let node _ acc f =
{ f with n_mem_alloc = create_subst_lists igs }, acc
let program p =
Format.printf "is_directe %b@." (G.is_directed);
let funs = { Mls_mapfold.defaults with Mls_mapfold.node_dec = node } in
let p, _ = Mls_mapfold.program_it funs () p in
p

View file

@ -0,0 +1,88 @@
open Interference_graph
(** Coloring*)
let no_color = 0
let min_color = 1
module ColorEnv =
ListMap(struct
type t = int
let compare = compare
end)
module ColorSet =
Set.Make(struct
type t = int
let compare = compare
end)
module Dsatur = struct
let rec remove_colored l = match l with
| [] -> []
| v::l -> if G.Mark.get v > 0 then l else remove_colored l
let colors i g v =
let color e colors =
if G.E.label e = i then
let c = G.Mark.get (G.E.dst e) in
if c <> 0 then
ColorSet.add c colors
else
colors
else
colors
in
G.fold_succ_e color g v ColorSet.empty
(** Returns the smallest value not in the list of colors. *)
let rec find_min_available_color interf_colors =
let rec aux i =
if not (ColorSet.mem i interf_colors) then i else aux (i+1)
in
aux min_color
(** Returns a new color from interference and affinity colors lists.*)
let pick_color interf_colors aff_colors =
let aff_colors = ColorSet.diff aff_colors interf_colors in
if not (ColorSet.is_empty aff_colors) then
ColorSet.choose aff_colors
else
find_min_available_color interf_colors
let dsat g v =
let color_deg = ColorSet.cardinal (colors Iinterference g v) in
if color_deg = 0 then G.out_degree g v else color_deg
let dsat_max g v1 v2 =
match compare (dsat g v1) (dsat g v2) with
| 0 -> if G.out_degree g v1 > G.out_degree g v2 then v1 else v2
| x when x > 0 -> v1
| _ -> v2
let uncolored_vertices g =
G.fold_vertex (fun v acc -> if G.Mark.get v = 0 then v::acc else acc) g []
let color_vertex g v =
G.Mark.set v (pick_color (colors Iinterference g v) (colors Iaffinity g v))
let rec color_vertices g vertices = match vertices with
| [] -> ()
| v::vertices ->
let vmax = List.fold_left (dsat_max g) v vertices in
color_vertex g vmax;
let vertices = remove_colored (v::vertices) in
color_vertices g vertices
let coloring g =
color_vertices g (uncolored_vertices g)
end
let values_by_color g =
let env = G.fold_vertex
(fun n env -> ColorEnv.add_elements (G.Mark.get n) !(G.V.label n) env)
g.g_graph ColorEnv.empty
in
ColorEnv.fold (fun _ v acc -> v::acc) env []
let color g =
Dsatur.coloring g.g_graph

View file

@ -0,0 +1,53 @@
open Graph
open Interference_graph
(** Printing *)
module DotG = struct
include G
let name = ref ""
let color_to_graphviz_color i =
(i * 8364263947 + 855784368)
(*Functions for printing the graph *)
let default_vertex_attributes _ = []
let default_edge_attributes _ = []
let get_subgraph _ = None
let graph_attributes _ =
[`Label !name]
let vertex_name v =
let rec ivar_name iv =
match iv with
| Ivar id -> Idents.name id
| Ifield(ivar, f) -> (ivar_name ivar)^"_"^(Names.shortname f)
in
Misc.sanitize_string (ivar_name (List.hd !(V.label v)))
let vertex_attributes v =
let s = String.concat ", " (List.map (fun iv -> ivar_to_string iv) !(V.label v)) in
[`Label s; `Color (color_to_graphviz_color (Mark.get v))]
let edge_attributes e =
let style =
match E.label e with
| Iinterference -> `Solid
| Iaffinity -> `Dashed
| Isame_value -> `Dotted
in
[`Style style; `Dir `None]
end
module DotPrint = Graphviz.Dot(DotG)
let print_graph label filename g =
Global_printer.print_type Format.str_formatter g.g_type;
let ty_str = Format.flush_str_formatter () in
DotG.name := label^" : "^ty_str;
let oc = open_out (filename ^ ".dot") in
Format.printf "Wrriting to %s.dot@." filename;
DotPrint.output_graph oc g.g_graph;
close_out oc

View file

@ -79,6 +79,12 @@ struct
r := !(V.label n2) @ !r;
remove_vertex g n2
)
let vertices g =
fold_vertex (fun v acc -> v::acc) g []
let filter_vertices f g =
fold_vertex (fun v acc -> if f v then v::acc else acc) g []
end
type interference_graph = {
@ -172,72 +178,3 @@ let iter_interf f g =
f g (G.E.src e) (G.E.dst e)
in
G.iter_edges_e do_f g.g_graph
(** Coloring*)
module KColor = Coloring.Mark(G)
module ColorEnv =
ListMap(struct
type t = int
let compare = compare
end)
let color g =
KColor.coloring g.g_graph (Hashtbl.length g.g_hash)
let values_by_color g =
let env = G.fold_vertex
(fun n env -> ColorEnv.add_elements (G.Mark.get n) !(G.V.label n) env)
g.g_graph ColorEnv.empty
in
ColorEnv.fold (fun _ v acc -> v::acc) env []
(** Printing *)
module DotG = struct
include G
let name = ref ""
let color_to_graphviz_color i =
(i * 8364263947 + 855784368)
(*Functions for printing the graph *)
let default_vertex_attributes _ = []
let default_edge_attributes _ = []
let get_subgraph _ = None
let graph_attributes _ =
[`Label !name]
let vertex_name v =
let rec ivar_name iv =
match iv with
| Ivar id -> Idents.name id
| Ifield(ivar, f) -> (ivar_name ivar)^"_"^(Names.shortname f)
in
Misc.sanitize_string (ivar_name (List.hd !(V.label v)))
let vertex_attributes v =
let s = String.concat ", " (List.map (fun iv -> ivar_to_string iv) !(V.label v)) in
[`Label s; `Color (color_to_graphviz_color (Mark.get v))]
let edge_attributes e =
let style =
match E.label e with
| Iinterference -> `Solid
| Iaffinity -> `Dashed
| Isame_value -> `Dotted
in
[`Style style]
end
module DotPrint = Graphviz.Dot(DotG)
let print_graph label filename g =
Global_printer.print_type Format.str_formatter g.g_type;
let ty_str = Format.flush_str_formatter () in
DotG.name := label^" : "^ty_str;
let oc = open_out (filename ^ ".dot") in
Format.printf "Wrriting to %s.dot@." filename;
DotPrint.output_graph oc g.g_graph;
close_out oc