Commit 7d6106d0 authored by Gwenaël Delaval's avatar Gwenaël Delaval

Passes optimization

Translation to tail-recursive versions of functions
for handling of (very) big nodes.
parent b9870eef
......@@ -42,11 +42,15 @@ let cand c1 c2 =
match c1, c2 with
| Cempty, _ -> c2 | _, Cempty -> c1
| c1, c2 -> Cand(c1, c2)
let rec candlist l =
let candlist l =
let rec candlist_aux acc l =
match l with
| [] -> acc
| [c] -> cand acc c
| c1 :: l -> candlist_aux (cand c1 acc) l in
match l with
| [] -> Cempty
| [c] -> c
| c1 :: l -> cand c1 (candlist l)
| [] -> Cempty
| c :: l -> candlist_aux c l
let ctuplelist l = match l with
| [c] -> c
......@@ -185,7 +189,7 @@ let rec typing_pat = function
candlist (List.map typing_pat pat_list)
(** Typing equations *)
let rec typing_eqs eq_list = candlist (List.map typing_eq eq_list)
let rec typing_eqs eq_list = candlist (List.rev_map typing_eq eq_list)
and typing_eq eq =
match eq.eq_desc with
......
......@@ -403,7 +403,7 @@ and translate_eq_desc loc env = function
and translate_block env b =
let env = Rename.append env b.b_local in
{ Heptagon.b_local = translate_vd_list env b.b_local;
Heptagon.b_equs = List.map (translate_eq env) b.b_equs;
Heptagon.b_equs = List.rev_map (translate_eq env) b.b_equs;
Heptagon.b_defnames = Env.empty;
Heptagon.b_stateful = false;
Heptagon.b_loc = b.b_loc; }, env
......@@ -442,8 +442,8 @@ and translate_var_dec env vd =
Heptagon.v_loc = vd.v_loc }
(** [env] should contain the declared variables prior to this translation *)
and translate_vd_list env =
List.map (translate_var_dec env)
and translate_vd_list env v_list =
List.rev (List.rev_map (translate_var_dec env) v_list)
and translate_last = function
| Var -> Heptagon.Var
......
......@@ -74,8 +74,8 @@ let complete_with_last defined_names local_defined_names eq_list =
let block funs defnames b =
let b, _ = Hept_mapfold.block funs Env.empty b in (*recursive call*)
let added_eq = complete_with_last defnames b.b_defnames [] in
{ b with b_equs = b.b_equs @ added_eq; b_defnames = defnames }
let eqs = complete_with_last defnames b.b_defnames b.b_equs in
{ b with b_equs = eqs; b_defnames = defnames }
, defnames
let eqdesc funs _ ed = match ed with
......
......@@ -52,7 +52,8 @@ let last (eq_list, env, v) { v_ident = n; v_type = t; v_linearity = lin; v_last
Env.add n lastn env,
(mk_var_dec lastn t ~linearity:lin) :: v
let extend_env env v = List.fold_left last ([], env, []) v
let extend_env env eq_list acc_vd vd_list =
List.fold_left last (eq_list, env, acc_vd) vd_list
let edesc _ env ed = match ed with
| Elast x ->
......@@ -60,19 +61,21 @@ let edesc _ env ed = match ed with
| _ -> raise Errors.Fallback
let block funs env b =
let eq_lastn_n_list, env, last_v = extend_env env b.b_local in
let eq_list, env, vd_list = extend_env env b.b_equs b.b_local b.b_local in
let b, _ = Hept_mapfold.block funs env b in
{ b with b_local = b.b_local @ last_v;
b_equs = eq_lastn_n_list @ b.b_equs }, env
{ b with b_local = vd_list;
b_equs = eq_list },
env
let node_dec funs _ n =
Idents.enter_node n.n_name;
let _, env, _ = extend_env Env.empty n.n_input in
let eq_lasto_list, env, last_o = extend_env env n.n_output in
let { n_block } = n in
let _, env, _ = extend_env Env.empty [] [] n.n_input in
let eq_list, env, vd_list = extend_env env n_block.b_equs n_block.b_local n.n_output in
let n, _ = Hept_mapfold.node_dec funs env n in
{ n with n_block =
{ n.n_block with b_local = n.n_block.b_local @ last_o;
b_equs = eq_lasto_list @ n.n_block.b_equs } }, env
{ n_block with b_local = vd_list;
b_equs = eq_list } }, env
let program p =
let funs = { Hept_mapfold.defaults with
......
......@@ -209,8 +209,8 @@ let translate_contract contract =
Heptagon.c_assume_loc = e_a_loc;
Heptagon.c_enforce_loc = e_g_loc;
Heptagon.c_controllables = l_c } ->
Some { c_local = List.map translate_var v;
c_eq = List.map translate_eq eq_list;
Some { c_local = List.rev_map translate_var v;
c_eq = List.rev_map translate_eq eq_list;
c_assume = translate_extvalue e_a;
c_objectives = List.map translate_objective objs;
c_assume_loc = translate_extvalue e_a_loc;
......@@ -225,8 +225,8 @@ let node n =
n_input = List.map translate_var n.Heptagon.n_input;
n_output = List.map translate_var n.Heptagon.n_output;
n_contract = translate_contract n.Heptagon.n_contract;
n_local = List.map translate_var n.Heptagon.n_block.Heptagon.b_local;
n_equs = List.map translate_eq n.Heptagon.n_block.Heptagon.b_equs;
n_local = List.rev_map translate_var n.Heptagon.n_block.Heptagon.b_local;
n_equs = List.rev_map translate_eq n.Heptagon.n_block.Heptagon.b_equs;
n_loc = n.Heptagon.n_loc ;
n_params = n.Heptagon.n_params;
n_param_constraints = n.Heptagon.n_param_constraints;
......
......@@ -234,7 +234,7 @@ let translate_var_dec l =
let one_var { Minils.v_ident = x; Minils.v_type = t; Minils.v_linearity = lin; v_loc = loc } =
mk_var_dec ~loc:loc ~linearity:lin x t
in
List.map one_var l
List.rev (List.rev_map one_var l)
let rec translate_extvalue map w = match w.Minils.w_desc with
| Minils.Wvar x -> ext_value_of_pattern (var_from_name map x)
......@@ -452,12 +452,12 @@ let empty_call_context = None
[s] the actions used in the step method.
[v] var decs *)
let rec translate_eq map call_context
({ Minils.eq_lhs = pat; Minils.eq_base_ck = ck; Minils.eq_rhs = e } as eq)
(v, si, j, s) =
(v, si, j, s)
({ Minils.eq_lhs = pat; Minils.eq_base_ck = ck; Minils.eq_rhs = e } as eq) =
let { Minils.e_desc = desc; Minils.e_loc = loc } = e in
match (pat, desc) with
| _pat, Minils.Ewhen (e,_,_) ->
translate_eq map call_context {eq with Minils.eq_rhs = e} (v, si, j, s)
translate_eq map call_context (v, si, j, s) {eq with Minils.eq_rhs = e}
(* TODO Efby and Eifthenelse should be dealt with in translate_act, no ? *)
| Minils.Evarpat n, Minils.Efby (opt_c, e) ->
let x = var_from_name map n in
......@@ -529,7 +529,8 @@ let rec translate_eq map call_context
v, si, j, action @ s
and translate_eq_list map call_context act_list =
List.fold_right (translate_eq map call_context) act_list ([], [], [], [])
let rev_act = List.rev act_list in
List.fold_left (translate_eq map call_context) ([], [], [], []) rev_act
and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty =
match app.Minils.a_op with
......@@ -734,17 +735,17 @@ let translate_node
let (m_c, si', j', s_list', d_list') = translate_contract subst_map mem_var_tys contract in
let i_list = translate_var_dec i_list in
let o_list = translate_var_dec o_list in
let d_list = translate_var_dec (v @ d_list) in
let d_list = translate_var_dec (List.rev_append v d_list) in
let m, d_list = List.partition
(fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) d_list in
let m', o_list =
List.partition
(fun vd -> List.exists (fun (i,_) -> i = vd.v_ident) mem_var_tys) o_list in
let s = s_list @ s_list' in
let s = List.rev_append (List.rev s_list) s_list' in
let j = j' @ j in
let si = si @ si' in
let stepm = { m_name = Mstep; m_inputs = i_list; m_outputs = o_list;
m_body = mk_block ~locals:(d_list' @ d_list) s }
m_body = mk_block ~locals:(List.rev_append d_list' d_list) s }
in
let resetm = { m_name = Mreset; m_inputs = []; m_outputs = []; m_body = mk_block si } in
if stateful
......
......@@ -249,7 +249,7 @@ let typing_eq h ({ eq_lhs = pat; eq_rhs = e; eq_loc = loc } as eq) =
error_message loc (Etypeclash (ct, pat_ct)));
{ eq with eq_base_ck = base_ck }
let typing_eqs h eq_list = List.map (typing_eq h) eq_list
let typing_eqs h eq_list = List.rev_map (typing_eq h) eq_list
let append_env h vds =
List.fold_left (fun h { v_ident = n; v_clock = ck } -> Env.add n ck h) h vds
......@@ -290,7 +290,7 @@ let typing_node node =
let set_clock vd = { vd with v_clock = ck_repr (Env.find vd.v_ident h) } in
let node = { node with n_input = List.map set_clock node.n_input;
n_output = List.map set_clock node.n_output;
n_local = List.map set_clock node.n_local;
n_local = List.rev_map set_clock node.n_local;
n_equs = equs;
n_contract = contract; }
in
......
......@@ -107,10 +107,10 @@ let contract _ acc c = c, acc
let node funs acc nd =
let env = build_env nd in
let nd, (_, _, v, eqs) =
Mls_mapfold.node_dec funs (env, nd.n_local @ nd.n_output, [], []) nd
Mls_mapfold.node_dec funs (env, nd.n_output @ nd.n_local, nd.n_local, []) nd
in
(* return updated node *)
{ nd with n_local = v @ nd.n_local; n_equs = List.rev eqs }, acc
{ nd with n_local = v; n_equs = List.rev eqs }, acc
let program p =
let funs = { Mls_mapfold.defaults with
......
......@@ -113,31 +113,31 @@ let is_deadcode = function (* TODO Etrange puisque c'est apres la passe de deadc
| _ -> false
let rec joinlist j l =
let rec join_next l =
let rec join_next acc l =
match l with
| [] -> []
| [s1] -> [s1]
| [] -> acc
| [s1] -> s1::acc
| s1::s2::l ->
match s1, s2 with
| Acase(e1, h1),
Acase(e2, h2) when Obc_compare.exp_compare e1 e2 = 0 ->
let fused_switch = Acase(e1, joinhandlers j h1 h2) in
if is_modified_handlers j e2 h1 then
fused_switch::(join_first l)
join_first (fused_switch::acc) l
else
join_next (fused_switch::l)
| s1, s2 -> s1::(join_first (s2::l))
and join_first l =
join_next acc (fused_switch::l)
| s1, s2 -> join_first (s1::acc) (s2::l)
and join_first acc l =
match l with
| [] -> []
| [] -> acc
| (Acase(e1, h1))::l ->
if is_modified_handlers j e1 h1 then
(Acase(e1, h1))::(join_next l)
join_next ((Acase(e1, h1))::acc) l
else
join_next ((Acase(e1, h1))::l)
| _ -> join_next l
join_next acc ((Acase(e1, h1))::l)
| _ -> join_next acc l
in
join_first l
List.rev (join_first [] l)
and join_block j b =
......
Markdown is supported
0%
or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment