Compile fixes

This commit is contained in:
Cédric Pasteur 2011-04-20 14:05:55 +02:00
parent 3ee0e5e7b4
commit 7787428f34
8 changed files with 195 additions and 60 deletions

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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

View file

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