Compile fixes

compiler/minils/analysis/_tags

@@ -0,0 +1 @@
+<interference.ml>:use_ocamlgraph

compiler/minils/analysis/interference.ml

@@ -1,49 +1,13 @@
 open Idents
 open Interference_graph
 
-let memoize f =
-  let map = Hashtbl.create 100 in
-    fun x ->
-      try
-        Hashtbl.find map x
-      with
-        | Not_found -> let r = f x in Hashtbl.add map x r; r
-
-let memoize_couple f =
-  let map = Hashtbl.create 100 in
-    fun (x,y) ->
-      try
-        Hashtbl.find map (x,y)
-      with
-        | Not_found ->
-            let r = f (x,y) in Hashtbl.add map (x,y) r; Hashtbl.add map (y,x) r; r
-
-(** [iter_couple f l] calls f for all x and y distinct in [l].  *)
-let rec iter_couple f l = match l with
-  | [] -> ()
-  | x::l ->
-      List.iter (f x) l;
-      iter_couple f l
-
-module ListMap = functor (Ord:OrderedType) ->
-struct
-  include Map.Make(Ord)
-
-  let add_element k v m =
-    try
-      add k (v::(find k m)) m
-    with
-      | Not_found -> add k [v] m
-end
-
-type TyEnv =
+module TyEnv =
     ListMap.Make (struct
       type t = Types.ty
       let compare = Global_compare.type_compare
     end)
 
-
-module world = struct
+module World = struct
   let vds = ref Idents.Env.empty
   let memories = ref IvarSet.empty
 
@@ -56,18 +20,13 @@ module world = struct
     let env = build env f.n_output in
     let env = build env f.n_local in
       vds := env;
-    (* build the set of memories *)ml
+    (* build the set of memories *)
       let mems = Mls_utils.node_memory_vars f in
         memories := List.fold_left (fun s (x, _) -> IvarSet.add (Ivar x) s) IvarSet.empty mems
 
   let vd_from_ident x =
     Idents.Env.find x !vds
 
-  let is_optimized_ty ty = true
-
-  let is_memory x =
-    Idents.IdentSet.mem x !memories
-
   let rec ivar_type iv = match iv with
     | Ivar x ->
         let vd = vd_from_ident x in
@@ -75,6 +34,21 @@ module world = struct
     | Ifield(_, f) ->
         Modules.find_field f
 
+  let is_optimized_ty ty =
+    match unalias_type ty with
+      | Tarray _ -> true
+      | Tid n ->
+          (match find_type n with
+            | Tstruct _ -> true
+            | _ -> false)
+      | Tinvalid -> false
+
+  let is_optimized iv =
+    is_optimized_ty (ivar_type iv)
+
+  let is_memory x =
+    Idents.IdentSet.mem x !memories
+
   let igs = ref []
 
   let node_for_ivar iv =
@@ -193,7 +167,7 @@ let should_interfere = memoize_couple should_interfere
 (** Builds the (empty) interference graphs corresponding to the
     variable declaration list vds. It just creates one graph per type
     and one node per declaration. *)
-let init_interference_graph () =
+let init_interference_graph f =
   (** Adds a node to the list of nodes for the given type. *)
   let add_node env iv ty =
     let ty = unalias_type ty in
@@ -217,8 +191,10 @@ let init_interference_graph () =
        | _ -> env
     )
   in
+  (* do not add not linear inputs*)
+  let vds = (*List.filter is_linear f.n_input @ *) f.n_output @ f.n_local in
   let env = Idents.Env.fold
-    (fun _ vd env -> add_ivar env (Ivar vd.v_ident) vd.v_type) TyEnv.empty !World.vds in
+    (fun _ vd env -> add_ivar env (Ivar vd.v_ident) vd.v_type) TyEnv.empty vds in
     World.igs := TyEnv.fold mk_graph [] env
 
 
@@ -324,7 +300,7 @@ let add_init_return_eq f =
 let build_interf_graph f =
   World.init f;
   (** Init interference graph *)
-  init_interference_graph ();
+  init_interference_graph f;
 
   let eqs = add_init_return_eq f in
   (** Build live vars sets for each equation *)
@@ -342,3 +318,51 @@ let build_interf_graph f =
 
     (* Return the graphs *)
     !World.igs
+
+
+
+(** Color the nodes corresponding to fields using
+    the color attributed to the record. This makes sure that
+    if a and b are shared, then a.f and b.f are too. *)
+let color_fields ig =
+  let process n =
+    let fields = filter_fields (G.label n) in
+    match fields with
+      | [] -> ()
+      | id::_ -> (* we only look at the first as they will all have the same color *)
+        let _, top_node = node_for_name id in
+          G.Mark.set n (G.Mark.get top_node)
+  in
+    G.iter_vertex process ig.g_graph
+
+(** Color an interference graph.*)
+let color_interf_graphs igs =
+  let record_igs, igs =
+    List.partition (fun ig -> is_record_type ig.g_info) igs in
+    (* First color interference graphs of record types *)
+    List.iter color record_igs;
+    (* Then update fields colors *)
+    List.iter (color_fields record_igs) igs;
+    (* and finish the coloring *)
+    List.iter color igs
+
+(** Create the list of lists of variables stored together,
+    from the interference graph.*)
+let create_subst_lists igs =
+  let create_one_ig ig =
+    List.map (fun x -> ig.g_info, x) (values_by_color ig)
+  in
+    List.flatten (List.map create_one_ig igs)
+
+let node f =
+  (** Build the interference graphs *)
+  let igs = build_interf_graph f in
+    (** Color the graph *)
+    color_interf_graphs igs;
+    (** Remember the choice we made for code generation *)
+      { f with n_mem_alloc = create_subst_lists igs }
+
+let program p =
+  let funs = { Mls_mapfold.defaults with node_dec = node } in
+  let p, _ = Mls_mapfold.program_it funs ([], []) p in
+    p

compiler/minils/minils.ml

@@ -125,7 +125,8 @@ type node_dec = {
   n_equs   : eq list;
   n_loc    : location;
   n_params : param list;
-  n_params_constraints : size_constraint list }
+  n_params_constraints : size_constraint list;
+  n_mem_alloc : (ty * Interference_graph.ivar list) list; }
 
 type const_dec = {
   c_name : qualname;
@@ -155,7 +156,7 @@ let mk_exp ty ?(clock = fresh_clock()) ?(loc = no_location) desc =
     e_ck = clock; e_loc = loc }
 
 let extvalue_exp ?(clock = fresh_clock()) ?(loc = no_location) ty desc =
-  mk_exp ~clock:clock ~loc:loc ty (Eextvalue (mk_extvalue ~clock:clock ~loc:loc ty desc))
+  mk_exp ~clock:clock ~loc:loc ty (Eextvalue (mk_extvalue ~clock:clock ~loc:loc ~ty:ty desc))
 
 let mk_var_dec ?(loc = no_location) ?(clock = fresh_clock()) ident ty =
   { v_ident = ident; v_type = ty; v_clock = clock; v_loc = loc }
@@ -166,6 +167,7 @@ let mk_equation ?(loc = no_location) pat exp =
 let mk_node
     ?(input = []) ?(output = []) ?(contract = None) ?(local = []) ?(eq = [])
     ?(stateful = true) ?(loc = no_location) ?(param = []) ?(constraints = [])
+    ?(mem_alloc=[])
     name =
   { n_name = name;
     n_stateful = stateful;
@@ -176,7 +178,8 @@ let mk_node
     n_equs = eq;
     n_loc = loc;
     n_params = param;
-    n_params_constraints = constraints }
+    n_params_constraints = constraints;
+    n_mem_alloc = mem_alloc }
 
 let mk_type_dec type_desc name loc =
   { t_name = name; t_desc = type_desc; t_loc = loc }

compiler/minils/mls_utils.ml

@@ -67,7 +67,7 @@ let pat_from_dec_list decs =
 
 let tuple_from_dec_list decs =
   let aux vd =
-    mk_extvalue ~clock:vd.v_clock vd.v_type (Wvar vd.v_ident)
+    mk_extvalue ~clock:vd.v_clock ~ty:vd.v_type (Wvar vd.v_ident)
   in
     Eapp(mk_app Earray, List.map aux decs, None)
 

compiler/utilities/minils/_tags

@@ -0,0 +1 @@
+<interference_graph.ml>: use_ocamlgraph

compiler/utilities/minils/interference_graph.ml

@@ -9,29 +9,46 @@ type ivar =
     | Ivar of Idents.var_ident
     | Ifield of ivar * Names.field_name
 
-type IvarEnv =
+module ListMap (Ord:Map.OrderedType) =
+struct
+  include Map.Make(Ord)
+
+  let add_element k v m =
+    try
+      add k (v::(find k m)) m
+    with
+      | Not_found -> add k [v] m
+
+  let add_elements k vl m =
+    try
+      add k (vl @ (find k m)) m
+    with
+      | Not_found -> add k vl m
+end
+
+module IvarEnv =
     Map.Make (struct
       type t = ivar
       let compare = compare
     end)
 
-type IvarSet =
+module IvarSet =
     Set.Make (struct
       type t = ivar
       let compare = compare
     end)
 
 let rec ivar_to_string = function
-  | IVar n -> Idents.name n
-  | IField(iv,f) -> (ivar_to_string iv)^"."^(shortname f)
+  | Ivar n -> Idents.name n
+  | Ifield(iv,f) -> (ivar_to_string iv)^"."^(Names.shortname f)
 
 
 module VertexValue = struct
   type t = ivar list ref
-  let compare = compare
+  (*let compare = compare
   let hash = Hashtbl.hash
   let equal = (=)
-  let default = []
+  let default = []*)
 end
 
 module EdgeValue = struct
@@ -42,7 +59,7 @@ end
 
 module G =
 struct
-  include Imperative.Graph.ConcreteLabeled(VertexValue)(EdgeValue)
+  include Imperative.Graph.AbstractLabeled(VertexValue)(EdgeValue)
 
   let add_edge_v g n1 v n2 =
     add_edge_e g (E.create n1 v n2)
@@ -63,7 +80,6 @@ struct
         r := !(V.label n2) @ !r;
         remove_vertex g n2
     )
-
 end
 
 type interference_graph = {
@@ -156,5 +172,69 @@ let iter_interf f g =
     if G.E.label e = Iinterference then
       f (G.V.label (G.E.src e)) (G.V.label (G.E.dst e))
   in
-    G.iter_edges do_f g.g_graph
+    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 ""
+
+  (*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]
+
+  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
+    DotPrint.output_graph oc g.g_graph;
+    close_out oc

compiler/utilities/misc.ml

@@ -227,4 +227,28 @@ let split_string s separator = Str.split (separator |> Str.quote |> Str.regexp)
 
 let file_extension s = split_string s "." |> last_element
 
+let memoize f =
+  let map = Hashtbl.create 100 in
+    fun x ->
+      try
+        Hashtbl.find map x
+      with
+        | Not_found -> let r = f x in Hashtbl.add map x r; r
+
+let memoize_couple f =
+  let map = Hashtbl.create 100 in
+    fun (x,y) ->
+      try
+        Hashtbl.find map (x,y)
+      with
+        | Not_found ->
+            let r = f (x,y) in Hashtbl.add map (x,y) r; Hashtbl.add map (y,x) r; r
+
+(** [iter_couple f l] calls f for all x and y distinct in [l].  *)
+let rec iter_couple f l = match l with
+  | [] -> ()
+  | x::l ->
+      List.iter (f x) l;
+      iter_couple f l
+
 

compiler/utilities/pp_tools.ml

@@ -66,3 +66,5 @@ let print_map iter print_key print_element ff map =
   fprintf ff "@[<hv 2>[@ ";
   iter (fun k x -> fprintf ff "| %a -> %a@ " print_key k print_element x) map;
   fprintf ff "]@]"
+
+