From 448c1631813b1270331b7de6f00664111a8a3c9c Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Thu, 21 Apr 2011 10:44:25 +0200 Subject: [PATCH] Dsatur coloring algorithm It is not completely generic, as we need to know the difference between affinity and interference edges. --- compiler/minils/analysis/interference.ml | 12 ++- compiler/utilities/minils/dcoloring.ml | 88 +++++++++++++++++++ compiler/utilities/minils/interference2dot.ml | 53 +++++++++++ .../utilities/minils/interference_graph.ml | 75 ++-------------- 4 files changed, 155 insertions(+), 73 deletions(-) create mode 100644 compiler/utilities/minils/dcoloring.ml create mode 100644 compiler/utilities/minils/interference2dot.ml diff --git a/compiler/minils/analysis/interference.ml b/compiler/minils/analysis/interference.ml index 5bddce8..aa5374a 100644 --- a/compiler/minils/analysis/interference.ml +++ b/compiler/minils/analysis/interference.ml @@ -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 diff --git a/compiler/utilities/minils/dcoloring.ml b/compiler/utilities/minils/dcoloring.ml new file mode 100644 index 0000000..7ebf966 --- /dev/null +++ b/compiler/utilities/minils/dcoloring.ml @@ -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 diff --git a/compiler/utilities/minils/interference2dot.ml b/compiler/utilities/minils/interference2dot.ml new file mode 100644 index 0000000..64971e6 --- /dev/null +++ b/compiler/utilities/minils/interference2dot.ml @@ -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 diff --git a/compiler/utilities/minils/interference_graph.ml b/compiler/utilities/minils/interference_graph.ml index e203589..394724e 100644 --- a/compiler/utilities/minils/interference_graph.ml +++ b/compiler/utilities/minils/interference_graph.ml @@ -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