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