From 9eaafe9736eb2ee01a8f0a1933c45aeb9cffe91b Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?L=C3=A9onard=20G=C3=A9rard?= Date: Thu, 26 Aug 2010 13:55:29 +0200 Subject: [PATCH] replaced mapfold with callgraph_mapfold. And the fixes to compile. --- compiler/main/hept2mls.ml | 3 +- compiler/minils/main/mls2seq.ml | 4 +- compiler/minils/minils.ml | 8 +- compiler/minils/transformations/callgraph.ml | 412 +++++++++++++----- .../transformations/callgraph_mapfold.ml | 325 -------------- 5 files changed, 314 insertions(+), 438 deletions(-) delete mode 100644 compiler/minils/transformations/callgraph_mapfold.ml diff --git a/compiler/main/hept2mls.ml b/compiler/main/hept2mls.ml index d75f4db..42a231f 100644 --- a/compiler/main/hept2mls.ml +++ b/compiler/main/hept2mls.ml @@ -381,8 +381,7 @@ let node n_equs = l_eqs; n_loc = loc ; n_params = params; - n_params_constraints = params_constr; - n_params_instances = []; } + n_params_constraints = params_constr } let typedec {Heptagon.t_name = n; Heptagon.t_desc = tdesc; Heptagon.t_loc = loc} = diff --git a/compiler/minils/main/mls2seq.ml b/compiler/minils/main/mls2seq.ml index 6b75c77..00c9975 100644 --- a/compiler/minils/main/mls2seq.ml +++ b/compiler/minils/main/mls2seq.ml @@ -60,10 +60,10 @@ let generate_target p s = let o = Mls2obc.program p in convert_fun o | Minils_no_params convert_fun -> - let p_list = Callgraph_mapfold.program p in + let p_list = Callgraph.program p in List.iter convert_fun p_list | Obc_no_params convert_fun -> - let p_list = Callgraph_mapfold.program p in + let p_list = Callgraph.program p in let o_list = List.map Mls2obc.program p_list in print_unfolded p_list; if !Misc.verbose then diff --git a/compiler/minils/minils.ml b/compiler/minils/minils.ml index 8700797..a63d3a4 100644 --- a/compiler/minils/minils.ml +++ b/compiler/minils/minils.ml @@ -111,9 +111,8 @@ type node_dec = { n_local : var_dec list; n_equs : eq list; n_loc : location; - n_params : param list; (** TODO CP mettre des petits commentaires *) - n_params_constraints : size_constraint list; - n_params_instances : (static_exp list) list } + n_params : param list; + n_params_constraints : size_constraint list } type const_dec = { c_name : name; @@ -151,8 +150,7 @@ let mk_node n_equs = eq; n_loc = loc; n_params = param; - n_params_constraints = constraints; - n_params_instances = pinst; } + n_params_constraints = constraints } let mk_type_dec ?(type_desc = Type_abs) ?(loc = no_location) name = { t_name = name; t_desc = type_desc; t_loc = loc } diff --git a/compiler/minils/transformations/callgraph.ml b/compiler/minils/transformations/callgraph.ml index 2a27028..6d0c124 100644 --- a/compiler/minils/transformations/callgraph.ml +++ b/compiler/minils/transformations/callgraph.ml @@ -1,121 +1,325 @@ -open Misc -open Minils open Names -open Idents -open Format +open Types +open Misc open Location -open Format -open Static open Signature +open Modules +open Static +open Global_mapfold +open Mls_mapfold +open Minils -let nodes_instances = ref NamesEnv.empty -let global_env = ref NamesEnv.empty +module Error = +struct + type error = + | Enode_unbound of longname + | Epartial_instanciation of static_exp -let rec string_of_int_list = function - | [] -> "" - | [n] -> (string_of_int n) - | n::l -> (string_of_int n)^", "^(string_of_int_list l) + let message loc kind = + begin match kind with + | Enode_unbound ln -> + Format.eprintf "%aUnknown node '%s'@." + print_location loc + (fullname ln) + | Epartial_instanciation se -> + Format.eprintf "%aUnable to fully instanciate the static exp '%a'@." + print_location se.se_loc + print_static_exp se + end; + raise Misc.Error +end -let add_node_params n params = - if NamesEnv.mem n !nodes_instances then - nodes_instances := NamesEnv.add n - (params::(NamesEnv.find n !nodes_instances)) !nodes_instances - else - nodes_instances := NamesEnv.add n [params] !nodes_instances +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 -let rec node_by_name s = function - | [] -> raise Not_found - | n::l -> - if n.n_name = s then - n - else - node_by_name s l + (** 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 -let build env params_names params_values = - List.fold_left2 (fun m { p_name = n } v -> NamesEnv.add n (Sconst v) m) - env params_names params_values + module S = (** Instances set *) + Set.Make( + struct + type t = instance + let compare = compare_instances + end) -let rec collect_exp nodes env e = - match e.e_desc with - | Emerge(_, c_e_list) -> - List.iter (fun (_, e) -> collect_exp nodes env e) c_e_list - | Eifthenelse(e1, e2, e3) -> - collect_exp nodes env e1; - collect_exp nodes env e2; - collect_exp nodes env e3 - | Ewhen(e, _, _) | Efby(_, e) | Efield(e, _) -> - collect_exp nodes env e - | Evar _ | Econstvar _ | Econst _ -> () - | Estruct(f_e_list) -> - List.iter (fun (_, e) -> collect_exp nodes env e) f_e_list - | Etuple e_list | Earray e_list -> - List.iter (collect_exp nodes env) e_list - | Efield_update(_, e1, e2) -> - collect_exp nodes env e1; - collect_exp nodes env e2 - (* Do the real work: call node *) - | Ecall( { op_name = ln; op_params = params; op_kind = _ }, - e_list, _) -> - List.iter (collect_exp nodes env) e_list; - let params = List.map (int_of_static_exp env) params in - call_node_instance nodes ln params - | Earray_op op -> - collect_array_exp nodes env op + 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) -and collect_array_exp nodes env = function - | Eselect_dyn (e_list, e1, e2) -> - List.iter (collect_exp nodes env) e_list; - collect_exp nodes env e1; - collect_exp nodes env e2 - | Eupdate (_, e1, e2) | Econcat (e1, e2) -> - collect_exp nodes env e1; - collect_exp nodes env e2 - | Eselect (_,e) | Eselect_slice (_ , _, e) | Erepeat (_,e) -> - collect_exp nodes env e - | Eiterator (_, { op_name = ln; op_params = params }, _, e_list, _) -> - List.iter (collect_exp nodes env) e_list; - let params = List.map (int_of_static_exp env) params in - call_node_instance nodes ln params + (** Maps a couple (node name, params) to the name of the instantiated node *) + let nodes_names = ref M.empty -and collect_eqs nodes env eq = - collect_exp nodes env eq.eq_rhs + (** Maps a node to its list of instances *) + let nodes_instances = ref LongNameEnv.empty -and call_node_instance nodes ln params = - match params with - | [] -> () - | params -> - let n = node_by_name (shortname ln) nodes in - node_call nodes n params + (** create a params instance *) + let instantiate m se = + try List.map (eval m) se + with Partial_instanciation se -> + Error.message no_location (Error.Epartial_instanciation se) -and node_call nodes n params = - match params with - | [] -> - List.iter (collect_eqs nodes !global_env) n.n_equs - | params -> - add_node_params n.n_name params; - let env = build !global_env n.n_params params in - List.iter (collect_eqs nodes env) n.n_equs + (** @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 -let node n = - let inst = - if NamesEnv.mem n.n_name !nodes_instances then - NamesEnv.find n.n_name !nodes_instances - else - [] in - { n with n_params_instances = inst } + (** 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) -let build_const_env cd_list = - List.fold_left (fun env cd -> NamesEnv.add - cd.Minils.c_name cd.Minils.c_value env) - NamesEnv.empty cd_list + (** 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 *) + 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; } + +let info = + { (** opened programs*) + opened = NamesEnv.empty; + (** Maps a node to the list of (node name, params) it calls *) + called_nodes = LongNameEnv.empty } + +(** Loads the modname.epo file. *) +let load_object_file modname = + Modules.open_module modname; + let name = String.uncapitalize modname in + try + let filename = Modules.findfile (name ^ ".epo") in + let ic = open_in_bin filename in + try + let p:program = input_value ic in + if p.p_format_version <> minils_format_version then ( + Format.eprintf "The file %s was compiled with \ + an older version of the compiler.\n \ + Please recompile %s.ept first.\n" filename name; + raise Error + ); + close_in ic; + info.opened <- NamesEnv.add p.p_modname p info.opened + with + | End_of_file | Failure _ -> + close_in ic; + Format.eprintf "Corrupted object file %s.\n\ + Please recompile %s.ept first.\n" filename name; + raise Error + with + | Modules.Cannot_find_file(filename) -> + Format.eprintf "Cannot find the object file '%s'.\n" + filename; + raise Error + +(** @return the node with name [ln], loading the corresponding + object file if necessary. *) +let node_by_longname ln = + match ln with + | Modname { qual = q; id = id } -> + if not (NamesEnv.mem q info.opened) then + load_object_file q; + (try + let p = NamesEnv.find q info.opened in + List.find (fun n -> n.n_name = id) p.p_nodes + with + Not_found -> Error.message no_location (Error.Enode_unbound ln)) + | _ -> assert false + +(** @return the list of nodes called by the node named [ln], with the + corresponding params (static parameters appear as free variables). *) +let collect_node_calls ln = + let add_called_node ln params acc = + match params with + | [] -> acc + | _ -> + (match ln with + | Modname { qual = "Pervasives" } -> acc + | _ -> (ln, params)::acc) + in + let edesc funs acc ed = match ed with + | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) -> + ed, add_called_node ln params acc + | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, + _, _, _) -> + ed, add_called_node ln params acc + | _ -> raise Misc.Fallback + 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 + +(** @return the list of nodes called by the node named [ln]. This list is + computed lazily the first time it is needed. *) +let called_nodes ln = + if not (LongNameEnv.mem ln info.called_nodes) then ( + let called = collect_node_calls ln in + info.called_nodes <- LongNameEnv.add ln called info.called_nodes; + called + ) else + LongNameEnv.find ln info.called_nodes + +(* +(** 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 + | Svar (Name n) -> Error.message se.se_loc (Error.Evar_unbound n) + | _ -> raise Misc.Fallback + in + 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 (ln, params) = + (* First, add the instance for this node *) + let n = node_by_longname ln in + 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, instantiate m p) call_list in + List.iter call_node call_list let program p = - let try_call_node n = - match n.n_params with - | [] -> node_call p.p_nodes n [] - | _ -> () - in - global_env := build_const_env p.p_consts; - List.iter try_call_node p.p_nodes; - { p with p_nodes = List.map node p.p_nodes } - + (* 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 main_nodes; + let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in + (* Generate all the needed instances *) + List.map Param_instances.Instantiate.program p_list diff --git a/compiler/minils/transformations/callgraph_mapfold.ml b/compiler/minils/transformations/callgraph_mapfold.ml deleted file mode 100644 index 6d0c124..0000000 --- a/compiler/minils/transformations/callgraph_mapfold.ml +++ /dev/null @@ -1,325 +0,0 @@ -open Names -open Types -open Misc -open Location -open Signature -open Modules -open Static -open Global_mapfold -open Mls_mapfold -open Minils - -module Error = -struct - type error = - | Enode_unbound of longname - | Epartial_instanciation of static_exp - - let message loc kind = - begin match kind with - | Enode_unbound ln -> - Format.eprintf "%aUnknown node '%s'@." - print_location loc - (fullname ln) - | Epartial_instanciation se -> - Format.eprintf "%aUnable to fully instanciate the static exp '%a'@." - print_location se.se_loc - print_static_exp se - end; - 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 = - try List.map (eval m) se - with Partial_instanciation se -> - Error.message no_location (Error.Epartial_instanciation 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 *) - 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; } - -let info = - { (** opened programs*) - opened = NamesEnv.empty; - (** Maps a node to the list of (node name, params) it calls *) - called_nodes = LongNameEnv.empty } - -(** Loads the modname.epo file. *) -let load_object_file modname = - Modules.open_module modname; - let name = String.uncapitalize modname in - try - let filename = Modules.findfile (name ^ ".epo") in - let ic = open_in_bin filename in - try - let p:program = input_value ic in - if p.p_format_version <> minils_format_version then ( - Format.eprintf "The file %s was compiled with \ - an older version of the compiler.\n \ - Please recompile %s.ept first.\n" filename name; - raise Error - ); - close_in ic; - info.opened <- NamesEnv.add p.p_modname p info.opened - with - | End_of_file | Failure _ -> - close_in ic; - Format.eprintf "Corrupted object file %s.\n\ - Please recompile %s.ept first.\n" filename name; - raise Error - with - | Modules.Cannot_find_file(filename) -> - Format.eprintf "Cannot find the object file '%s'.\n" - filename; - raise Error - -(** @return the node with name [ln], loading the corresponding - object file if necessary. *) -let node_by_longname ln = - match ln with - | Modname { qual = q; id = id } -> - if not (NamesEnv.mem q info.opened) then - load_object_file q; - (try - let p = NamesEnv.find q info.opened in - List.find (fun n -> n.n_name = id) p.p_nodes - with - Not_found -> Error.message no_location (Error.Enode_unbound ln)) - | _ -> assert false - -(** @return the list of nodes called by the node named [ln], with the - corresponding params (static parameters appear as free variables). *) -let collect_node_calls ln = - let add_called_node ln params acc = - match params with - | [] -> acc - | _ -> - (match ln with - | Modname { qual = "Pervasives" } -> acc - | _ -> (ln, params)::acc) - in - let edesc funs acc ed = match ed with - | Eapp ({ a_op = (Enode ln | Efun ln); a_params = params }, _, _) -> - ed, add_called_node ln params acc - | Eiterator(_, { a_op = (Enode ln | Efun ln); a_params = params }, - _, _, _) -> - ed, add_called_node ln params acc - | _ -> raise Misc.Fallback - 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 - -(** @return the list of nodes called by the node named [ln]. This list is - computed lazily the first time it is needed. *) -let called_nodes ln = - if not (LongNameEnv.mem ln info.called_nodes) then ( - let called = collect_node_calls ln in - info.called_nodes <- LongNameEnv.add ln called info.called_nodes; - called - ) else - LongNameEnv.find ln info.called_nodes - -(* -(** 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 - | Svar (Name n) -> Error.message se.se_loc (Error.Evar_unbound n) - | _ -> raise Misc.Fallback - in - 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 (ln, params) = - (* First, add the instance for this node *) - let n = node_by_longname ln in - 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, instantiate m p) call_list in - List.iter call_node call_list - -let program p = - (* 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 main_nodes; - let p_list = NamesEnv.fold (fun _ p l -> p::l) info.opened [] in - (* Generate all the needed instances *) - List.map Param_instances.Instantiate.program p_list