diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index c4835fb..4fff980 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -58,6 +58,12 @@ let rec translate_pat map = function List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) pat_list [] +let translate_var_dec map l = + let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } = + mk_var_dec ~loc:loc x t + in + List.map one_var l + (* [translate e = c] *) let rec translate map (si, j, s) e = let desc = match e.Minils.e_desc with @@ -119,7 +125,7 @@ and translate_act map context pat and translate_c_act_list map context pat c_act_list = List.map - (fun (c, act) -> (c, (translate_act map context pat act))) + (fun (c, act) -> (c, mk_block (translate_act map context pat act))) c_act_list let mk_obj_call_from_context (o, _) n = @@ -132,7 +138,7 @@ let size_from_call_context (_, n) = n let empty_call_context = Oobj "n", None let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } - (si, j, s) = + (v, si, j, s) = let { Minils.e_desc = desc; Minils.e_ty = ty; Minils.e_ck = ck; Minils.e_loc = loc } = e in match (pat, desc) with @@ -146,7 +152,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let action = Aassgn (var_from_name map n, translate map (si, j, s) e) in - si, j, (control map ck action) :: s + v, si, j, (control map ck action) :: s | Minils.Etuplepat p_list, Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_list, _) -> @@ -154,17 +160,20 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } (fun pat e -> translate_eq map call_context (Minils.mk_equation pat e)) - p_list act_list (si, j, s) + p_list act_list (v, si, j, s) | pat, Minils.Eapp({ Minils.a_op = Minils.Eifthenelse }, [e1;e2;e3], _) -> let cond = translate map (si, j, s) e1 in - let si, j, true_act = translate_eq map call_context - (Minils.mk_equation pat e2) (si, j, s) in - let si, j, false_act = translate_eq map call_context - (Minils.mk_equation pat e3) (si, j, s) in - let action = Acase (cond, [Name "true", true_act; - Name "false", false_act]) in - si, j, (control map ck action) :: s + let vt, si, j, true_act = translate_eq map call_context + (Minils.mk_equation pat e2) (v, si, j, s) in + let vf, si, j, false_act = translate_eq map call_context + (Minils.mk_equation pat e3) (v, si, j, s) in + let vf = translate_var_dec map vf in + let vt = translate_var_dec map vt in + let action = + Acase (cond, [Name "true", mk_block ~locals:vt true_act; + Name "false", mk_block ~locals:vf false_act]) in + v, si, j, (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Efield_update; @@ -175,7 +184,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let action = Aassgn (mk_lhs (Lfield (x, f)), translate map (si, j, s) e2) in - si, j, (control map ck copy) :: (control map ck action) :: s + v, si, j, (control map ck copy) :: (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; @@ -193,10 +202,11 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } [idx2;idx1])) ])) in let action = Afor (cpt, mk_static_exp (Sint 0), bound, - [Aassgn (mk_lhs (Larray (var_from_name map x, mk_evar cpt)), + mk_block [Aassgn (mk_lhs (Larray (var_from_name map x, + mk_evar cpt)), mk_lhs_exp (Larray (lhs_of_exp e, idx)))] ) in - si, j, (control map ck action) :: s + v, si, j, (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) -> @@ -208,9 +218,9 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } Aassgn (x, mk_exp (Elhs (lhs_of_idx_list (lhs_of_exp e1) idx))) in let false_act = Aassgn (x, translate map (si, j, s) e2) in let cond = bound_check_expr idx bounds in - let action = Acase (cond, [ Name "true", [true_act]; - Name "false", [false_act] ]) in - si, j, (control map ck action) :: s + let action = Acase (cond, [ Name "true", mk_block [true_act]; + Name "false", mk_block [false_act] ]) in + v, si, j, (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate; @@ -221,7 +231,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let action = Aassgn (lhs_of_idx_list x idx, translate map (si, j, s) e2) in - si, j, (control map ck copy) :: (control map ck action) :: s + v, si, j, (control map ck copy) :: (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; @@ -229,11 +239,11 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let cpt = Ident.fresh "i" in let action = Afor (cpt, mk_static_exp (Sint 0), n, - [Aassgn (mk_lhs (Larray (var_from_name map x, - mk_evar cpt)), - translate map (si, j, s) e) ]) + mk_block [Aassgn (mk_lhs (Larray (var_from_name map x, + mk_evar cpt)), + translate map (si, j, s) e) ]) in - si, j, (control map ck action) :: s + v, si, j, (control map ck action) :: s | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> @@ -246,25 +256,25 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let e2 = translate map (si, j, s) e2 in let a1 = Afor (cpt1, mk_static_exp (Sint 0), n1, - [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)), - mk_lhs_exp (Larray (lhs_of_exp e1, - mk_evar cpt1)))] ) in + mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)), + mk_lhs_exp (Larray (lhs_of_exp e1, + mk_evar cpt1)))] ) in let idx = mk_exp (Eop (op_from_string "+", [ mk_exp (Econst n1); mk_evar cpt2])) in let a2 = Afor (cpt2, static_exp_of_int 0, n2, - [Aassgn (mk_lhs (Larray (x, idx)), - mk_lhs_exp (Larray (lhs_of_exp e2, - mk_evar cpt2)))] ) + mk_block [Aassgn (mk_lhs (Larray (x, idx)), + mk_lhs_exp (Larray (lhs_of_exp e2, + mk_evar cpt2)))] ) in - si, j, (control map ck a1) :: (control map ck a2) :: s + v, si, j, (control map ck a1) :: (control map ck a2) :: s | _ -> assert false ) | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, e_list, r) -> let name_list = translate_pat map pat in let c_list = List.map (translate map (si, j, s)) e_list in - let si', j', action = mk_node_call map call_context + let v', si', j', action = mk_node_call map call_context app loc name_list c_list in let action = List.map (control map ck) action in let s = (match r, app.Minils.a_op with @@ -272,7 +282,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let ra = List.map (control map ck) si' in ra @ action @ s | _, _ -> action @ s) in - si'@si, j'@j, s + v' @ v, si'@si, j'@j, s | pat, Minils.Eiterator (it, app, n, e_list, reset) -> let name_list = translate_pat map pat in @@ -289,15 +299,15 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let ra = List.map (control map ck) si' in ra @ action @ s | _, _ -> action @ s) - in (si' @ si, j' @ j, s) + in (v, si' @ si, j' @ j, s) | (pat, _) -> let action = translate_act map (si, j, s) pat e in let action = List.map (control map ck) action in - si, j, action @ s + v, si, j, action @ s and translate_eq_list map call_context act_list = - List.fold_right (translate_eq map call_context) act_list ([], [], []) + List.fold_right (translate_eq map call_context) act_list ([], [], [], []) and mk_node_call map call_context app loc name_list args = match app.Minils.a_op with @@ -308,14 +318,14 @@ and mk_node_call map call_context app loc name_list args = (match app.Minils.a_op with | Minils.Efun _ -> [] | Minils.Enode _ -> [reinit o]) in - si, j, [Acall (name_list, o, Mstep, args)] + [], si, j, [Acall (name_list, o, Mstep, args)] | Minils.Elambda(inp, outp, locals, eq_list) -> let add_input env vd = Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in let build env vd a = Env.add vd.Minils.v_ident a env in - let subst_block env b = + let subst_act_list env act_list = let exp funs env e = match e.e_desc with | Elhs { l_desc = Lvar x } -> let e = @@ -325,16 +335,16 @@ and mk_node_call map call_context app loc name_list args = | _ -> Obc_mapfold.exp funs env e in let funs = { Obc_mapfold.defaults with exp = exp } in - let b, _ = Obc_mapfold.block_it funs env b in - b + let act_list, _ = mapfold (Obc_mapfold.act_it funs) env act_list in + act_list in let map = List.fold_left add_input map inp in let map = List.fold_left2 build map outp name_list in let map = List.fold_left add_input map locals in - let si, j, s = translate_eq_list map call_context eq_list in + let v, si, j, s = translate_eq_list map call_context eq_list in let env = List.fold_left2 build Env.empty inp args in - si, j, subst_block env s + v @ locals, si, j, subst_act_list env s | _ -> assert false @@ -348,29 +358,35 @@ and translate_iterator map call_context it name_list app loc n x c_list = | Minils.Imap -> let c_list = array_of_input c_list in let name_list = array_of_output name_list in - let si, j, action = mk_node_call map call_context + let v, si, j, action = mk_node_call map call_context app loc name_list c_list in - si, j, [ Afor (x, static_exp_of_int 0, n, action) ] + let v = translate_var_dec map v in + let b = mk_block ~locals:v action in + si, j, [ Afor (x, static_exp_of_int 0, n, b) ] | Minils.Imapfold -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_list in let (name_list, acc_out) = split_last name_list in let name_list = array_of_output name_list in - let si, j, action = mk_node_call map call_context + let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ]) (c_list @ [ mk_exp (Elhs acc_out) ]) in + let v = translate_var_dec map v in + let b = mk_block ~locals:v action in si, j, [Aassgn (acc_out, acc_in); - Afor (x, static_exp_of_int 0, n, action)] + Afor (x, static_exp_of_int 0, n, b)] | Minils.Ifold -> let (c_list, acc_in) = split_last c_list in let c_list = array_of_input c_list in let acc_out = last_element name_list in - let si, j, action = mk_node_call map call_context + let v, si, j, action = mk_node_call map call_context app loc name_list (c_list @ [ mk_exp (Elhs acc_out) ]) in + let v = translate_var_dec map v in + let b = mk_block ~locals:v action in si, j, [ Aassgn (acc_out, acc_in); - Afor (x, static_exp_of_int 0, n, action) ] + Afor (x, static_exp_of_int 0, n, b) ] let remove m d_list = List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n m)) d_list @@ -383,12 +399,6 @@ let obj_decl l = { o_name = obj_call_name x; o_class = t; o_size = i; o_loc = loc }) l -let translate_var_dec map l = - let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } = - mk_var_dec ~loc:loc x t - in - List.map one_var l - let translate_contract map mem_vars = function | None -> ([], [], [], []) @@ -399,9 +409,9 @@ let translate_contract map mem_vars = Minils.c_assume = e_a; Minils.c_enforce = e_c } -> - let (si, j, s_list) = translate_eq_list map + let (v, si, j, s_list) = translate_eq_list map empty_call_context eq_list in - let d_list = translate_var_dec map d_list in + let d_list = translate_var_dec map (v @ d_list) in let d_list = List.filter (fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in (si, j, s_list, d_list) @@ -430,13 +440,13 @@ let translate_node } as n) = let mem_vars = Mls_utils.node_memory_vars n in let subst_map = subst_map i_list o_list d_list mem_vars in - let (si, j, s_list) = translate_eq_list subst_map + let (v, si, j, s_list) = translate_eq_list subst_map empty_call_context eq_list in let (si', j', s_list', d_list') = translate_contract subst_map mem_vars contract in let i_list = translate_var_dec subst_map i_list in let o_list = translate_var_dec subst_map o_list in - let d_list = translate_var_dec subst_map d_list in + let d_list = translate_var_dec subst_map (v @ d_list) in let m, d_list = List.partition (fun vd -> List.mem vd.v_ident mem_vars) d_list in let s = joinlist (s_list @ s_list') in @@ -444,10 +454,10 @@ let translate_node let si = joinlist (si @ si') in let stepm = { m_name = Mstep; m_inputs = i_list; m_outputs = o_list; - m_locals = d_list @ d_list'; m_body = s } in + m_body = mk_block ~locals:(d_list' @ d_list) s } in let resetm = { m_name = Mreset; m_inputs = []; m_outputs = []; - m_locals = []; m_body = si } in + m_body = mk_block si } in { cd_name = f; cd_mems = m; cd_params = params; cd_objs = j; cd_methods = [stepm; resetm]; cd_loc = loc } diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 86f0406..841dfa8 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -462,8 +462,7 @@ let rec cstm_of_act var_env obj_env act = translation function on sub-statements. *) | Afor (x, i1, i2, act) -> [Cfor(name x, int_of_static_exp i1, - int_of_static_exp i2, - cstm_of_act_list var_env obj_env act)] + int_of_static_exp i2, cstm_of_act_list var_env obj_env act)] (** Reinitialization of an object variable, extracting the reset function's name from our environment [obj_env]. *) @@ -503,8 +502,14 @@ let rec cstm_of_act var_env obj_env act = let outvl = clhss_of_lhss var_env outvl in generate_function_call var_env obj_env outvl objn args -and cstm_of_act_list var_env obj_env act_list = - List.flatten (List.map (cstm_of_act var_env obj_env) act_list) +and cstm_of_act_list var_env obj_env b = + let l = List.map cvar_of_vd b.b_locals in + let var_env = l @ var_env in + let cstm = List.flatten (List.map (cstm_of_act var_env obj_env) b.b_body) in + match l with + | [] -> cstm + | _ -> + [Csblock { var_decls = l; block_body = cstm }] (* TODO needed only because of renaming phase *) let global_name = ref "";; @@ -541,7 +546,7 @@ let fun_def_of_step_fun name obj_env mem objs md = memory structure. *) let args = step_fun_args name md in (** Its normal local variables. *) - let local_vars = List.map cvar_of_vd md.m_locals in + let local_vars = List.map cvar_of_vd md.m_body.b_locals in (** Out vars for function calls *) let out_vars = diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index f00a8fd..e844df3 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -23,6 +23,10 @@ let var_from_name map x = _ -> assert false end +let fuse_blocks b1 b2 = + { b1 with b_locals = b1.b_locals @ b2.b_locals; + b_body = b1.b_body @ b2.b_body } + let rec find c = function | [] -> raise Not_found | (c1, s1) :: h -> @@ -34,7 +38,7 @@ let rec control map ck s = | Cvar { contents = Clink ck } -> control map ck s | Con(ck, c, n) -> let x = var_from_name map n in - control map ck (Acase(mk_exp (Elhs x), [(c, [s])])) + control map ck (Acase(mk_exp (Elhs x), [(c, mk_block [s])])) let is_deadcode = function | Aassgn (lhs, e) -> @@ -43,7 +47,7 @@ let is_deadcode = function | _ -> false ) | Acase (e, []) -> true - | Afor(_, _, _, []) -> true + | Afor(_, _, _, { b_body = [] }) -> true | _ -> false let rec joinlist l = @@ -58,11 +62,14 @@ let rec joinlist l = joinlist ((Acase(e1, joinhandlers h1 h2))::l) | s1, s2 -> s1::(joinlist (s2::l)) +and join_block b = + { b with b_body = joinlist b.b_body } + and joinhandlers h1 h2 = match h1 with | [] -> h2 | (c1, s1) :: h1' -> let s1', h2' = - try let s2, h2'' = find c1 h2 in s1@s2, h2'' + try let s2, h2'' = find c1 h2 in fuse_blocks s1 s2, h2'' with Not_found -> s1, h2 in - (c1, joinlist s1') :: joinhandlers h1' h2' + (c1, join_block s1') :: joinhandlers h1' h2' diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index 885454a..a629196 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -68,9 +68,11 @@ type act = | Acase of exp * (constructor_name * block) list | Afor of var_ident * static_exp * static_exp * block -and block = act list +and block = + { b_locals : var_dec list; + b_body : act list } -type var_dec = +and var_dec = { v_ident : var_ident; v_type : ty; (* TODO should be here, v_controllable : bool*) v_loc : location } @@ -85,7 +87,6 @@ type method_def = { m_name : method_name; m_inputs : var_dec list; m_outputs : var_dec list; - m_locals : var_dec list; m_body : block; } type class_def = @@ -119,6 +120,10 @@ let mk_lhs_exp ?(ty=invalid_type) desc = let mk_evar id = mk_exp (Elhs (mk_lhs (Lvar id))) +let mk_block ?(locals=[]) eq_list = + { b_locals = locals; + b_body = eq_list } + let rec var_name x = match x.l_desc with | Lvar x -> x diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index 8c3debc..85c0fee 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -110,8 +110,9 @@ and act funs acc a = match a with and block_it funs acc b = funs.block funs acc b and block funs acc b = - mapfold (act_it funs) acc b - + let b_locals, acc = var_decs_it funs acc b.b_locals in + let b_body, acc = mapfold (act_it funs) acc b.b_body in + { b with b_locals = b_locals; b_body = b_body }, acc and var_dec_it funs acc vd = funs.var_dec funs acc vd and var_dec funs acc vd = @@ -136,11 +137,9 @@ and method_def_it funs acc md = funs.method_def funs acc md and method_def funs acc md = let m_inputs, acc = var_decs_it funs acc md.m_inputs in let m_outputs, acc = var_decs_it funs acc md.m_outputs in - let m_locals, acc = var_decs_it funs acc md.m_locals in let m_body, acc = block_it funs acc md.m_body in { md with - m_inputs = m_inputs; m_outputs = m_outputs; - m_locals = m_locals; m_body = m_body } + m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body } , acc diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 2038935..58f03c9 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -92,8 +92,13 @@ let rec print_act ff a = fprintf ff "@["; print_exps ff es; fprintf ff "@]"; fprintf ff ")" -and print_act_list ff l = - print_list_r print_act "" ";" "" ff l +and print_act_list ff b = + if b.b_locals <> [] then begin + fprintf ff "@[var "; + print_list_r print_vd "" ";" "" ff b.b_locals; + fprintf ff ";@]@," + end; + print_list_r print_act "" ";" "" ff b.b_body and print_tag_act_list ff tag_act_list = print_list @@ -117,11 +122,6 @@ let print_method ff md = fprintf ff "@]) returns "; print_list_r print_vd "(" ";" ")" ff md.m_outputs; fprintf ff "@]){@,"; - if md.m_locals <> [] then begin - fprintf ff "@[var "; - print_list_r print_vd "" ";" "" ff md.m_locals; - fprintf ff ";@]@," - end; print_act_list ff md.m_body; fprintf ff "}@]"