jeltz
/
heptagon
1
0
Fork 0
Code Issues Pull Requests Releases Activity

Fixed code generation for Elambda 

- Added block notion in Obc
- Correct translation to C
This commit is contained in:
Cédric Pasteur 2010-07-22 09:36:22 +02:00
parent 4d52fe79ef
commit 1be9f1c789
6 changed files with 108 additions and 82 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

126
compiler/main/mls2obc.ml
View File

@ -58,6 +58,12 @@ let rec translate_pat map = function
List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) List.fold_right (fun pat acc -> (translate_pat map pat) @ acc)
pat_list [] 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] *) (* [translate e = c] *)
let rec translate map (si, j, s) e = let rec translate map (si, j, s) e =
let desc = match e.Minils.e_desc with 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 = and translate_c_act_list map context pat c_act_list =
List.map 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 c_act_list
let mk_obj_call_from_context (o, _) n = 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 empty_call_context = Oobj "n", None
let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } 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; let { Minils.e_desc = desc; Minils.e_ty = ty;
Minils.e_ck = ck; Minils.e_loc = loc } = e in Minils.e_ck = ck; Minils.e_loc = loc } = e in
match (pat, desc) with 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, let action = Aassgn (var_from_name map n,
translate map (si, j, s) e) translate map (si, j, s) e)
in in
si, j, (control map ck action) :: s v, si, j, (control map ck action) :: s
| Minils.Etuplepat p_list, | Minils.Etuplepat p_list,
Minils.Eapp({ Minils.a_op = Minils.Etuple }, act_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 -> (fun pat e ->
translate_eq map call_context translate_eq map call_context
(Minils.mk_equation pat e)) (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], _) -> | pat, Minils.Eapp({ Minils.a_op = Minils.Eifthenelse }, [e1;e2;e3], _) ->
let cond = translate map (si, j, s) e1 in let cond = translate map (si, j, s) e1 in
let si, j, true_act = translate_eq map call_context let vt, si, j, true_act = translate_eq map call_context
(Minils.mk_equation pat e2) (si, j, s) in (Minils.mk_equation pat e2) (v, si, j, s) in
let si, j, false_act = translate_eq map call_context let vf, si, j, false_act = translate_eq map call_context
(Minils.mk_equation pat e3) (si, j, s) in (Minils.mk_equation pat e3) (v, si, j, s) in
let action = Acase (cond, [Name "true", true_act; let vf = translate_var_dec map vf in
Name "false", false_act]) in let vt = translate_var_dec map vt in
si, j, (control map ck action) :: s 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.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Efield_update; 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 = let action =
Aassgn (mk_lhs (Lfield (x, f)), translate map (si, j, s) e2) Aassgn (mk_lhs (Lfield (x, f)), translate map (si, j, s) e2)
in 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.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; 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 [idx2;idx1])) ])) in
let action = let action =
Afor (cpt, mk_static_exp (Sint 0), bound, 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)))] ) mk_lhs_exp (Larray (lhs_of_exp e, idx)))] )
in in
si, j, (control map ck action) :: s v, si, j, (control map ck action) :: s
| Minils.Evarpat x, | Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eselect_dyn }, e1::e2::idx, _) -> 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 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 false_act = Aassgn (x, translate map (si, j, s) e2) in
let cond = bound_check_expr idx bounds in let cond = bound_check_expr idx bounds in
let action = Acase (cond, [ Name "true", [true_act]; let action = Acase (cond, [ Name "true", mk_block [true_act];
Name "false", [false_act] ]) in Name "false", mk_block [false_act] ]) in
si, j, (control map ck action) :: s v, si, j, (control map ck action) :: s
| Minils.Evarpat x, | Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Eupdate; 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, let action = Aassgn (lhs_of_idx_list x idx,
translate map (si, j, s) e2) translate map (si, j, s) e2)
in 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.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; 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 cpt = Ident.fresh "i" in
let action = let action =
Afor (cpt, mk_static_exp (Sint 0), n, Afor (cpt, mk_static_exp (Sint 0), n,
[Aassgn (mk_lhs (Larray (var_from_name map x, mk_block [Aassgn (mk_lhs (Larray (var_from_name map x,
mk_evar cpt)), mk_evar cpt)),
translate map (si, j, s) e) ]) translate map (si, j, s) e) ])
in in
si, j, (control map ck action) :: s v, si, j, (control map ck action) :: s
| Minils.Evarpat x, | Minils.Evarpat x,
Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> 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 e2 = translate map (si, j, s) e2 in
let a1 = let a1 =
Afor (cpt1, mk_static_exp (Sint 0), n1, Afor (cpt1, mk_static_exp (Sint 0), n1,
[Aassgn (mk_lhs (Larray (x, mk_evar cpt1)), mk_block [Aassgn (mk_lhs (Larray (x, mk_evar cpt1)),
mk_lhs_exp (Larray (lhs_of_exp e1, mk_lhs_exp (Larray (lhs_of_exp e1,
mk_evar cpt1)))] ) in mk_evar cpt1)))] ) in
let idx = mk_exp (Eop (op_from_string "+", let idx = mk_exp (Eop (op_from_string "+",
[ mk_exp (Econst n1); mk_evar cpt2])) in [ mk_exp (Econst n1); mk_evar cpt2])) in
let a2 = let a2 =
Afor (cpt2, static_exp_of_int 0, n2, Afor (cpt2, static_exp_of_int 0, n2,
[Aassgn (mk_lhs (Larray (x, idx)), mk_block [Aassgn (mk_lhs (Larray (x, idx)),
mk_lhs_exp (Larray (lhs_of_exp e2, mk_lhs_exp (Larray (lhs_of_exp e2,
mk_evar cpt2)))] ) mk_evar cpt2)))] )
in 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 ) | _ -> assert false )
| pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app, | pat, Minils.Eapp ({ Minils.a_op = Minils.Efun _ | Minils.Enode _ } as app,
e_list, r) -> e_list, r) ->
let name_list = translate_pat map pat in let name_list = translate_pat map pat in
let c_list = List.map (translate map (si, j, s)) e_list 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 app loc name_list c_list in
let action = List.map (control map ck) action in let action = List.map (control map ck) action in
let s = (match r, app.Minils.a_op with 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 let ra = List.map (control map ck) si' in
ra @ action @ s ra @ action @ s
| _, _ -> action @ s) in | _, _ -> action @ s) in
si'@si, j'@j, s v' @ v, si'@si, j'@j, s
| pat, Minils.Eiterator (it, app, n, e_list, reset) -> | pat, Minils.Eiterator (it, app, n, e_list, reset) ->
let name_list = translate_pat map pat in 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 let ra = List.map (control map ck) si' in
ra @ action @ s ra @ action @ s
| _, _ -> action @ s) | _, _ -> action @ s)
in (si' @ si, j' @ j, s) in (v, si' @ si, j' @ j, s)
| (pat, _) -> | (pat, _) ->
let action = translate_act map (si, j, s) pat e in let action = translate_act map (si, j, s) pat e in
let action = List.map (control map ck) action 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 = 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 = and mk_node_call map call_context app loc name_list args =
match app.Minils.a_op with 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 (match app.Minils.a_op with
| Minils.Efun _ -> [] | Minils.Efun _ -> []
| Minils.Enode _ -> [reinit o]) in | 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) -> | Minils.Elambda(inp, outp, locals, eq_list) ->
let add_input env vd = let add_input env vd =
Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in Env.add vd.Minils.v_ident (mk_lhs (Lvar vd.Minils.v_ident)) env in
let build env vd a = let build env vd a =
Env.add vd.Minils.v_ident a env in 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 let exp funs env e = match e.e_desc with
| Elhs { l_desc = Lvar x } -> | Elhs { l_desc = Lvar x } ->
let e = let e =
@ -325,16 +335,16 @@ and mk_node_call map call_context app loc name_list args =
| _ -> Obc_mapfold.exp funs env e | _ -> Obc_mapfold.exp funs env e
in in
let funs = { Obc_mapfold.defaults with exp = exp } in let funs = { Obc_mapfold.defaults with exp = exp } in
let b, _ = Obc_mapfold.block_it funs env b in let act_list, _ = mapfold (Obc_mapfold.act_it funs) env act_list in
b act_list
in in
let map = List.fold_left add_input map inp 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_left2 build map outp name_list in
let map = List.fold_left add_input map locals 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 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 | _ -> assert false
@ -348,29 +358,35 @@ and translate_iterator map call_context it name_list app loc n x c_list =
| Minils.Imap -> | Minils.Imap ->
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let name_list = array_of_output 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 c_list in 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 -> | Minils.Imapfold ->
let (c_list, acc_in) = split_last c_list in let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input 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, acc_out) = split_last name_list in
let name_list = array_of_output 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 ]) app loc (name_list @ [ acc_out ])
(c_list @ [ mk_exp (Elhs acc_out) ]) in (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); 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 -> | Minils.Ifold ->
let (c_list, acc_in) = split_last c_list in let (c_list, acc_in) = split_last c_list in
let c_list = array_of_input c_list in let c_list = array_of_input c_list in
let acc_out = last_element name_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 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); 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 = let remove m d_list =
List.filter (fun { Minils.v_ident = n } -> not (List.mem_assoc n 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_name = obj_call_name x; o_class = t;
o_size = i; o_loc = loc }) l 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 = let translate_contract map mem_vars =
function function
| None -> ([], [], [], []) | None -> ([], [], [], [])
@ -399,9 +409,9 @@ let translate_contract map mem_vars =
Minils.c_assume = e_a; Minils.c_assume = e_a;
Minils.c_enforce = e_c 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 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 let d_list = List.filter
(fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in (fun vd -> not (List.mem vd.v_ident mem_vars)) d_list in
(si, j, s_list, d_list) (si, j, s_list, d_list)
@ -430,13 +440,13 @@ let translate_node
} as n) = } as n) =
let mem_vars = Mls_utils.node_memory_vars n in 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 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 empty_call_context eq_list in
let (si', j', s_list', d_list') = let (si', j', s_list', d_list') =
translate_contract subst_map mem_vars contract in translate_contract subst_map mem_vars contract in
let i_list = translate_var_dec subst_map i_list in let i_list = translate_var_dec subst_map i_list in
let o_list = translate_var_dec subst_map o_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 let m, d_list = List.partition
(fun vd -> List.mem vd.v_ident mem_vars) d_list in (fun vd -> List.mem vd.v_ident mem_vars) d_list in
let s = joinlist (s_list @ s_list') in let s = joinlist (s_list @ s_list') in
@ -444,10 +454,10 @@ let translate_node
let si = joinlist (si @ si') in let si = joinlist (si @ si') in
let stepm = { let stepm = {
m_name = Mstep; m_inputs = i_list; m_outputs = o_list; 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 = { let resetm = {
m_name = Mreset; m_inputs = []; m_outputs = []; 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_name = f; cd_mems = m; cd_params = params;
cd_objs = j; cd_methods = [stepm; resetm]; cd_objs = j; cd_methods = [stepm; resetm];
cd_loc = loc } cd_loc = loc }

15
compiler/obc/c/cgen.ml
View File

@ -462,8 +462,7 @@ let rec cstm_of_act var_env obj_env act =
translation function on sub-statements. *) translation function on sub-statements. *)
| Afor (x, i1, i2, act) -> | Afor (x, i1, i2, act) ->
[Cfor(name x, int_of_static_exp i1, [Cfor(name x, int_of_static_exp i1,
int_of_static_exp i2, int_of_static_exp i2, cstm_of_act_list var_env obj_env act)]
cstm_of_act_list var_env obj_env act)]
(** Reinitialization of an object variable, extracting the reset (** Reinitialization of an object variable, extracting the reset
function's name from our environment [obj_env]. *) 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 let outvl = clhss_of_lhss var_env outvl in
generate_function_call var_env obj_env outvl objn args generate_function_call var_env obj_env outvl objn args
and cstm_of_act_list var_env obj_env act_list = and cstm_of_act_list var_env obj_env b =
List.flatten (List.map (cstm_of_act var_env obj_env) act_list) 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 *) (* TODO needed only because of renaming phase *)
let global_name = ref "";; let global_name = ref "";;
@ -541,7 +546,7 @@ let fun_def_of_step_fun name obj_env mem objs md =
memory structure. *) memory structure. *)
let args = step_fun_args name md in let args = step_fun_args name md in
(** Its normal local variables. *) (** 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 *) (** Out vars for function calls *)
let out_vars = let out_vars =

15
compiler/obc/control.ml
View File

@ -23,6 +23,10 @@ let var_from_name map x =
_ -> assert false _ -> assert false
end 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 let rec find c = function
| [] -> raise Not_found | [] -> raise Not_found
| (c1, s1) :: h -> | (c1, s1) :: h ->
@ -34,7 +38,7 @@ let rec control map ck s =
| Cvar { contents = Clink ck } -> control map ck s | Cvar { contents = Clink ck } -> control map ck s
| Con(ck, c, n) -> | Con(ck, c, n) ->
let x = var_from_name map n in 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 let is_deadcode = function
| Aassgn (lhs, e) -> | Aassgn (lhs, e) ->
@ -43,7 +47,7 @@ let is_deadcode = function
| _ -> false | _ -> false
) )
| Acase (e, []) -> true | Acase (e, []) -> true
| Afor(_, _, _, []) -> true | Afor(_, _, _, { b_body = [] }) -> true
| _ -> false | _ -> false
let rec joinlist l = let rec joinlist l =
@ -58,11 +62,14 @@ let rec joinlist l =
joinlist ((Acase(e1, joinhandlers h1 h2))::l) joinlist ((Acase(e1, joinhandlers h1 h2))::l)
| s1, s2 -> s1::(joinlist (s2::l)) | s1, s2 -> s1::(joinlist (s2::l))
and join_block b =
{ b with b_body = joinlist b.b_body }
and joinhandlers h1 h2 = and joinhandlers h1 h2 =
match h1 with match h1 with
| [] -> h2 | [] -> h2
| (c1, s1) :: h1' -> | (c1, s1) :: h1' ->
let s1', h2' = 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 with Not_found -> s1, h2 in
(c1, joinlist s1') :: joinhandlers h1' h2' (c1, join_block s1') :: joinhandlers h1' h2'

11
compiler/obc/obc.ml
View File

@ -68,9 +68,11 @@ type act =
| Acase of exp * (constructor_name * block) list | Acase of exp * (constructor_name * block) list
| Afor of var_ident * static_exp * static_exp * block | 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_ident : var_ident;
v_type : ty; (* TODO should be here, v_controllable : bool*) v_type : ty; (* TODO should be here, v_controllable : bool*)
v_loc : location } v_loc : location }
@ -85,7 +87,6 @@ type method_def =
{ m_name : method_name; { m_name : method_name;
m_inputs : var_dec list; m_inputs : var_dec list;
m_outputs : var_dec list; m_outputs : var_dec list;
m_locals : var_dec list;
m_body : block; } m_body : block; }
type class_def = type class_def =
@ -119,6 +120,10 @@ let mk_lhs_exp ?(ty=invalid_type) desc =
let mk_evar id = let mk_evar id =
mk_exp (Elhs (mk_lhs (Lvar 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 = let rec var_name x =
match x.l_desc with match x.l_desc with
| Lvar x -> x | Lvar x -> x

9
compiler/obc/obc_mapfold.ml
View File

@ -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_it funs acc b = funs.block funs acc b
and 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_it funs acc vd = funs.var_dec funs acc vd
and 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 = and method_def funs acc md =
let m_inputs, acc = var_decs_it funs acc md.m_inputs in 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_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 let m_body, acc = block_it funs acc md.m_body in
{ md with { md with
m_inputs = m_inputs; m_outputs = m_outputs; m_inputs = m_inputs; m_outputs = m_outputs; m_body = m_body }
m_locals = m_locals; m_body = m_body }
, acc , acc

14
compiler/obc/obc_printer.ml
View File

@ -92,8 +92,13 @@ let rec print_act ff a =
fprintf ff "@["; print_exps ff es; fprintf ff "@]"; fprintf ff "@["; print_exps ff es; fprintf ff "@]";
fprintf ff ")" fprintf ff ")"
and print_act_list ff l = and print_act_list ff b =
print_list_r print_act "" ";" "" ff l if b.b_locals <> [] then begin
fprintf ff "@[<hov 4>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 = and print_tag_act_list ff tag_act_list =
print_list print_list
@ -117,11 +122,6 @@ let print_method ff md =
fprintf ff "@]) returns "; fprintf ff "@]) returns ";
print_list_r print_vd "(" ";" ")" ff md.m_outputs; print_list_r print_vd "(" ";" ")" ff md.m_outputs;
fprintf ff "@]){@,"; fprintf ff "@]){@,";
if md.m_locals <> [] then begin
fprintf ff "@[<hov 4>var ";
print_list_r print_vd "" ";" "" ff md.m_locals;
fprintf ff ";@]@,"
end;
print_act_list ff md.m_body; print_act_list ff md.m_body;
fprintf ff "}@]" fprintf ff "}@]"