From 7787428f343977347c3bb6cea400ad9acb4d0bb6 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?C=C3=A9dric=20Pasteur?= Date: Wed, 20 Apr 2011 14:05:55 +0200 Subject: [PATCH] Compile fixes --- compiler/minils/analysis/_tags | 1 + compiler/minils/analysis/interference.ml | 118 +++++++++++------- compiler/minils/minils.ml | 9 +- compiler/minils/mls_utils.ml | 2 +- compiler/utilities/minils/_tags | 1 + .../utilities/minils/interference_graph.ml | 98 +++++++++++++-- compiler/utilities/misc.ml | 24 ++++ compiler/utilities/pp_tools.ml | 2 + 8 files changed, 195 insertions(+), 60 deletions(-) create mode 100644 compiler/minils/analysis/_tags create mode 100644 compiler/utilities/minils/_tags diff --git a/compiler/minils/analysis/_tags b/compiler/minils/analysis/_tags new file mode 100644 index 0000000..a8e5446 --- /dev/null +++ b/compiler/minils/analysis/_tags @@ -0,0 +1 @@ +:use_ocamlgraph \ No newline at end of file diff --git a/compiler/minils/analysis/interference.ml b/compiler/minils/analysis/interference.ml index b5d5ddb..f6ec0fe 100644 --- a/compiler/minils/analysis/interference.ml +++ b/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 diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 38b5649..766bcc3 100644 --- a/compiler/minils/minils.ml +++ b/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 } diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index 12e3258..f65742a 100644 --- a/compiler/minils/mls_utils.ml +++ b/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) diff --git a/compiler/utilities/minils/_tags b/compiler/utilities/minils/_tags new file mode 100644 index 0000000..35ec891 --- /dev/null +++ b/compiler/utilities/minils/_tags @@ -0,0 +1 @@ +: use_ocamlgraph diff --git a/compiler/utilities/minils/interference_graph.ml b/compiler/utilities/minils/interference_graph.ml index 98d4dbf..20a91ea 100644 --- a/compiler/utilities/minils/interference_graph.ml +++ b/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 diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index f02f364..6548c11 100644 --- a/compiler/utilities/misc.ml +++ b/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 + diff --git a/compiler/utilities/pp_tools.ml b/compiler/utilities/pp_tools.ml index 442e2f5..88f932b 100644 --- a/compiler/utilities/pp_tools.ml +++ b/compiler/utilities/pp_tools.ml @@ -66,3 +66,5 @@ let print_map iter print_key print_element ff map = fprintf ff "@[[@ "; iter (fun k x -> fprintf ff "| %a -> %a@ " print_key k print_element x) map; fprintf ff "]@]" + +