From a3ac71174ccce588022c849aa873dd1b47eefac0 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= Date: Tue, 17 Aug 2010 18:30:37 +0200 Subject: [PATCH] Static exp instantiation fix. --- compiler/global/global_mapfold.ml | 44 ++++++++++++++----- compiler/minils/mls_mapfold.ml | 4 +- .../transformations/callgraph_mapfold.ml | 20 +++++---- 3 files changed, 47 insertions(+), 21 deletions(-) diff --git a/compiler/global/global_mapfold.ml b/compiler/global/global_mapfold.ml index 2052398..6e4c5eb 100644 --- a/compiler/global/global_mapfold.ml +++ b/compiler/global/global_mapfold.ml @@ -1,5 +1,6 @@ open Misc open Types +(*open Clocks*) open Signature type 'a global_it_funs = { @@ -7,21 +8,20 @@ type 'a global_it_funs = { 'a global_it_funs -> 'a -> static_exp -> static_exp * 'a; static_exp_desc : 'a global_it_funs -> 'a -> static_exp_desc -> static_exp_desc * 'a; - ty : - 'a global_it_funs -> 'a -> ty -> ty * 'a; - param: - 'a global_it_funs -> 'a -> param -> param * 'a; + ty : 'a global_it_funs -> 'a -> ty -> ty * 'a; +(* ct : 'a global_it_funs -> 'a -> ct -> ct * 'a; + ck : 'a global_it_funs -> 'a -> ck -> ck * 'a; + link : 'a global_it_funs -> 'a -> link -> link * 'a; *) + param: 'a global_it_funs -> 'a -> param -> param * 'a; arg: 'a global_it_funs -> 'a -> arg -> arg * 'a; node : 'a global_it_funs -> 'a -> node -> node * 'a; - structure: - 'a global_it_funs -> 'a -> structure -> structure * 'a; - field: - 'a global_it_funs -> 'a -> field -> field * 'a; } + structure: 'a global_it_funs -> 'a -> structure -> structure * 'a; + field: 'a global_it_funs -> 'a -> field -> field * 'a; } let rec static_exp_it funs acc se = funs.static_exp funs acc se and static_exp funs acc se = - let se_desc, acc = static_exp_desc_it funs acc se.se_desc in let se_ty, acc = ty_it funs acc se.se_ty in + let se_desc, acc = static_exp_desc_it funs acc se.se_desc in { se with se_desc = se_desc; se_ty = se_ty }, acc and static_exp_desc_it funs acc sd = @@ -58,6 +58,30 @@ and ty funs acc t = match t with let se, acc = static_exp_it funs acc se in Tarray (t, se), acc +(* +and ct_it funs acc c = try funs.ct funs acc c with Fallback -> ct funs acc t +and ct funs acc c = match c with + | Ck(ck) -> let ck, acc = ck_it funs acc ck in Ck ck, acc + | Cprod(ct_l) -> + let ct_l, acc = mapfold (ct_it funs) acc ct_l in Cprod ct_l, acc + +and ck_it funs acc c = try funs.ck funs acc c with Fallback -> ck funs acc c +and ck funs acc c = match c with + | Cbase -> c, acc + | Cvar(link_ref) -> + let l, acc = link_it funs acc link_ref.contents in + Cvar {link_ref with contents = l}, acc + | Con(ck, constructor_name, var_ident) -> + let ck, acc = ck_it funs acc ck in + Con (ck, constructor_name, var_ident), acc + +and link_it funs acc c = + try funs.link funs acc c with Fallback -> link funs acc c +and link funs acc l = match l with + | Cindex _ -> l, acc + | Clink(ck) -> let ck, acc = ck_it funs acc ck in Clink ck, acc +*) + and structure_it funs acc s = funs.structure funs acc s and structure funs acc s = mapfold (field_it funs) acc s @@ -102,7 +126,7 @@ let defaults = { } -(* Used to stop the pass at this level *) +(** Is used to stop the pass at this level *) let stop funs acc x = x, acc let defaults_stop = { diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index 66cafaa..e3a98d2 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -12,8 +12,8 @@ open Global_mapfold open Minils (* /!\ do never, never put in your funs record one - of the generic iterator function (_omega), - either yours either the _default version *) + of the generic iterator function (_it), + either yours either the default version named according to the type. *) type 'a mls_it_funs = { app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a; diff --git a/compiler/minils/transformations/callgraph_mapfold.ml b/compiler/minils/transformations/callgraph_mapfold.ml index b9b82a6..a28d789 100644 --- a/compiler/minils/transformations/callgraph_mapfold.ml +++ b/compiler/minils/transformations/callgraph_mapfold.ml @@ -170,16 +170,18 @@ let generate_new_name ln params = module Instantiate = struct (** Replaces static parameters with their value in the instance. *) - let static_exp funs m se = 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 + let static_exp funs m se = + let se, m = Global_mapfold.static_exp funs m se in + 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 - | _ -> Global_mapfold.static_exp funs m se + | _ -> se, m (** Replaces nodes call with the call to the correct instance. *) let edesc funs m ed =