jeltz/heptagon
1
0
Fork 0
Code Issues Pull requests Releases Activity

Correct Mapfold !! Or at least much more than before.

Browse source 
Still not sure whether the notion of main_nodes is correct.
A parametrized node not used right in the module gets removed.
Is that the wanted behaviour ?
This commit is contained in:
Léonard Gérard 2010-08-24 11:07:05 +02:00
parent fb678481ce
commit c4a926f489
4 changed files with 217 additions and 168 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

349
compiler/minils/transformations/callgraph_mapfold.ml
View file

@ -29,21 +29,185 @@ struct
raise Misc.Error
end
module Param_instances :
sig
type key = private static_exp (** Fully instantiated param *)
type env = key NamesEnv.t
val instantiate: env -> static_exp list -> key list
val get_node_instances : LongNameEnv.key -> key list list
val add_node_instance : LongNameEnv.key -> key list -> unit
val build : env -> param list -> key list -> env
module Instantiate :
sig
val program : program -> program
end
end =
struct
type key = static_exp
type env = key NamesEnv.t
(** An instance is a list of instantiated params *)
type instance = key list
(** two instances are equal if the desc of keys are equal *)
let compare_instances =
let compare se1 se2 = compare se1.se_desc se2.se_desc in
Misc.make_list_compare compare
module S = (** Instances set *)
Set.Make(
struct
type t = instance
let compare = compare_instances
end)
module M = (** Map instance to its instantiated node *)
Map.Make(
struct
type t = longname * instance
let compare (l1,i1) (l2,i2) =
let cl = compare l1 l2 in
if cl = 0 then compare_instances i1 i2 else cl
end)
(** Maps a couple (node name, params) to the name of the instantiated node *)
let nodes_names = ref M.empty
(** Maps a node to its list of instances *)
let nodes_instances = ref LongNameEnv.empty
(** create a params instance *)
let instantiate m se = List.map (simplify m) se
(** @return the name of the node corresponding to the instance of
[ln] with the static parameters [params]. *)
let node_for_params_call ln params = match params with
| [] -> ln
| _ -> let ln = M.find (ln,params) !nodes_names in ln
(** Generates a fresh name for the the instance of
[ln] with the static parameters [params] and stores it. *)
let generate_new_name ln params = match params with
| [] -> nodes_names := M.add (ln, params) ln !nodes_names
| _ -> (match ln with
| Modname { qual = q; id = id } ->
let new_ln = Modname { qual = q;
(* TODO ??? c'est quoi ce nom ??? *)
(* l'utilite de fresh n'est vrai que si toute les fonctions
sont touchees.. ce qui n'est pas vrai cf main_nodes *)
(* TODO mettre les valeurs des params dans le nom *)
id = id^(Idents.name (Idents.fresh "")) } in
nodes_names := M.add (ln, params) new_ln !nodes_names
| _ -> assert false)
(** Adds an instance of a node. *)
let add_node_instance ln params =
(* get the already defined instances *)
let instances = try LongNameEnv.find ln !nodes_instances
with Not_found -> S.empty in
if S.mem params instances then () (* nothing to do *)
else ( (* it's a new instance *)
let instances = S.add params instances in
nodes_instances := LongNameEnv.add ln instances !nodes_instances;
generate_new_name ln params )
(** @return the list of instances of a node. *)
let get_node_instances ln =
let instances_set =
try LongNameEnv.find ln !nodes_instances
with Not_found -> S.empty in
S.elements instances_set
(** Build an environment by instantiating the passed params *)
let build env params_names params_values =
List.fold_left2 (fun m { p_name = n } v -> NamesEnv.add n v m)
env params_names (instantiate env params_values)
(** This module creates an instance of a node with a given
list of static parameters. *)
module Instantiate =
struct
(** Replaces static parameters with their value in the instance. *)
let static_exp funs m se =
let se, _ = Global_mapfold.static_exp funs m se in
let se = match se.se_desc with
| Svar ln ->
(match ln with
| Name n ->
(try NamesEnv.find n m
with Not_found -> (* It should then be in the global env *)
(* TODO should we check it's in the global env ?
I guess it should not be necessary cf typing.
Error.message se.se_loc (Error.Evar_unbound n)) *)
se)
| Modname _ -> se)
| _ -> se in
se, m
(** Replaces nodes call with the call to the correct instance. *)
let edesc funs m ed =
let ed, _ = Mls_mapfold.edesc funs m ed in
let ed = match ed with
| Eapp ({ a_op = Efun ln; a_params = params } as app, e_list, r) ->
let op = Efun (node_for_params_call ln (instantiate m params)) in
Eapp ({ app with a_op = op; a_params = [] }, e_list, r)
| Eapp ({ a_op = Enode ln; a_params = params } as app, e_list, r) ->
let op = Enode (node_for_params_call ln (instantiate m params)) in
Eapp ({ app with a_op = op; a_params = [] }, e_list, r)
| Eiterator(it, ({ a_op = Efun ln; a_params = params } as app),
n, e_list, r) ->
let op = Efun (node_for_params_call ln (instantiate m params)) in
Eiterator(it, {app with a_op = op; a_params = [] }, n, e_list, r)
| Eiterator(it, ({ a_op = Enode ln; a_params = params } as app),
n, e_list, r) ->
let op = Enode (node_for_params_call ln (instantiate m params)) in
Eiterator(it,{app with a_op = op; a_params = [] }, n, e_list, r)
| _ -> ed
in ed, m
let node_dec_instance modname n params =
let global_funs =
{ Global_mapfold.defaults with static_exp = static_exp } in
let funs =
{ Mls_mapfold.defaults with edesc = edesc;
global_funs = global_funs } in
let m = build NamesEnv.empty n.n_params params in
let n, _ = Mls_mapfold.node_dec_it funs m n in
(* Add to the global environment the signature of the new instance *)
let ln = Modname { qual = modname; id = n.n_name } in
let { info = node_sig } = find_value ln in
let node_sig, _ = Global_mapfold.node_it global_funs m node_sig in
let node_sig = { node_sig with node_params = [];
node_params_constraints = [] } in
(* Find the name that was associated to this instance *)
let ln = node_for_params_call ln params in
Modules.add_value_by_longname ln node_sig;
{ n with n_name = shortname ln; n_params = []; n_params_constraints = [];}
let node_dec modname n =
let ln = Modname { qual = modname; id = n.n_name } in
List.map (node_dec_instance modname n) (get_node_instances ln)
let program p =
{ p
with p_nodes = List.flatten (List.map (node_dec p.p_modname) p.p_nodes)}
end
end
open Param_instances
type info =
{ mutable opened : program NamesEnv.t;
mutable called_nodes : ((longname * static_exp list) list) LongNameEnv.t;
mutable nodes_instances : (static_exp list list) LongNameEnv.t;
mutable nodes_names : (longname * static_exp list, longname) Hashtbl.t }
mutable called_nodes : ((longname * static_exp list) list) LongNameEnv.t; }
let info =
{ (** opened programs*)
opened = NamesEnv.empty;
(** Maps a node to the list of (node name, params) it calls *)
called_nodes = LongNameEnv.empty;
(** Maps a node to its list of instances *)
nodes_instances = LongNameEnv.empty;
(** Maps a couple (node name, params) to the name of the instantiated node*)
nodes_names = Hashtbl.create 100 }
called_nodes = LongNameEnv.empty }
(** Loads the modname.epo file. *)
let load_object_file modname =
@ -107,8 +271,7 @@ let collect_node_calls ln =
ed, add_called_node ln params acc
| _ -> raise Misc.Fallback
in
let funs = { Mls_mapfold.defaults with
edesc = edesc } in
let funs = { Mls_mapfold.defaults with edesc = edesc } in
let n = node_by_longname ln in
let _, acc = Mls_mapfold.node_dec funs [] n in
acc
@ -123,128 +286,7 @@ let called_nodes ln =
) else
LongNameEnv.find ln info.called_nodes
(** Adds a new instance of a node. [params] should not contain
any static variable. *)
let add_node_instance ln params =
if LongNameEnv.mem ln info.nodes_instances then
info.nodes_instances <- LongNameEnv.add ln
(params::(LongNameEnv.find ln info.nodes_instances)) info.nodes_instances
else
info.nodes_instances <- LongNameEnv.add ln [params] info.nodes_instances
(** @return the list of instances of a node. *)
let get_node_instances ln =
try
LongNameEnv.find ln info.nodes_instances
with
Not_found -> []
(** @return the name of the node corresponding to the instance of
[ln] with the static parameters [params]. The parameters should
be normalized using [Static.simplify] before calling this function. *)
let node_for_params_call ln params =
match params with
| [] -> ln
| _ -> Hashtbl.find info.nodes_names (ln,params)
let build env params_names params_values =
List.fold_left2 (fun m { p_name = n } v -> NamesEnv.add n v m)
env params_names params_values
(** Generates a fresh name for the the instance of
[ln] with the static parameters [params] and stores it. *)
let generate_new_name ln params =
match params with
| [] -> Hashtbl.add info.nodes_names (ln, params) ln
| _ ->
(match ln with
| Modname { qual = q; id = id } ->
let new_ln =
Modname { qual = q; (* TODO ??? c'est quoi ce nom ??? *)
(* l'utilité de fresh n'est vrai que si toute les fonctions
sont touchées.. ce qui n'est pas vrai cf main_nodes *)
(* TODO mettre les valeurs des params dans le nom *)
id = id ^ (Idents.name (Idents.fresh "")) } in
Hashtbl.add info.nodes_names (ln, params) new_ln
| _ -> assert false)
(** This module creates an instance of a node with a given
list of static parameters. *)
module Instantiate =
struct
(** Replaces static parameters with their value in the instance. *)
let static_exp funs m se =
let se, m = Global_mapfold.static_exp funs m se in
let se, m = match se.se_desc with
| Svar ln ->
let se = (match ln with
| Name n ->
(try NamesEnv.find n m
with Not_found ->
Error.message se.se_loc (Error.Evar_unbound n))
| Modname _ -> se) in
se, m
| _ -> se, m in
simplify m se, m
let global_funs = { Global_mapfold.defaults with static_exp = static_exp }
(** Replaces nodes call with the call to the correct instance. *)
let edesc funs m ed =
let ed, _ = Mls_mapfold.edesc funs m ed in
let ed = match ed with
| Eapp ({ a_op = Efun ln; a_params = params } as app, e_list, r) ->
let params = List.map (simplify m) params in
Eapp ({ app with a_op = Efun (node_for_params_call ln params);
a_params = [] }, e_list, r)
| Eapp ({ a_op = Enode ln; a_params = params } as app, e_list, r) ->
let params = List.map (simplify m) params in
Eapp ({ app with a_op = Enode (node_for_params_call ln params);
a_params = [] }, e_list, r)
| Eiterator(it, ({ a_op = Efun ln; a_params = params } as app),
n, e_list, r) ->
let params = List.map (simplify m) params in
Eiterator(it,
{ app with a_op = Efun
(node_for_params_call ln params);
a_params = [] }, n, e_list, r)
| Eiterator(it, ({ a_op = Enode ln; a_params = params } as app),
n, e_list, r) ->
let params = List.map (simplify m) params in
Eiterator
(it, { app with a_op = Enode (node_for_params_call ln params);
a_params = [] }, n, e_list, r)
| _ -> ed
in ed, m
let funs = { Mls_mapfold.defaults
with edesc = edesc; global_funs = global_funs }
let node_dec_instance m modname n params =
let m = build m n.n_params params in
let n, _ = Mls_mapfold.node_dec_it funs m n in
(* Add to the global environment the signature of the new instance *)
let ln = Modname { qual = modname; id = n.n_name } in
let { info = node_sig } = find_value ln in
let node_sig, _ = Global_mapfold.node_it global_funs m node_sig in
let node_sig = { node_sig with node_params = [];
node_params_constraints = [] } in
(* Find the name that was associated to this instance *)
let ln = node_for_params_call ln params in
Modules.add_value_by_longname ln node_sig;
{ n with n_name = shortname ln;
n_params = []; n_params_constraints = []; }
let node_dec m modname n =
let ln = Modname { qual = modname; id = n.n_name } in
List.map (node_dec_instance m modname n) (get_node_instances ln)
let program m p =
{ p with
p_nodes = List.flatten (List.map (node_dec m p.p_modname) p.p_nodes) }
end
(*
(** Checks that a static expression does not contain any static parameter. *)
let check_no_static_var se =
let static_exp_desc funs acc sed = match sed with
@ -254,49 +296,30 @@ let check_no_static_var se =
let funs = { Global_mapfold.defaults with
static_exp_desc = static_exp_desc } in
ignore (Global_mapfold.static_exp_it funs false se)
*)
(** Generates the list of instances of nodes needed to call
[ln] with static parameters [params]. *)
let rec call_node m (ln, params) =
let rec call_node (ln, params) =
(* First, add the instance for this node *)
let n = node_by_longname ln in
let m = build m n.n_params params in
List.iter check_no_static_var params;
add_node_instance ln params;
generate_new_name ln params;
let m = build NamesEnv.empty n.n_params params in
(* List.iter check_no_static_var params; *)
add_node_instance ln params;
(* Recursively generate instances for called nodes. *)
let call_list = called_nodes ln in
let call_list = List.map
(fun (ln, p) -> ln, List.map (simplify m) p) call_list in
List.iter (call_node m) call_list
(** Deal with the global const declarations of a program,
and return the associated environnment. *)
let const_decs m const_l =
let const_dec m cd =
let c_value, m =
Global_mapfold.static_exp_it Instantiate.global_funs m cd.c_value in
let c_type, m =
Global_mapfold.ty_it Instantiate.global_funs m cd.c_type in
let m = NamesEnv.add cd.c_name c_value m in
{ cd with c_value = c_value; c_type = c_type }, m in
mapfold const_dec m const_l
let type_decs m type_l =
mapfold (Mls_mapfold.type_dec_it Instantiate.funs) m type_l
(* Recursively generate instances for called nodes. *)
let call_list = called_nodes ln in
let call_list =
List.map (fun (ln, p) -> ln, instantiate m p) call_list in
List.iter call_node call_list
let program p =
(* construct the global env [m] with valued static idents *)
let p_consts, m = const_decs NamesEnv.empty p.p_consts in
let p_types, m = type_decs m p.p_types in
let p = { p with p_consts = p_consts; p_types = p_types } in
(* Find the nodes without static parameters *)
let main_nodes = List.filter (fun n -> is_empty n.n_params) p.p_nodes in
let main_nodes = List.map (fun n -> (longname n.n_name, [])) main_nodes in
info.opened <- NamesEnv.add p.p_modname p NamesEnv.empty;
(* Creates the list of instances starting from these nodes *)
List.iter (call_node m) main_nodes;
List.iter call_node main_nodes;
let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in
(* Generate all the needed instances *)
List.map (Instantiate.program m) p_list
List.map Param_instances.Instantiate.program p_list

10
compiler/utilities/misc.ml
View file

@ -179,6 +179,16 @@ let rec split_last = function
let remove x l =
List.filter (fun y -> x <> y) l
let make_list_compare c l1 l2 =
let rec aux l1 l2 = match (l1, l2) with
| (h1::t1, h2::t2) ->
let result = c h1 h2 in
if result = 0 then aux t1 t2 else result
| ([], [] ) -> 0
| (_, [] ) -> 1
| ([], _ ) -> -1
in aux l1 l2
let is_empty = function
| [] -> true
| _ -> false

7
compiler/utilities/misc.mli
View file

@ -163,7 +163,12 @@ val repeat_list : 'a -> int -> 'a list
val memd_assoc : 'b -> ('a * 'b) list -> bool
(** Same as List.assoc but searching for a data and returning the key. *)
val assocd: 'b -> ('a * 'b) list -> 'a
val assocd : 'b -> ('a * 'b) list -> 'a
(** [make_compare c] generates the lexicographical compare function on lists
induced by [c] *)
val make_list_compare : ('a -> 'a -> int) -> 'a list -> 'a list -> int
(** Ast iterators *)

19
test/good/statics.ept
View file

@ -1,9 +1,11 @@
(* Check manually *)
(* This test should only create two instances of f. *)
const c:int = 3
const k:int = 1
fun f<<n:int>>() returns (y:int)
let
y = n + 3;
y = n + 3 + c;
tel
fun g<<m:int>>() returns (y:int)
@ -13,8 +15,17 @@ let
y = f<<m>>();
tel
fun h() returns (y:int)
fun i<<m:int>>() returns (o : int)
var x, y, z: int;
let
y = c + g<<c>>();
x = f<<2>>();
y = f<<1 + m>>();
z = f<<k + 1>>();
o = f<<m + k>>();
tel
fun h() returns (y:int)
let
y = c + g<<c>>() + i<<k>>();
tel