From c4a926f4899923dcc5d6f383586bc272e73c5194 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Tue, 24 Aug 2010 11:07:05 +0200 Subject: [PATCH] Correct Mapfold !! Or at least much more than before. 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 ? --- .../transformations/callgraph_mapfold.ml | 349 ++++++++++-------- compiler/utilities/misc.ml | 10 + compiler/utilities/misc.mli | 7 +- test/good/statics.ept | 19 +- 4 files changed, 217 insertions(+), 168 deletions(-) diff --git a/compiler/minils/transformations/callgraph_mapfold.ml b/compiler/minils/transformations/callgraph_mapfold.ml index fb7dc2f..96ac213 100644 --- a/compiler/minils/transformations/callgraph_mapfold.ml +++ b/compiler/minils/transformations/callgraph_mapfold.ml @@ -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 diff --git a/compiler/utilities/misc.ml b/compiler/utilities/misc.ml index f0546c9..9142f25 100644 --- a/compiler/utilities/misc.ml +++ b/compiler/utilities/misc.ml @@ -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 diff --git a/compiler/utilities/misc.mli b/compiler/utilities/misc.mli index 0161b4c..a1b43f5 100644 --- a/compiler/utilities/misc.mli +++ b/compiler/utilities/misc.mli @@ -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 *) diff --git a/test/good/statics.ept b/test/good/statics.ept index 193aba0..2bb07b1 100644 --- a/test/good/statics.ept +++ b/test/good/statics.ept @@ -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<>() returns (y:int) let - y = n + 3; + y = n + 3 + c; tel fun g<>() returns (y:int) @@ -13,8 +15,17 @@ let y = f<>(); tel -fun h() returns (y:int) +fun i<>() returns (o : int) +var x, y, z: int; let - y = c + g<>(); + x = f<<2>>(); + y = f<<1 + m>>(); + z = f<>(); + o = f<>(); +tel + +fun h() returns (y:int) +let + y = c + g<>() + i<>(); tel