From 57751992c076508b54f0756cb2025dcd869ba789 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?Le=CC=81onard=20Ge=CC=81rard?= Date: Wed, 14 Jul 2010 02:31:31 +0200 Subject: [PATCH] Rebase done : Mls re-ported. Mls_mapfold and mls_utils updated. --- compiler/minils/mls_mapfold.ml | 35 +++---- compiler/minils/mls_printer.ml | 2 +- compiler/minils/mls_utils.ml | 94 ++++++------------- .../transformations/callgraph_mapfold.ml | 11 ++- 4 files changed, 53 insertions(+), 89 deletions(-) diff --git a/compiler/minils/mls_mapfold.ml b/compiler/minils/mls_mapfold.ml index e32d090..b904065 100644 --- a/compiler/minils/mls_mapfold.ml +++ b/compiler/minils/mls_mapfold.ml @@ -16,24 +16,19 @@ open Minils either yours either the _default version *) type 'a mls_it_funs = { - app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a; - edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a; - eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * 'a; - exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a; - pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a; - var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a; - contract: - 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a; - node_dec: - 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a; - const_dec: - 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a; - type_dec: - 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a; - tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a; - program: - 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a; - global_funs: 'a Global_mapfold.global_it_funs } + app: 'a mls_it_funs -> 'a -> Minils.app -> Minils.app * 'a; + edesc: 'a mls_it_funs -> 'a -> Minils.edesc -> Minils.edesc * 'a; + eq: 'a mls_it_funs -> 'a -> Minils.eq -> Minils.eq * 'a; + exp: 'a mls_it_funs -> 'a -> Minils.exp -> Minils.exp * 'a; + pat: 'a mls_it_funs -> 'a -> Minils.pat -> Minils.pat * 'a; + var_dec: 'a mls_it_funs -> 'a -> Minils.var_dec -> Minils.var_dec * 'a; + contract: 'a mls_it_funs -> 'a -> Minils.contract -> Minils.contract * 'a; + node_dec: 'a mls_it_funs -> 'a -> Minils.node_dec -> Minils.node_dec * 'a; + const_dec: 'a mls_it_funs -> 'a -> Minils.const_dec -> Minils.const_dec * 'a; + type_dec: 'a mls_it_funs -> 'a -> Minils.type_dec -> Minils.type_dec * 'a; + tdesc: 'a mls_it_funs -> 'a -> Minils.tdesc -> Minils.tdesc * 'a; + program: 'a mls_it_funs -> 'a -> Minils.program -> Minils.program * 'a; + global_funs:'a Global_mapfold.global_it_funs } let rec exp_it funs acc e = funs.exp funs acc e @@ -165,7 +160,7 @@ and program funs acc p = let nd_list, acc = mapfold (node_dec_it funs) acc p.p_nodes in { p with p_types = td_list; p_consts = cd_list; p_nodes = nd_list }, acc -let mls_funs_default = { +let defaults = { app = app; edesc = edesc; eq = eq; @@ -178,4 +173,4 @@ let mls_funs_default = { type_dec = type_dec; tdesc = tdesc; program = program; - global_funs = Global_mapfold.global_funs_default } + global_funs = Global_mapfold.defaults } diff --git a/compiler/minils/mls_printer.ml b/compiler/minils/mls_printer.ml index 396a188..472caad 100644 --- a/compiler/minils/mls_printer.ml +++ b/compiler/minils/mls_printer.ml @@ -210,7 +210,7 @@ let print oc { p_opened = pm; p_types = pt; p_nodes = pn; p_consts = pc } = let ff = formatter_of_out_channel oc in ( List.iter (print_open_module ff) pm; - List.iter (print_type_def ff) pt; + List.iter (print_type_dec ff) pt; List.iter (print_const_dec ff) pc; List.iter (print_node ff) pn; fprintf ff "@?" ) diff --git a/compiler/minils/mls_utils.ml b/compiler/minils/mls_utils.ml index d318319..a03bf6f 100644 --- a/compiler/minils/mls_utils.ml +++ b/compiler/minils/mls_utils.ml @@ -55,8 +55,7 @@ let is_op = function module Vars = struct - let add x acc = - if List.mem x acc then acc else x :: acc + let add x acc = if List.mem x acc then acc else x :: acc let rec vars_pat acc = function | Evarpat x -> x :: acc @@ -67,54 +66,26 @@ struct | Cbase | Cvar { contents = Cindex _ } -> acc | Cvar { contents = Clink ck } -> vars_ck acc ck - let rec read is_left acc e = - let acc = - match e.e_desc with - | Evar n -> add n acc - | Emerge(x, c_e_list) -> - let acc = add x acc in - List.fold_left (fun acc (_, e) -> read is_left acc e) acc c_e_list - | Eifthenelse(e1, e2, e3) -> - read is_left (read is_left (read is_left acc e1) e2) e3 - | Ewhen(e, c, x) -> - let acc = add x acc in - read is_left acc e - | Etuple(e_list) -> List.fold_left (read is_left) acc e_list - | Ecall(_, e_list, None) -> - List.fold_left (read is_left) acc e_list - | Ecall(_, e_list, Some x) -> - let acc = add x acc in - List.fold_left (read is_left) acc e_list - | Efby(_, e) -> - if is_left then vars_ck acc e.e_ck else read is_left acc e - | Efield(e, _) -> read is_left acc e - | Estruct(f_e_list) -> - List.fold_left (fun acc (_, e) -> read is_left acc e) acc f_e_list - | Econst _ | Econstvar _ -> acc - | Efield_update (_, e1, e2) -> - read is_left (read is_left acc e1) e2 - (*Array operators*) - | Earray e_list -> List.fold_left (read is_left) acc e_list - | Earray_op op -> read_array_op is_left acc op + let read_exp read_funs (is_left, acc) e = + (* recursive call *) + let _,(_, acc) = Mls_mapfold.exp read_funs (is_left, acc) e in + (* special cases *) + let acc = match e.e_desc with + | Evar x | Emerge(x,_) | Ewhen(_, _, x) + | Eapp(_, _, Some x) | Eiterator (_, _, _, _, Some x) -> + add x acc + | Efby(_, e) -> + if is_left then vars_ck acc e.e_ck else acc + | _ -> acc in - vars_ck acc e.e_ck + e, (is_left, vars_ck acc e.e_ck) - and read_array_op is_left acc = function - | Erepeat (_,e) -> read is_left acc e - | Eselect (_,e) -> read is_left acc e - | Eselect_dyn (e_list, e1, e2) -> - let acc = List.fold_left (read is_left) acc e_list in - read is_left (read is_left acc e1) e2 - | Eupdate (_, e1, e2) -> - read is_left (read is_left acc e1) e2 - | Eselect_slice (_ , _, e) -> read is_left acc e - | Econcat (e1, e2) -> - read is_left (read is_left acc e1) e2 - | Eiterator (_, _, _, e_list, None) -> - List.fold_left (read is_left) acc e_list - | Eiterator (_, _, _, e_list, Some x) -> - let acc = add x acc in - List.fold_left (read is_left) acc e_list + let read_exp is_left acc e = + let _, (_, acc) = + Mls_mapfold.exp_it + { Mls_mapfold.defaults with Mls_mapfold.exp = read_exp } + (is_left, acc) e in + acc let rec remove x = function | [] -> [] @@ -122,21 +93,19 @@ struct let def acc { eq_lhs = pat } = vars_pat acc pat - let read is_left { eq_lhs = pat; eq_rhs = e } = - match pat, e.e_desc with - | Evarpat(n), Efby(_, e1) -> - if is_left - then remove n (read is_left [] e1) - else read is_left [] e1 - | _ -> read is_left [] e + let read is_left { eq_lhs = pat; eq_rhs = e } = match pat, e.e_desc with + | Evarpat(n), Efby(_, e1) -> + if is_left + then remove n (read_exp is_left [] e1) + else read_exp is_left [] e1 + | _ -> read_exp is_left [] e let antidep { eq_rhs = e } = match e.e_desc with Efby _ -> true | _ -> false - let clock { eq_rhs = e } = - match e.e_desc with - | Emerge(_, (_, e) :: _) -> e.e_ck - | _ -> e.e_ck + let clock { eq_rhs = e } = match e.e_desc with + | Emerge(_, (_, e) :: _) -> e.e_ck + | _ -> e.e_ck let head ck = let rec headrec ck l = @@ -149,10 +118,9 @@ struct (** Returns a list of memory vars (x in x = v fby e) appearing in an equation. *) - let memory_vars ({ eq_lhs = _; eq_rhs = e } as eq) = - match e.e_desc with - | Efby(_, _) -> def [] eq - | _ -> [] + let memory_vars ({ eq_lhs = _; eq_rhs = e } as eq) = match e.e_desc with + | Efby(_, _) -> def [] eq + | _ -> [] end diff --git a/compiler/minils/transformations/callgraph_mapfold.ml b/compiler/minils/transformations/callgraph_mapfold.ml index 8795068..a67b769 100644 --- a/compiler/minils/transformations/callgraph_mapfold.ml +++ b/compiler/minils/transformations/callgraph_mapfold.ml @@ -89,7 +89,7 @@ let collect_node_calls ln = | _ -> ed, (ln, params)::acc) | _ -> raise Misc.Fallback in - let funs = { Mls_mapfold.mls_funs_default with + 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 @@ -165,9 +165,9 @@ struct | _ -> assert false) let node_dec_instance modname n params = - let global_funs = { global_funs_default with + let global_funs = { Global_mapfold.defaults with static_exp = static_exp } in - let funs = { Mls_mapfold.mls_funs_default with + let funs = { Mls_mapfold.defaults with edesc = edesc; global_funs = global_funs } in let m = build NamesEnv.empty n.n_params params in @@ -185,7 +185,8 @@ struct 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) } + { p + with p_nodes = List.flatten (List.map (node_dec p.p_modname) p.p_nodes) } end let check_no_static_var se = @@ -193,7 +194,7 @@ let check_no_static_var se = | Svar (Name n) -> Error.message se.se_loc (Error.Evar_unbound n) | _ -> raise Misc.Fallback in - let funs = { Global_mapfold.global_funs_default with + let funs = { Global_mapfold.defaults with static_exp_desc = static_exp_desc } in ignore (Global_mapfold.static_exp_it funs false se)