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

@@ -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

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

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

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