From 4794045208c80a06bbae33d15713bc9f22100ba8 Mon Sep 17 00:00:00 2001 From: Adrien Guatto Date: Mon, 30 May 2011 10:06:16 +0200 Subject: [PATCH] Reworked Obc AST: from right patterns to extvalues. I introduced a notion of extended values in Obc expressions, replacing the Epattern constructor. Patterns may now only occur at their rightful place, on the left of an assignment. This change allows to index global constant arrays. --- compiler/main/mls2obc.ml | 190 +++++++------- compiler/obc/c/c.ml | 59 +++-- compiler/obc/c/c.mli | 135 ---------- compiler/obc/c/cgen.ml | 301 ++++++++++++---------- compiler/obc/c/cmain.ml | 69 ++--- compiler/obc/c/csubst.ml | 60 ----- compiler/obc/control.ml | 4 +- compiler/obc/java/java.ml | 10 +- compiler/obc/java/java_main.ml | 30 +-- compiler/obc/java/java_printer.ml | 7 +- compiler/obc/java/obc2java.ml | 32 ++- compiler/obc/obc.ml | 12 +- compiler/obc/obc_mapfold.ml | 34 ++- compiler/obc/obc_printer.ml | 15 +- compiler/obc/obc_utils.ml | 51 +++- compiler/obc/transformations/scalarize.ml | 2 +- heptc | 13 +- 17 files changed, 487 insertions(+), 537 deletions(-) delete mode 100644 compiler/obc/c/c.mli delete mode 100644 compiler/obc/c/csubst.ml diff --git a/compiler/main/mls2obc.ml b/compiler/main/mls2obc.ml index 23ec7f5..29e31f0 100644 --- a/compiler/main/mls2obc.ml +++ b/compiler/main/mls2obc.ml @@ -43,6 +43,12 @@ let var_from_name map x = _ -> assert false end +let ext_value_exp_from_name map x = + let w = ext_value_of_pattern (var_from_name map x) in + mk_exp w.w_ty (Eextvalue w) + +(* let lvar_from_name map ty x = mk_pattern ty (Lvar (var_from_name map x)) *) + let fresh_it () = let id = Idents.gen_var "mls2obc" "i" in id, mk_var_dec id Initial.tint @@ -61,23 +67,28 @@ let rec pattern_of_idx_list p l = in aux p l -let rec pattern_of_trunc_idx_list p l = +let rec extvalue_of_idx_list w l = match w.w_ty, l with + | _, [] -> w + | Tarray (ty',_), idx :: l -> + extvalue_of_idx_list (mk_ext_value ty' (Warray (w, idx))) l + | _ -> internal_error "mls2obc" 1 + +let rec ext_value_of_trunc_idx_list p l = let mk_between idx se = - mk_exp_int (Eop (mk_pervasives "between", [idx; mk_exp se.se_ty (Econst se)])) + mk_exp_int (Eop (mk_pervasives "between", [idx; mk_ext_value_exp se.se_ty (Wconst se)])) in - let rec aux p l = match p.pat_ty, l with + let rec aux p l = match p.w_ty, l with | _, [] -> p - | Tarray (ty', se), idx :: l -> aux (mk_pattern ty' (Larray (p, mk_between idx se))) l + | Tarray (ty', se), idx :: l -> aux (mk_ext_value ty' (Warray (p, mk_between idx se))) l | _ -> internal_error "mls2obc" 1 in aux p l let array_elt_of_exp idx e = match e.e_desc, Modules.unalias_type e.e_ty with - | Econst ({ se_desc = Sarray_power (c, _) }), Tarray (ty,_) -> - mk_exp ty (Econst c) + | Eextvalue { w_desc = Wconst { se_desc = Sarray_power (c, _); _ }; }, Tarray (ty,_) -> mk_ext_value_exp ty (Wconst c) | _, Tarray (ty,_) -> - mk_pattern_exp ty (Larray(pattern_of_exp e, idx)) + mk_ext_value_exp ty (Warray(ext_value_of_exp e, idx)) | _ -> internal_error "mls2obc" 2 (** Creates the expression that checks that the indices @@ -87,9 +98,9 @@ let array_elt_of_exp idx e = let rec bound_check_expr idx_list bounds = let mk_comp idx n = let e1 = mk_exp_bool (Eop (op_from_string "<", - [idx; mk_exp_int (Econst n)])) in + [idx; mk_ext_value_exp_int (Wconst n)])) in let e2 = mk_exp_bool (Eop (op_from_string "<=", - [mk_exp_int (Econst (mk_static_int 0)); idx])) in + [mk_ext_value_exp_int (Wconst (mk_static_int 0)); idx])) in mk_exp_bool (Eop (op_from_string "&", [e1;e2])) in match (idx_list, bounds) with @@ -101,9 +112,9 @@ let rec bound_check_expr idx_list bounds = | (_, _) -> internal_error "mls2obc" 3 let mk_plus_one e = match e.e_desc with - | Econst idx -> + | Eextvalue ({ w_desc = Wconst idx; _ } as w) -> let idx_plus_one = mk_static_int_op (mk_pervasives "+") [idx; mk_static_int 1] in - { e with e_desc = Econst idx_plus_one } + { e with e_desc = Eextvalue { w with w_desc = Wconst idx_plus_one; }; } | _ -> let idx_plus_one = Eop (mk_pervasives "+", [e; mk_exp_const_int 1]) in { e with e_desc = idx_plus_one } @@ -136,7 +147,7 @@ let rec update_array dest src idx_list v = match dest.pat_ty, idx_list with let update_record dest src f v = let assgn_act { f_name = l; f_type = ty } = let dest_l = mk_pattern ty (Lfield(dest, l)) in - let src_l = mk_pattern_exp ty (Lfield(src, l)) in + let src_l = mk_ext_value_exp ty (Wfield(src, l)) in if f = l then Aassgn(dest_l, v) else @@ -148,22 +159,22 @@ let update_record dest src f v = in List.map assgn_act fields -let rec control map ck s = - match ck with - | Cbase | Cvar { contents = Cindex _ } -> 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 x.pat_ty (Epattern x), [(c, mk_block [s])])) +let rec control map ck s = match ck with + | Cbase | Cvar { contents = Cindex _ } -> s + | Cvar { contents = Clink ck } -> control map ck s + | Con(ck, c, n) -> + let x = ext_value_exp_from_name map n in + control map ck (Acase(x, [(c, mk_block [s])])) let reinit o = Acall ([], o, Mreset, []) -let rec translate_pat map = function - | Minils.Evarpat x -> [ var_from_name map x ] - | Minils.Etuplepat pat_list -> - List.fold_right (fun pat acc -> (translate_pat map pat) @ acc) - pat_list [] +let rec translate_pat map ty pat = match pat, ty with + | Minils.Evarpat x, _ -> [ var_from_name map x ] + | Minils.Etuplepat pat_list, Tprod ty_l -> + List.fold_right2 (fun ty pat acc -> (translate_pat map ty pat) @ acc) + ty_l pat_list [] + | Minils.Etuplepat _, _ -> Misc.internal_error "Ill-typed pattern" 0 let translate_var_dec l = let one_var { Minils.v_ident = x; Minils.v_type = t; v_loc = loc } = @@ -171,44 +182,45 @@ let translate_var_dec l = in List.map one_var l -let rec translate_extvalue map w = - let desc = match w.Minils.w_desc with - | Minils.Wconst v -> Econst v - | Minils.Wvar x -> Epattern (var_from_name map x) - | Minils.Wfield (w1, f) -> - let e = translate_extvalue map w1 in - Epattern (mk_pattern w.Minils.w_ty (Lfield (pattern_of_exp e, f))) - | Minils.Wwhen (w1, c, x) -> - let e1 = translate_extvalue map w1 in - e1.e_desc - in - mk_exp w.Minils.w_ty desc +let rec translate_extvalue map w = match w.Minils.w_desc with + | Minils.Wvar x -> ext_value_of_pattern (var_from_name map x) + | _ -> + let desc = match w.Minils.w_desc with + | Minils.Wconst v -> Wconst v + | Minils.Wvar x -> assert false + | Minils.Wfield (w1, f) -> Wfield (translate_extvalue map w1, f) + | Minils.Wwhen (w1, c, x) -> (translate_extvalue map w1).w_desc + in + mk_ext_value w.Minils.w_ty desc + +and translate_extvalue_to_exp map w = + mk_exp ~loc:w.Minils.w_loc w.Minils.w_ty (Eextvalue (translate_extvalue map w)) (* [translate e = c] *) let rec translate map e = let desc = match e.Minils.e_desc with | Minils.Eextvalue w -> - let e = translate_extvalue map w in e.e_desc - | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, e_list, _) -> - Eop (op_from_string "=", List.map (translate_extvalue map ) e_list) + let w = translate_extvalue map w in Eextvalue w + | Minils.Eapp ({ Minils.a_op = Minils.Eequal }, w_list, _) -> + Eop (op_from_string "=", List.map (translate_extvalue_to_exp map) w_list) | Minils.Eapp ({ Minils.a_op = Minils.Efun n }, e_list, _) when Mls_utils.is_op n -> - Eop (n, List.map (translate_extvalue map ) e_list) + Eop (n, List.map (translate_extvalue_to_exp map ) e_list) | Minils.Estruct f_e_list -> let type_name = (match e.Minils.e_ty with | Tid name -> name | _ -> assert false) in let f_e_list = List.map - (fun (f, e) -> (f, (translate_extvalue map e))) f_e_list in + (fun (f, e) -> (f, (translate_extvalue_to_exp map e))) f_e_list in Estruct (type_name, f_e_list) (*Remaining array operators*) | Minils.Eapp ({ Minils.a_op = Minils.Earray }, e_list, _) -> - Earray (List.map (translate_extvalue map ) e_list) + Earray (List.map (translate_extvalue_to_exp map ) e_list) | Minils.Eapp ({ Minils.a_op = Minils.Eselect; - Minils.a_params = idx }, e_list, _) -> + Minils.a_params = idx_list }, e_list, _) -> let e = translate_extvalue map (assert_1 e_list) in - let idx_list = List.map (fun idx -> mk_exp tint (Econst idx)) idx in - Epattern (pattern_of_idx_list (pattern_of_exp e) idx_list) + let idx_list = List.map mk_exp_static_int idx_list in + Eextvalue (extvalue_of_idx_list e idx_list) (* Already treated cases when translating the [eq] *) | Minils.Eiterator _ | Minils.Emerge _ | Minils.Efby _ | Minils.Eapp ({Minils.a_op=(Minils.Enode _|Minils.Efun _|Minils.Econcat @@ -223,7 +235,7 @@ let rec translate map e = and translate_act_extvalue map pat w = match pat with | Minils.Evarpat n -> - [Aassgn (var_from_name map n, translate_extvalue map w)] + [Aassgn (var_from_name map n, translate_extvalue_to_exp map w)] | _ -> assert false (* [translate pat act = si, d] *) @@ -234,11 +246,11 @@ and translate_act map pat | Minils.Evarpat x, Minils.Emerge (y, c_act_list) -> let x = var_from_name map x in let translate_c_extvalue (c, w) = - c, mk_block [Aassgn (x, translate_extvalue map w)] + c, mk_block [Aassgn (x, translate_extvalue_to_exp map w)] in - let pattern = var_from_name map y in - [Acase (mk_exp pattern.pat_ty (Epattern pattern), - List.map translate_c_extvalue c_act_list)] + + [Acase (ext_value_exp_from_name map y, + List.map translate_c_extvalue c_act_list)] (* Array ops *) | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Econcat }, [e1; e2], _) -> @@ -248,14 +260,14 @@ and translate_act map pat let t = x.pat_ty in (match e1.Minils.w_ty, e2.Minils.w_ty with | Tarray (t1, n1), Tarray (t2, n2) -> - let e1 = translate_extvalue map e1 in - let e2 = translate_extvalue map e2 in + let e1 = translate_extvalue_to_exp map e1 in + let e2 = translate_extvalue_to_exp map e2 in let a1 = Afor (cpt1d, mk_exp_const_int 0, mk_exp_static_int n1, mk_block [Aassgn (mk_pattern t1 (Larray (x, mk_evar_int cpt1)), array_elt_of_exp (mk_evar_int cpt1) e1)] ) in let idx = mk_exp_int (Eop (op_from_string "+", - [ mk_exp_int (Econst n1); mk_evar_int cpt2])) in + [ mk_exp_static_int n1; mk_evar_int cpt2])) in let p2 = array_elt_of_exp (mk_evar_int cpt2) e2 in let a2 = Afor (cpt2d, mk_exp_const_int 0, mk_exp_static_int n2, mk_block [Aassgn (mk_pattern t2 (Larray (x, idx)), p2)] ) @@ -265,20 +277,20 @@ and translate_act map pat | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Earray_fill; Minils.a_params = n_list }, [e], _) -> - let e = translate_extvalue map e in + let e = translate_extvalue_to_exp map e in let x = var_from_name map x in let t = match x.pat_ty with | Tarray (t,_) -> t | _ -> Misc.internal_error "mls2obc select slice type" 5 in - + let rec make_loop power_list replace = match power_list with | [] -> x, replace | p :: power_list -> let cpt, cptd = fresh_it () in - let e, replace = - make_loop power_list - (fun y -> [Afor (cptd, mk_exp_const_int 0, + let e, replace = + make_loop power_list + (fun y -> [Afor (cptd, mk_exp_const_int 0, mk_exp_static_int p, mk_block (replace y))]) in let e = Larray (e, mk_evar_int cpt) in (mk_pattern t e, replace) @@ -290,14 +302,14 @@ and translate_act map pat Minils.Eapp ({ Minils.a_op = Minils.Eselect_slice; Minils.a_params = [idx1; idx2] }, [e], _) -> let cpt, cptd = fresh_it () in - let e = translate_extvalue map e in + let e = translate_extvalue_to_exp map e in let x = var_from_name map x in let t = match x.pat_ty with | Tarray (t,_) -> t | _ -> Misc.internal_error "mls2obc select slice type" 5 in let idx = mk_exp_int (Eop (op_from_string "+", - [mk_evar_int cpt; mk_exp_int (Econst idx1) ])) in + [mk_evar_int cpt; mk_exp_static_int idx1 ])) in (* bound = (idx2 - idx1) + 1*) let bound = mk_static_int_op (op_from_string "+") [ mk_static_int 1; mk_static_int_op (op_from_string "-") [idx2;idx1] ] in @@ -309,10 +321,10 @@ and translate_act map pat let x = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.w_ty in let e1 = translate_extvalue map e1 in - let idx = List.map (translate_extvalue map) idx in - let p = pattern_of_idx_list (pattern_of_exp e1) idx in - let true_act = Aassgn (x, mk_exp p.pat_ty (Epattern p)) in - let false_act = Aassgn (x, translate_extvalue map e2) in + let idx = List.map (translate_extvalue_to_exp map) idx in + let w = extvalue_of_idx_list e1 idx in + let true_act = Aassgn (x, mk_exp w.w_ty (Eextvalue w)) in + let false_act = Aassgn (x, translate_extvalue_to_exp map e2) in let cond = bound_check_expr idx bounds in [ mk_ifthenelse cond [true_act] [false_act] ] @@ -320,16 +332,16 @@ and translate_act map pat let x = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.w_ty in let e1 = translate_extvalue map e1 in - let idx = List.map (translate_extvalue map) idx in - let p = pattern_of_trunc_idx_list (pattern_of_exp e1) idx in - [Aassgn (x, mk_exp p.pat_ty (Epattern p))] + let idx = List.map (translate_extvalue_to_exp map) idx in + let w = ext_value_of_trunc_idx_list e1 idx in + [Aassgn (x, mk_exp w.w_ty (Eextvalue w))] | Minils.Evarpat x, Minils.Eapp ({ Minils.a_op = Minils.Eupdate }, e1::e2::idx, _) -> let x = var_from_name map x in let bounds = Mls_utils.bounds_list e1.Minils.w_ty in - let idx = List.map (translate_extvalue map) idx in - let e1 = translate_extvalue map e1 in - let e2 = translate_extvalue map e2 in + let idx = List.map (translate_extvalue_to_exp map) idx in + let e1 = translate_extvalue_to_exp map e1 in + let e2 = translate_extvalue_to_exp map e2 in let cond = bound_check_expr idx bounds in let true_act = update_array x e1 idx e2 in let false_act = Aassgn (x, e1) in @@ -340,8 +352,8 @@ and translate_act map pat Minils.a_params = [{ se_desc = Sfield f }] }, [e1; e2], _) -> let x = var_from_name map x in let e1 = translate_extvalue map e1 in - let e2 = translate_extvalue map e2 in - update_record x (pattern_of_exp e1) f e2 + let e2 = translate_extvalue_to_exp map e2 in + update_record x e1 f e2 | Minils.Evarpat n, _ -> [Aassgn (var_from_name map n, translate map act)] @@ -378,8 +390,8 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } let x = var_from_name map n in let si = (match opt_c with | None -> si - | Some c -> (Aassgn (x, mk_exp x.pat_ty (Econst c))) :: si) in - let action = Aassgn (var_from_name map n, translate_extvalue map e) in + | Some c -> (Aassgn (x, mk_ext_value_static x.pat_ty c)) :: si) in + let action = Aassgn (var_from_name map n, translate_extvalue_to_exp map e) in v, si, j, (control map ck action) :: s (* should be unnecessary | Minils.Etuplepat p_list, @@ -391,15 +403,15 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } p_list act_list (v, si, j, s) *) | pat, Minils.Eapp({ Minils.a_op = Minils.Eifthenelse }, [e1;e2;e3], _) -> - let cond = translate_extvalue map e1 in + let cond = translate_extvalue_to_exp map e1 in let true_act = translate_act_extvalue map pat e2 in let false_act = translate_act_extvalue map pat e3 in let action = mk_ifthenelse cond true_act false_act in - v, si, j, (control map ck action) :: s + v, si, j, (control map ck action) :: s | 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_extvalue map) e_list in + let name_list = translate_pat map e.Minils.e_ty pat in + let c_list = List.map (translate_extvalue_to_exp map) e_list in let v', si', j', action = mk_node_call map call_context app loc name_list c_list e.Minils.e_ty in let action = List.map (control map ck) action in @@ -412,9 +424,9 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } v' @ v, si'@si, j'@j, s | pat, Minils.Eiterator (it, app, n, pe_list, e_list, reset) -> - let name_list = translate_pat map pat in - let p_list = List.map (translate_extvalue map) pe_list in - let c_list = List.map (translate_extvalue map) e_list in + let name_list = translate_pat map e.Minils.e_ty pat in + let p_list = List.map (translate_extvalue_to_exp map) pe_list in + let c_list = List.map (translate_extvalue_to_exp map) e_list in let x, xd = fresh_it () in let call_context = Some { oa_index = mk_pattern_int (Lvar x); oa_size = n} in @@ -439,7 +451,7 @@ let rec translate_eq map call_context { Minils.eq_lhs = pat; Minils.eq_rhs = e } and translate_eq_list 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 ty = +and mk_node_call map call_context app loc (name_list : Obc.pattern list) args ty = match app.Minils.a_op with | Minils.Efun f when Mls_utils.is_op f -> let act = match name_list with @@ -452,12 +464,13 @@ and mk_node_call map call_context app loc name_list args ty = [], [], [], [act] | Minils.Enode f when Itfusion.is_anon_node f -> - let add_input env vd = Env.add vd.Minils.v_ident - (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in + let add_input env vd = + Env.add vd.Minils.v_ident + (mk_pattern vd.Minils.v_type (Lvar vd.Minils.v_ident)) env in let build env vd a = Env.add vd.Minils.v_ident a env in let subst_act_list env act_list = let exp funs env e = match e.e_desc with - | Epattern { pat_desc = Lvar x } -> + | Eextvalue { w_desc = Wvar x } -> let e = (try Env.find x env with Not_found -> e) in @@ -541,7 +554,7 @@ and translate_iterator map call_context it name_list let node_out_ty = Types.prod ty_list in let v, si, j, action = mk_node_call map call_context app loc (name_list @ [ acc_out ]) - (p_list @ c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) + (p_list @ c_list @ [ exp_of_pattern acc_out ]) node_out_ty in let v = translate_var_dec v in @@ -556,7 +569,7 @@ and translate_iterator map call_context it name_list let acc_out = last_element name_list in let v, si, j, action = mk_node_call map call_context app loc name_list - (p_list @ c_list @ [ mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + (p_list @ c_list @ [ exp_of_pattern acc_out ]) ty in let v = translate_var_dec v in let b = mk_block ~locals:v action in @@ -569,8 +582,7 @@ and translate_iterator map call_context it name_list let c_list = array_of_input c_list in let acc_out = last_element name_list in let v, si, j, action = mk_node_call map call_context app loc name_list - (p_list @ c_list @ [ mk_evar_int x; - mk_exp acc_out.pat_ty (Epattern acc_out) ]) ty + (p_list @ c_list @ [ mk_evar_int x; exp_of_pattern acc_out ]) ty in let v = translate_var_dec v in let b = mk_block ~locals:v action in diff --git a/compiler/obc/c/c.ml b/compiler/obc/c/c.ml index 06bab9f..f311fbe 100644 --- a/compiler/obc/c/c.ml +++ b/compiler/obc/c/c.ml @@ -70,11 +70,14 @@ and cexpr = | Cuop of string * cexpr (** Unary operator with its name. *) | Cbop of string * cexpr * cexpr (** Binary operator. *) | Cfun_call of string * cexpr list (** Function call with its parameters. *) - | Cconst of cconst (** Constants. *) - | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) - | Caddrof of clhs (** Take the address of a left-hand-side expression. *) + | Caddrof of cexpr (** Take the address of an expression. *) | Cstructlit of string * cexpr list (** Structure literal "{ f1, f2, ... }".*) | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *) + | Cconst of cconst (** Constants. *) + | Cvar of string (** A local variable. *) + | Cderef of cexpr (** Pointer dereference, *ptr. *) + | Cfield of cexpr * qualname (** Field access to left-hand-side. *) + | Carray of cexpr * cexpr (** Array access cexpr[cexpr] *) and cconst = | Ccint of int (** Integer constant. *) | Ccfloat of float (** Floating-point number constant. *) @@ -82,10 +85,10 @@ and cconst = | Cstrlit of string (** String literal, enclosed in double-quotes. *) (** C left-hand-side (ie. affectable) expressions. *) and clhs = - | Cvar of string (** A local variable. *) - | Cderef of clhs (** Pointer dereference, *ptr. *) - | Cfield of clhs * qualname (** Field access to left-hand-side. *) - | Carray of clhs * cexpr (** Array access clhs[cexpr] *) + | CLvar of string (** A local variable. *) + | CLderef of clhs (** Pointer dereference, *ptr. *) + | CLfield of clhs * qualname (** Field access to left-hand-side. *) + | CLarray of clhs * cexpr (** Array access clhs[cexpr] *) (** C statements. *) and cstm = | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *) @@ -234,29 +237,34 @@ and pp_cexpr fmt ce = match ce with | Cbop (s, l, r) -> fprintf fmt "(%a%s%a)" pp_cexpr l s pp_cexpr r | Cfun_call (s, el) -> fprintf fmt "%a(@[%a@])" pp_string s (pp_list1 pp_cexpr ",") el - | Cconst (Ccint i) -> fprintf fmt "%d" i - | Cconst (Ccfloat f) -> fprintf fmt "%f" f - | Cconst (Ctag "true") -> fprintf fmt "true" - | Cconst (Ctag "false") -> fprintf fmt "false" - | Cconst (Ctag t) -> pp_string fmt t - | Cconst (Cstrlit t) -> fprintf fmt "\"%s\"" t - | Clhs lhs -> fprintf fmt "%a" pp_clhs lhs - | Caddrof lhs -> fprintf fmt "&%a" pp_clhs lhs + | Caddrof e -> fprintf fmt "&%a" pp_cexpr e | Cstructlit (s, el) -> fprintf fmt "(%a){@[%a@]}" pp_string s (pp_list1 pp_cexpr ",") el | Carraylit el -> (* TODO master : WRONG *) fprintf fmt "((int []){@[%a@]})" (pp_list1 pp_cexpr ",") el - -and pp_clhs fmt lhs = match lhs with + | Cconst c -> pp_cconst fmt c | Cvar s -> pp_string fmt s - | Cderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' - | Cfield (Cderef lhs, f) -> fprintf fmt "%a->%a" pp_clhs lhs pp_qualname f - | Cfield (lhs, f) -> fprintf fmt "%a.%a" pp_clhs lhs pp_qualname f - | Carray (lhs, e) -> + | Cderef e -> fprintf fmt "*%a" pp_cexpr e + | Cfield (Cderef e, f) -> fprintf fmt "%a->%a" pp_cexpr e pp_qualname f + | Cfield (e, f) -> fprintf fmt "%a.%a" pp_cexpr e pp_qualname f + | Carray (e1, e2) -> fprintf fmt "%a[%a]" pp_cexpr e1 pp_cexpr e2 + +and pp_clhs fmt clhs = match clhs with + | CLvar s -> pp_string fmt s + | CLderef lhs' -> fprintf fmt "*%a" pp_clhs lhs' + | CLfield (CLderef lhs, f) -> fprintf fmt "%a->%a" pp_clhs lhs pp_qualname f + | CLfield (lhs, f) -> fprintf fmt "%a.%a" pp_clhs lhs pp_qualname f + | CLarray (lhs, e) -> fprintf fmt "%a[%a]" pp_clhs lhs pp_cexpr e +and pp_cconst fmt cconst = match cconst with + | Ccint i -> fprintf fmt "%d" i + | Ccfloat f -> fprintf fmt "%f" f + | Ctag t -> pp_string fmt t + | Cstrlit t -> fprintf fmt "\"%s\"" t + let pp_cdecl fmt cdecl = match cdecl with | Cdecl_enum (s, sl) -> fprintf fmt "@[@[typedef enum {@ %a@]@ } %a;@ @]@\n" @@ -322,12 +330,6 @@ let output dir cprog = (** { Lexical conversions to C's syntax } *) -(** Converts an expression to a lhs. *) -let lhs_of_exp e = - match e with - | Clhs e -> e - | _ -> assert false - (** Returns the type of a pointer to a type, except for types which are already pointers. *) let pointer_to ty = @@ -347,4 +349,5 @@ let rec array_base_ctype ty idx_list = match ty, idx_list with | Cty_arr (_, ty), [_] -> ty | Cty_arr (_, ty), _::idx_list -> array_base_ctype ty idx_list - | _ -> assert false + | _ -> + assert false diff --git a/compiler/obc/c/c.mli b/compiler/obc/c/c.mli deleted file mode 100644 index 0acea8d..0000000 --- a/compiler/obc/c/c.mli +++ /dev/null @@ -1,135 +0,0 @@ -(**************************************************************************) -(* *) -(* Heptagon *) -(* *) -(* Author : Marc Pouzet *) -(* Organization : Demons, LRI, University of Paris-Sud, Orsay *) -(* *) -(**************************************************************************) - -(** Abstract syntax tree for C programs. *) -(** {2 C abstract syntax tree } *) - -(** Here is the C abstract syntax tree used by MiniLS for its C backend. It does - not try to completly model the C language, only the relatively small part - that were are interested in (e.g. no function pointers or local variable - initialization). *) - -(** C types relevant for Obc. Note the absence of function pointers. *) -type cty = - | Cty_int (** C machine-dependent integer type. *) - | Cty_float (** C machine-dependent single-precision floating-point type. *) - | Cty_char (** C character type. *) - | Cty_id of Names.qualname - (** Previously defined C type, such as an enum or struct.*) - | Cty_ptr of cty (** C points-to-other-type type. *) - | Cty_arr of int * cty (** A static array of the specified size. *) - | Cty_void (** Well, [void] is not really a C type. *) - -(** A C block: declarations and statements. In source code form, it begins with - variable declarations before a list of semicolon-separated statements, the - whole thing being enclosed in curly braces. *) -type cblock = { - (** Variable declarations, where each declaration consists of a variable - name and the associated C type. *) - var_decls : (string * cty) list; - (** The actual statement forming our block. *) - block_body : cstm list; -} - -(** C expressions. *) -and cexpr = - | Cuop of string * cexpr (** Unary operator with its name. *) - | Cbop of string * cexpr * cexpr (** Binary operator. *) - | Cfun_call of string * cexpr list (** Function call with its parameters. *) - | Cconst of cconst (** Constants. *) - | Clhs of clhs (** Left-hand-side expressions are obviously expressions! *) - | Caddrof of clhs (** Take the address of a left-hand-side expression. *) - | Cstructlit of string * cexpr list (** Structure literal [{f1, f2, ... }]. *) - | Carraylit of cexpr list (** Array literal [\[e1, e2, ...\]]. *) -and cconst = - | Ccint of int (** Integer constant. *) - | Ccfloat of float (** Floating-point number constant. *) - | Ctag of string (** Tag, member of a previously declared enumeration. *) - | Cstrlit of string (** String literal, enclosed in double-quotes. *) -(** C left-hand-side (ie. affectable) expressions. *) -and clhs = - | Cvar of string (** A local variable. *) - | Cderef of clhs (** Pointer dereference, *ptr. *) - | Cfield of clhs * Names.qualname (** Field access to left-hand-side. *) - | Carray of clhs * cexpr (** Array access clhs[cexpr] *) -(** C statements. *) -and cstm = - | Csexpr of cexpr (** Expression evaluation, may cause side-effects! *) - | Csblock of cblock (** A local sub-block, can have its own private decls. **) - | Cskip (** A dummy instruction that does nothing and will not be printed. *) - | Caffect of clhs * cexpr (** Affect the result of an expression to a lhs. *) - | Cif of cexpr * cstm list * cstm list (** Alternative *) - | Cswitch of cexpr * (string * cstm list) list (** Case/switch over an enum.*) - | Cwhile of cexpr * cstm list (** While loop. *) - | Cfor of string * cexpr * cexpr * cstm list (** For loop. int <= string < int *) - | Creturn of cexpr (** Ends a procedure/function by returning an expression.*) - -(** C type declarations ; will {b always} correspond to a typedef in emitted - source code. *) -type cdecl = - (** C typedef declaration (type, alias)*) - | Cdecl_typedef of cty * string - (** C enum declaration, with associated value tags. *) - | Cdecl_enum of string * string list - (** C structure declaration, with each field's name and type. *) - | Cdecl_struct of string * (string * cty) list - (** C function declaration. *) - | Cdecl_function of string * cty * (string * cty) list - -(** C function definition *) -type cfundef = { - f_name : string; (** The function's name. *) - f_retty : cty; (** The function's return type. *) - f_args : (string * cty) list; (** Each parameter's name and type. *) - f_body : cblock; (** Actual instructions, in the form of a block. *) -} - -(** C top-level definitions. *) -type cdef = - | Cfundef of cfundef (** Function definition, see [cfundef]. *) - | Cvardef of string * cty (** A variable definition, with its name and type.*) - -val cdecl_of_cfundef : cdef -> cdecl - -(** A C file can be a source file, containing definitions, or a header file, - containing declarations. *) -type cfile_desc = - | Cheader of string list * cdecl list (** Header dependencies * declaration - list *) - | Csource of cdef list - -type cfile = string * cfile_desc (** File name * file content *) - -(** [output dir cprog] pretty-prints the C program [cprog] to new files in the - directory [dir]. *) -val output : string -> cfile list -> unit - -(** [cname_of_name name] translates the string [name] to a valid C identifier. - Copied verbatim from the old C backend. *) -val cname_of_name : string -> string -(** [cname_of_name q] translates the qualified name [q] - to a valid C identifier. *) -val cname_of_qn : Names.qualname -> string - -(** Converts an expression to a lhs. *) -val lhs_of_exp : cexpr -> clhs - -(** Returns the type of a pointer to a type, except for - types which are already pointers. *) -val pointer_to : cty -> cty - -(** Returns whether a type is a pointer. *) -val is_pointer_type : cty -> bool - -(** [array_base_ctype ty idx_list] returns the base type of an array - type. If idx_list = [i1; ..; ip] and a is a variable of type ty, - then it returns a[i1]..[ip]. *) -val array_base_ctype : cty -> int list -> cty - - diff --git a/compiler/obc/c/cgen.ml b/compiler/obc/c/cgen.ml index 0fbf86e..bfb6c5c 100644 --- a/compiler/obc/c/cgen.ml +++ b/compiler/obc/c/cgen.ml @@ -138,56 +138,50 @@ let csubscript_of_idx_list e idx_list = represents the bounds of these two arrays. *) let rec copy_array src dest bounds = match bounds with - | [] -> [Caffect (dest, Clhs src)] + | [] -> [Caffect (dest, src)] | n::bounds -> let x = gen_symbol () in [Cfor(x, Cconst (Ccint 0), n, - copy_array (Carray (src, Clhs (Cvar x))) - (Carray (dest, Clhs (Cvar x))) bounds)] - -(** Returns the type associated with the name [n] - in the environnement [var_env] (which is an association list - mapping strings to cty). *) -let rec assoc_type n var_env = - match var_env with - | [] -> Error.message no_location (Error.Evar n) - | (vn,ty)::var_env -> - if vn = n then - ty - else - assoc_type n var_env + copy_array (Carray (src, Cvar x)) + (CLarray (dest, Cvar x)) bounds)] (** @return the unaliased version of a type. *) -let rec unalias_ctype = function +let rec unalias_ctype cty = match cty with | Cty_id ty_name -> - (try - match find_type ty_name with - | Talias ty -> unalias_ctype (ctype_of_otype ty) - | _ -> Cty_id ty_name - with Not_found -> Cty_id ty_name) + (try match find_type ty_name with + | Talias ty -> unalias_ctype (ctype_of_otype ty) + | _ -> Cty_id ty_name + with Not_found -> Cty_id ty_name) | Cty_arr (n, cty) -> Cty_arr (n, unalias_ctype cty) | Cty_ptr cty -> Cty_ptr (unalias_ctype cty) | cty -> cty +(** Returns the type associated with the name [n] + in the environnement [var_env] (which is an association list + mapping strings to cty). *) +and assoc_type n var_env = + try unalias_ctype (List.assoc n var_env) + with Not_found -> Error.message no_location (Error.Evar n) + (** Returns the type associated with the lhs [lhs] in the environnement [var_env] (which is an association list mapping strings to cty).*) -let rec assoc_type_lhs lhs var_env = - match lhs with - | Cvar x -> unalias_ctype (assoc_type x var_env) - | Carray (lhs, _) -> - let ty = assoc_type_lhs lhs var_env in - array_base_ctype ty [1] - | Cderef lhs -> - (match assoc_type_lhs lhs var_env with - | Cty_ptr ty -> ty - | _ -> Error.message no_location Error.Ederef_not_pointer) - | Cfield(Cderef (Cvar "self"), { name = x }) -> assoc_type x var_env - | Cfield(x, f) -> - let ty = assoc_type_lhs x var_env in - let n = struct_name ty in - let fields = find_struct n in - ctype_of_otype (field_assoc f fields) +let rec assoc_type_lhs lhs var_env = match lhs with + | CLvar x -> unalias_ctype (assoc_type x var_env) + | CLarray (lhs, _) -> + let ty = assoc_type_lhs lhs var_env in + array_base_ctype ty [1] + | CLderef lhs -> + (match assoc_type_lhs lhs var_env with + | Cty_ptr ty -> ty + | _ -> Error.message no_location Error.Ederef_not_pointer) + | CLfield(CLderef (CLvar "self"), { name = x }) -> assoc_type x var_env + | CLfield(CLderef (CLvar "out"), { name = x }) -> assoc_type x var_env + | CLfield(x, f) -> + let ty = assoc_type_lhs x var_env in + let n = struct_name ty in + let fields = find_struct n in + ctype_of_otype (field_assoc f fields) (** Creates the statement a = [e_1, e_2, ..], which gives a list a[i] = e_i.*) @@ -195,7 +189,7 @@ let rec create_affect_lit dest l ty = let rec _create_affect_lit dest i = function | [] -> [] | v::l -> - let stm = create_affect_stm (Carray (dest, Cconst (Ccint i))) v ty in + let stm = create_affect_stm (CLarray (dest, Cconst (Ccint i))) v ty in stm@(_create_affect_lit dest (i+1) l) in _create_affect_lit dest 0 l @@ -206,12 +200,13 @@ and create_affect_stm dest src ty = | Cty_arr (n, bty) -> (match src with | Carraylit l -> create_affect_lit dest l bty - | Clhs src -> - let x = gen_symbol () in - [Cfor(x, Cconst (Ccint 0), Cconst (Ccint n), - create_affect_stm (Carray (dest, Clhs (Cvar x))) - (Clhs (Carray (src, Clhs (Cvar x)))) bty)] - | _ -> assert false (** TODO: add missing cases eg for records *) + | src -> + let x = gen_symbol () in + [Cfor(x, + Cconst (Ccint 0), Cconst (Ccint n), + create_affect_stm + (CLarray (dest, Cvar x)) + (Carray (src, Cvar x)) bty)] ) | Cty_id ln -> (match src with @@ -219,22 +214,17 @@ and create_affect_stm dest src ty = let create_affect { f_name = f_name; Signature.f_type = f_type; } e stm_list = let cty = ctype_of_otype f_type in - create_affect_stm (Cfield (dest, f_name)) e cty @ stm_list in + create_affect_stm (CLfield (dest, f_name)) e cty @ stm_list in List.fold_right2 create_affect (find_struct ln) ce_list [] | _ -> [Caffect (dest, src)]) | _ -> [Caffect (dest, src)] (** Returns the expression to use e as an argument of a function expecting a pointer as argument. *) -let address_of e = -(* try *) - let lhs = lhs_of_exp e in - match lhs with - | Carray _ -> Clhs lhs - | Cderef lhs -> Clhs lhs - | _ -> Caddrof lhs -(* with _ -> - e *) +let address_of e = match e with + | Carray _ -> e + | Cderef e -> e + | _ -> Caddrof e let rec cexpr_of_static_exp se = match se.se_desc with @@ -271,27 +261,21 @@ let rec cexpr_of_static_exp se = (** [cexpr_of_exp exp] translates the Obj action [exp] to a C expression. *) -let rec cexpr_of_exp var_env exp = +let rec cexpr_of_exp out_env var_env exp = match exp.e_desc with - (** Obj expressions that form valid C lhs are translated via clhs_of_exp. *) - | Epattern _ -> - Clhs (clhs_of_exp var_env exp) - (** Constants, the easiest translation. *) - | Econst lit -> - cexpr_of_static_exp lit - (** Operators *) - | Eop(op, exps) -> - cop_of_op var_env op exps - (** Structure literals. *) + | Eextvalue w -> cexpr_of_ext_value out_env var_env w + (** Operators *) + | Eop(op, exps) -> cop_of_op out_env var_env op exps + (** Structure literals. *) | Estruct (tyn, fl) -> - let cexps = List.map (fun (_,e) -> cexpr_of_exp var_env e) fl in + let cexps = List.map (fun (_,e) -> cexpr_of_exp out_env var_env e) fl in let ctyn = cname_of_qn tyn in Cstructlit (ctyn, cexps) | Earray e_list -> - Carraylit (cexprs_of_exps var_env e_list) + Carraylit (cexprs_of_exps out_env var_env e_list) -and cexprs_of_exps var_env exps = - List.map (cexpr_of_exp var_env) exps +and cexprs_of_exps out_env var_env exps = + List.map (cexpr_of_exp out_env var_env) exps and cop_of_op_aux op_name cexps = match op_name with | { qual = Pervasives; name = op } -> @@ -307,38 +291,92 @@ and cop_of_op_aux op_name cexps = match op_name with Cbop (copname op, el, er) | _ -> Cfun_call(op, cexps) end - | {qual = m; name = op} -> Cfun_call(op,cexps) + | { name = op; _ } -> Cfun_call(op,cexps) -and cop_of_op var_env op_name exps = - let cexps = cexprs_of_exps var_env exps in +and cop_of_op out_env var_env op_name exps = + let cexps = cexprs_of_exps out_env var_env exps in cop_of_op_aux op_name cexps -and clhs_of_lhs var_env l = match l.pat_desc with +and clhs_of_pattern out_env var_env l = match l.pat_desc with (** Each Obc variable corresponds to a real local C variable. *) | Lvar v -> let n = name v in + let n_lhs = + if IdentSet.mem v out_env + then CLfield (CLderef (CLvar "out"), local_qn n) + else CLvar n + in + if List.mem_assoc n var_env then let ty = assoc_type n var_env in (match ty with - | Cty_ptr _ -> Cderef (Cvar n) - | _ -> Cvar n + | Cty_ptr _ -> CLderef n_lhs + | _ -> n_lhs ) else - Cvar n + n_lhs + (** Dereference our [self] struct holding the node's memory. *) + | Lmem v -> CLfield (CLderef (CLvar "self"), local_qn (name v)) + (** Field access. /!\ Indexed Obj expression should be a valid lhs! *) + | Lfield (l, fn) -> CLfield(clhs_of_pattern out_env var_env l, fn) + | Larray (l, idx) -> + CLarray(clhs_of_pattern out_env var_env l, + cexpr_of_exp out_env var_env idx) + +and clhs_list_of_pattern_list out_env var_env lhss = + List.map (clhs_of_pattern out_env var_env) lhss + +and cexpr_of_pattern out_env var_env l = match l.pat_desc with + (** Each Obc variable corresponds to a real local C variable. *) + | Lvar v -> + let n = name v in + let n_lhs = + if IdentSet.mem v out_env + then Cfield (Cderef (Cvar "out"), local_qn n) + else Cvar n + in + + if List.mem_assoc n var_env then + let ty = assoc_type n var_env in + (match ty with + | Cty_ptr _ -> Cderef n_lhs + | _ -> n_lhs + ) + else + n_lhs (** Dereference our [self] struct holding the node's memory. *) | Lmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v)) (** Field access. /!\ Indexed Obj expression should be a valid lhs! *) - | Lfield (l, fn) -> Cfield(clhs_of_lhs var_env l, fn) + | Lfield (l, fn) -> Cfield(cexpr_of_pattern out_env var_env l, fn) | Larray (l, idx) -> - Carray(clhs_of_lhs var_env l, cexpr_of_exp var_env idx) + Carray(cexpr_of_pattern out_env var_env l, + cexpr_of_exp out_env var_env idx) -and clhss_of_lhss var_env lhss = - List.map (clhs_of_lhs var_env) lhss +and cexpr_of_ext_value out_env var_env w = match w.w_desc with + | Wconst c -> cexpr_of_static_exp c + (** Each Obc variable corresponds to a plain local C variable. *) + | Wvar v -> + let n = name v in + let n_lhs = + if IdentSet.mem v out_env + then Cfield (Cderef (Cvar "out"), local_qn n) + else Cvar n + in -and clhs_of_exp var_env exp = match exp.e_desc with - | Epattern l -> clhs_of_lhs var_env l - (** We were passed an expression that is not translatable to a valid C lhs?!*) - | _ -> invalid_arg "clhs_of_exp: argument not a Var, Mem or Field" + if List.mem_assoc n var_env then + let ty = assoc_type n var_env in + (match ty with + | Cty_ptr _ -> Cderef n_lhs + | _ -> n_lhs) + else + n_lhs + (** Dereference our [self] struct holding the node's memory. *) + | Wmem v -> Cfield (Cderef (Cvar "self"), local_qn (name v)) + (** Field access. /!\ Indexed Obj expression should be a valid lhs! *) + | Wfield (l, fn) -> Cfield(cexpr_of_ext_value out_env var_env l, fn) + | Warray (l, idx) -> + Carray(cexpr_of_ext_value out_env var_env l, + cexpr_of_exp out_env var_env idx) let rec assoc_obj instance obj_env = match obj_env with @@ -361,14 +399,14 @@ let out_var_name_of_objn o = (** Creates the list of arguments to call a node. [targeting] is the targeting of the called node, [mem] represents the node context and [args] the argument list.*) -let step_fun_call var_env sig_info objn out args = +let step_fun_call out_env var_env sig_info objn out args = if sig_info.node_stateful then ( let mem = (match objn with | Oobj o -> Cfield (Cderef (Cvar "self"), local_qn (name o)) | Oarray (o, l) -> - let l = clhs_of_lhs var_env l in - Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), Clhs l) + let l = cexpr_of_pattern out_env var_env l in + Carray (Cfield (Cderef (Cvar "self"), local_qn (name o)), l) ) in args@[Caddrof out; Caddrof mem] ) else @@ -378,7 +416,7 @@ let step_fun_call var_env sig_info objn out args = [outvl] is a list of lhs where to put the results. [args] is the list of expressions to use as arguments. [mem] is the lhs where is stored the node's context.*) -let generate_function_call var_env obj_env outvl objn args = +let generate_function_call out_env var_env obj_env outvl objn args = (** Class name for the object to step. *) let classln = assoc_cn objn obj_env in let classn = cname_of_qn classln in @@ -391,7 +429,7 @@ let generate_function_call var_env obj_env outvl objn args = else (** The step function takes scalar arguments and its own internal memory holding structure. *) - let args = step_fun_call var_env sig_info objn out args in + let args = step_fun_call out_env var_env sig_info objn out args in (** Our C expression for the function call. *) Cfun_call (classn ^ "_step", args) in @@ -409,18 +447,17 @@ let generate_function_call var_env obj_env outvl objn args = let out_sig = output_names_list sig_info in let create_affect outv out_name = let ty = assoc_type_lhs outv var_env in - create_affect_stm outv (Clhs (Cfield (out, local_qn out_name))) ty + create_affect_stm outv (Cfield (out, local_qn out_name)) ty in (Csexpr fun_call)::(List.flatten (map2 create_affect outvl out_sig)) (** Create the statement dest = c where c = v^n^m... *) -let rec create_affect_const var_env dest c = +let rec create_affect_const var_env (dest : clhs) c = match c.se_desc with | Svar ln -> let se = Static.simplify QualEnv.empty (find_const ln).c_value in create_affect_const var_env dest se | Sarray_power(c, n_list) -> - let rec make_loop power_list replace = match power_list with | [] -> dest, replace | p :: power_list -> @@ -428,20 +465,20 @@ let rec create_affect_const var_env dest c = let e, replace = make_loop power_list (fun y -> [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp p, replace y)]) in - let e = (Carray (e, Clhs (Cvar x))) in + let e = (CLarray (e, Cvar x)) in e, replace in let e, b = make_loop n_list (fun y -> y) in b (create_affect_const var_env e c) | Sarray cl -> let create_affect_idx c (i, affl) = - let dest = Carray (dest, Cconst (Ccint i)) in + let dest = CLarray (dest, Cconst (Ccint i)) in (i - 1, create_affect_const var_env dest c @ affl) in snd (List.fold_right create_affect_idx cl (List.length cl - 1, [])) | Srecord f_se_list -> let affect_field affl (f, se) = - let dest_f = Cfield (dest, f) in + let dest_f = CLfield (dest, f) in (create_affect_const var_env dest_f se) @ affl in List.fold_left affect_field [] f_se_list @@ -450,23 +487,23 @@ let rec create_affect_const var_env dest c = (** [cstm_of_act obj_env mods act] translates the Obj action [act] to a list of C statements, using the association list [obj_env] to map object names to class names. *) -let rec cstm_of_act var_env obj_env act = +let rec cstm_of_act out_env var_env obj_env act = match act with (** Cosmetic : cases on boolean values are converted to if statements. *) | Acase (c, [({name = "true"}, te); ({ name = "false" }, fe)]) | Acase (c, [({name = "false"}, fe); ({ name = "true"}, te)]) -> - let cc = cexpr_of_exp var_env c in - let cte = cstm_of_act_list var_env obj_env te in - let cfe = cstm_of_act_list var_env obj_env fe in + let cc = cexpr_of_exp out_env var_env c in + let cte = cstm_of_act_list out_env var_env obj_env te in + let cfe = cstm_of_act_list out_env var_env obj_env fe in [Cif (cc, cte, cfe)] | Acase (c, [({name = "true"}, te)]) -> - let cc = cexpr_of_exp var_env c in - let cte = cstm_of_act_list var_env obj_env te in + let cc = cexpr_of_exp out_env var_env c in + let cte = cstm_of_act_list out_env var_env obj_env te in let cfe = [] in [Cif (cc, cte, cfe)] | Acase (c, [({name = "false"}, fe)]) -> - let cc = Cuop ("!", (cexpr_of_exp var_env c)) in - let cte = cstm_of_act_list var_env obj_env fe in + let cc = Cuop ("!", (cexpr_of_exp out_env var_env c)) in + let cte = cstm_of_act_list out_env var_env obj_env fe in let cfe = [] in [Cif (cc, cte, cfe)] @@ -480,35 +517,36 @@ let rec cstm_of_act var_env obj_env act = let ccl = List.map (fun (c,act) -> cname_of_qn c, - cstm_of_act_list var_env obj_env act) cl in - [Cswitch (cexpr_of_exp var_env e, ccl)] + cstm_of_act_list out_env var_env obj_env act) cl in + [Cswitch (cexpr_of_exp out_env var_env e, ccl)] | Ablock b -> - cstm_of_act_list var_env obj_env b + cstm_of_act_list out_env var_env obj_env b (** For composition of statements, just recursively apply our translation function on sub-statements. *) | Afor ({ v_ident = x }, i1, i2, act) -> - [Cfor(name x, cexpr_of_exp var_env i1, - cexpr_of_exp var_env i2, cstm_of_act_list var_env obj_env act)] + [Cfor(name x, cexpr_of_exp out_env var_env i1, + cexpr_of_exp out_env var_env i2, + cstm_of_act_list out_env var_env obj_env act)] - (** Special case for x = 0^n^n...*) - | Aassgn (vn, { e_desc = Econst c }) -> - let vn = clhs_of_lhs var_env vn in + (** Translate constant assignment *) + | Aassgn (vn, { e_desc = Eextvalue { w_desc = Wconst c; _}; }) -> + let vn = clhs_of_pattern out_env var_env vn in create_affect_const var_env vn c (** Purely syntactic translation from an Obc local variable to a C local one, with recursive translation of the rhs expression. *) | Aassgn (vn, e) -> - let vn = clhs_of_lhs var_env vn in + let vn = clhs_of_pattern out_env var_env vn in let ty = assoc_type_lhs vn var_env in - let ce = cexpr_of_exp var_env e in + let ce = cexpr_of_exp out_env var_env e in create_affect_stm vn ce ty (** Our Aop marks an operator invocation that will perform side effects. Just translate to a simple C statement. *) | Aop (op_name, args) -> - [Csexpr (cop_of_op var_env op_name args)] + [Csexpr (cop_of_op out_env var_env op_name args)] (** Reinitialization of an object variable, extracting the reset function's name from our environment [obj_env]. *) @@ -525,7 +563,7 @@ let rec cstm_of_act var_env obj_env act = | Some size -> let x = gen_symbol () in let field = Cfield (Cderef (Cvar "self"), local_qn (name on)) in - let elt = [Caddrof( Carray(field, Clhs (Cvar x)) )] in + let elt = [Caddrof( Carray(field, Cvar x) )] in [Cfor(x, Cconst (Ccint 0), cexpr_of_static_exp size, [Csexpr (Cfun_call (classn ^ "_reset", elt ))] )] ) @@ -534,15 +572,15 @@ let rec cstm_of_act var_env obj_env act = local structure to hold the results, before allocating to our variables. *) | Acall (outvl, objn, Mstep, el) -> - let args = cexprs_of_exps var_env el in - let outvl = clhss_of_lhss var_env outvl in - generate_function_call var_env obj_env outvl objn args + let args = cexprs_of_exps out_env var_env el in + let outvl = clhs_list_of_pattern_list out_env var_env outvl in + generate_function_call out_env var_env obj_env outvl objn args -and cstm_of_act_list var_env obj_env b = +and cstm_of_act_list out_env 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 + let cstm = List.flatten (List.map (cstm_of_act out_env var_env obj_env) b.b_body) in match l with | [] -> cstm | _ -> @@ -593,12 +631,13 @@ let fun_def_of_step_fun n obj_env mem objs md = (** The body *) let mems = List.map cvar_of_vd (mem@md.m_outputs) in let var_env = args @ mems @ out_vars in - let body = cstm_of_act_list var_env obj_env md.m_body in - - (** Substitute the return value variables with the corresponding - context field*) - let map = Csubst.assoc_map_for_fun md in - let body = List.map (Csubst.subst_stm map) body in + let out_env = + List.fold_left + (fun out_env vd -> IdentSet.add vd.v_ident out_env) + IdentSet.empty + md.m_outputs + in + let body = cstm_of_act_list out_env var_env obj_env md.m_body in Cfundef { f_name = fun_name; @@ -648,7 +687,7 @@ let reset_fun_def_of_class_def cd = try let var_env = List.map cvar_of_vd cd.cd_mems in let reset = find_reset_method cd in - cstm_of_act_list var_env cd.cd_objs reset.m_body + cstm_of_act_list IdentSet.empty var_env cd.cd_objs reset.m_body with Not_found -> [] (* TODO C : nicely deal with stateless objects *) in Cfundef { @@ -725,7 +764,7 @@ let cdefs_and_cdecls_of_type_decl otd = block_body = let gen_if t = let t = cname_of_qn t in - let funcall = Cfun_call ("strcmp", [Clhs (Cvar "s"); + let funcall = Cfun_call ("strcmp", [Cvar "s"; Cconst (Cstrlit t)]) in let cond = Cbop ("==", funcall, Cconst (Ccint 0)) in Cif (cond, [Creturn (Cconst (Ctag t))], []) in @@ -741,11 +780,11 @@ let cdefs_and_cdecls_of_type_decl otd = let gen_clause t = let t = cname_of_qn t in let fun_call = - Cfun_call ("strcpy", [Clhs (Cvar "buf"); + Cfun_call ("strcpy", [Cvar "buf"; Cconst (Cstrlit t)]) in (t, [Csexpr fun_call]) in - [Cswitch (Clhs (Cvar "x"), map gen_clause nl); - Creturn (Clhs (Cvar "buf"))]; } + [Cswitch (Cvar "x", map gen_clause nl); + Creturn (Cvar "buf")]; } } in ([of_string_fun; to_string_fun], [Cdecl_enum (name, List.map cname_of_qn nl); diff --git a/compiler/obc/c/cmain.ml b/compiler/obc/c/cmain.ml index 37d1760..c7761a4 100644 --- a/compiler/obc/c/cmain.ml +++ b/compiler/obc/c/cmain.ml @@ -29,6 +29,9 @@ let _ = Idents.enter_node (Modules.fresh_value "cmain" "main") let fresh n = Idents.name (Idents.gen_var "cmain" n) +let mk_int i = Cconst (Ccint i) +let mk_float f = Cconst (Ccfloat f) + (* Unique names for C variables handling step counts. *) let step_counter = fresh "step_c" and max_step = fresh"step_max" @@ -76,14 +79,14 @@ let assert_node_res cd = :: (if cd.cd_stateful then [Caddrof (Cvar (fst (List.hd mem)))] else []))); - Cif (Cuop ("!", Clhs (Cfield (Cvar (fst out), local_qn outn))), + Cif (Cuop ("!", Cfield (Cvar (fst out), local_qn outn)), [Csexpr (Cfun_call ("fprintf", - [Clhs(Cvar "stderr"); - Cconst (Cstrlit ("Node \\\"" ^ name - ^ "\\\" failed at step" ^ - " %d.\\n")); - Clhs (Cvar step_counter)])); - Creturn (Cconst (Ccint 1))], + [Cvar "stderr"; + Cconst (Cstrlit ("Node \\\"" ^ name + ^ "\\\" failed at step" ^ + " %d.\\n")); + Cvar step_counter])); + Creturn (mk_int 1)], []); ]; } in @@ -116,9 +119,9 @@ let main_def_of_class_def cd = let rec read_lhs_of_ty lhs ty = match ty with | Tarray (ty, n) -> let iter_var = fresh "i" in - let lhs = Carray (lhs, Clhs (Cvar iter_var)) in + let lhs = Carray (lhs, Cvar iter_var) in let (reads, bufs) = read_lhs_of_ty lhs ty in - ([Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, reads)], bufs) + ([Cfor (iter_var, mk_int 0, cexpr_of_static_exp n, reads)], bufs) | _ -> let rec mk_prompt lhs = match lhs with | Cvar vn -> (vn, []) @@ -136,8 +139,8 @@ let main_def_of_class_def cd = let body = if !Compiler_options.hepts_simulation then (* hepts: systematically test and quit when EOF *) - [Cif(Cbop("==",exp_scanf,Clhs(Cvar("EOF"))), - [Creturn(Cconst(Ccint(0)))],[])] + [Cif(Cbop("==",exp_scanf,Cvar("EOF")), + [Creturn(mk_int 0)],[])] else [Csexpr (exp_scanf);] in let body = @@ -156,7 +159,7 @@ let main_def_of_class_def cd = let varn = fresh "buf" in ([scan_exp; Csexpr (Cfun_call (tyn ^ "_of_string", - [Clhs (Cvar varn)]))], + [Cvar varn]))], [(varn, Cty_arr (20, Cty_char))]) in (** Generates printf statements and buffer declarations needed for printing @@ -164,10 +167,10 @@ let main_def_of_class_def cd = let rec write_lhs_of_ty lhs ty = match ty with | Tarray (ty, n) -> let iter_var = fresh "i" in - let lhs = Carray (lhs, Clhs (Cvar iter_var)) in + let lhs = Carray (lhs, Cvar iter_var) in let (writes, bufs) = write_lhs_of_ty lhs ty in - let writes_loop = - Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, writes) in + let writes_loop = + Cfor (iter_var, mk_int 0, cexpr_of_static_exp n, writes) in if !Compiler_options.hepts_simulation then ([writes_loop], bufs) else @@ -183,10 +186,10 @@ let main_def_of_class_def cd = else format_s ^ " " in let nbuf_opt = need_buf_for_ty ty in let ep = match nbuf_opt with - | None -> [Clhs lhs] + | None -> [lhs] | Some sid -> [Cfun_call ("string_of_" ^ sid, - [Clhs lhs; - Clhs (Cvar varn)])] in + [lhs; + Cvar varn])] in ([Csexpr (Cfun_call ("printf", Cconst (Cstrlit (format_s)) :: ep))], @@ -230,7 +233,7 @@ let main_def_of_class_def cd = let step_l = let funcall = let args = - map (fun vd -> Clhs (Cvar (name vd.v_ident))) stepm.m_inputs + map (fun vd -> Cvar (name vd.v_ident)) stepm.m_inputs @ (Caddrof (Cvar "res") :: if cd.cd_stateful then [Caddrof (Cvar "mem")] else []) in Cfun_call ((cname_of_qn cd.cd_name) ^ "_step", args) in @@ -241,7 +244,7 @@ let main_def_of_class_def cd = (if !Compiler_options.hepts_simulation then [] else [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]))]) - @ [Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in + @ [Csexpr (Cfun_call ("fflush", [Cvar "stdout"]))] in (** Do not forget to initialize memory via reset if needed. *) let rst_i = @@ -270,29 +273,29 @@ let main_skel var_list prologue body = if (argc == 2) max_step = atoi(argv[1]); *) - Caffect (Cvar step_counter, Cconst (Ccint 0)); - Caffect (Cvar max_step, Cconst (Ccint 0)); - Cif (Cbop ("==", Clhs (Cvar "argc"), Cconst (Ccint 2)), - [Caffect (Cvar max_step, + Caffect (CLvar step_counter, mk_int 0); + Caffect (CLvar max_step, mk_int 0); + Cif (Cbop ("==", Cvar "argc", mk_int 2), + [Caffect (CLvar max_step, Cfun_call ("atoi", - [Clhs (Carray (Cvar "argv", - Cconst (Ccint 1)))]))], []); + [Carray (Cvar "argv", + mk_int 1)]))], []); ] @ prologue (* while (!max_step || step_c < max_step) *) @ [ Cwhile (Cbop ("||", - Cuop ("!", Clhs (Cvar max_step)), + Cuop ("!", Cvar max_step), Cbop ("<", - Clhs (Cvar step_counter), - Clhs (Cvar max_step))), + Cvar step_counter, + Cvar max_step)), (* step_counter = step_counter + 1; *) - Caffect (Cvar step_counter, + Caffect (CLvar step_counter, Cbop ("+", - Clhs (Cvar step_counter), - Cconst (Ccint 1))) + Cvar step_counter, + mk_int 1)) :: body); - Creturn (Cconst (Ccint 0)); + Creturn (mk_int 0); ]; } } diff --git a/compiler/obc/c/csubst.ml b/compiler/obc/c/csubst.ml deleted file mode 100644 index 71829ab..0000000 --- a/compiler/obc/c/csubst.ml +++ /dev/null @@ -1,60 +0,0 @@ -open C -open Idents -open Names - -let rec subst_stm map stm = match stm with - | Csexpr e -> Csexpr (subst_exp map e) - | Cskip -> Cskip - | Creturn e -> Creturn (subst_exp map e) - | Csblock cblock -> - Csblock (subst_block map cblock) - | Caffect (lhs, e) -> - Caffect(subst_lhs map lhs, subst_exp map e) - | Cif (e, truel, falsel) -> - Cif (subst_exp map e, subst_stm_list map truel, - subst_stm_list map falsel) - | Cswitch (e, l) -> - Cswitch (subst_exp map e - , List.map (fun (s, sl) -> s, subst_stm_list map sl) l) - | Cwhile (e, l) -> - Cwhile (subst_exp map e, subst_stm_list map l) - | Cfor (x, i1, i2, l) -> - Cfor (x, i1, i2, subst_stm_list map l) - -and subst_stm_list map = - List.map (subst_stm map) - -and subst_lhs map lhs = - match lhs with - | Cvar n -> - if NamesEnv.mem n map then NamesEnv.find n map else lhs - | Cfield (lhs, s) -> Cfield (subst_lhs map lhs, s) - | Carray (lhs, n) -> Carray (subst_lhs map lhs, subst_exp map n) - | Cderef lhs -> Cderef (subst_lhs map lhs) - -and subst_exp map = function - | Cuop (op, e) -> Cuop (op, subst_exp map e) - | Cbop (s, l, r) -> Cbop (s, subst_exp map l, subst_exp map r) - | Cfun_call (s, el) -> Cfun_call (s, subst_exp_list map el) - | Cconst x -> Cconst x - | Clhs lhs -> Clhs (subst_lhs map lhs) - | Caddrof lhs -> Caddrof (subst_lhs map lhs) - | Cstructlit (s, el) -> Cstructlit (s, subst_exp_list map el) - | Carraylit el -> Carraylit (subst_exp_list map el) - -and subst_exp_list map = - List.map (subst_exp map) - -and subst_block map b = - { b with block_body = subst_stm_list map b.block_body } - -let assoc_map_for_fun md = - match md.Obc.m_outputs with - | [] -> NamesEnv.empty - | out -> - let fill_field map vd = - NamesEnv.add (name vd.Obc.v_ident) - (Cfield (Cderef (Cvar "out"), local_qn (name vd.Obc.v_ident))) map - in - List.fold_left fill_field NamesEnv.empty out - diff --git a/compiler/obc/control.ml b/compiler/obc/control.ml index 9fe3dfc..7b73da2 100644 --- a/compiler/obc/control.ml +++ b/compiler/obc/control.ml @@ -28,7 +28,9 @@ let rec find c = function let is_deadcode = function | Aassgn (lhs, e) -> (match e.e_desc with - | Epattern l -> l = lhs + | Eextvalue w -> + let w' = ext_value_of_pattern lhs in + w = w' (* TODO: proper compare *) | _ -> false ) | Acase (_, []) -> true diff --git a/compiler/obc/java/java.ml b/compiler/obc/java/java.ml index 7d00a34..27ee1ff 100644 --- a/compiler/obc/java/java.ml +++ b/compiler/obc/java/java.ml @@ -74,8 +74,7 @@ and act = Anewvar of var_dec * exp | Afor of var_dec * exp * exp * block | Areturn of exp -and exp = Eval of pattern - | Ethis +and exp = Ethis | Efun of op_name * exp list | Emethod_call of exp * method_name * exp list | Enew of ty * exp list @@ -89,7 +88,10 @@ and exp = Eval of pattern | Sconstructor of constructor_name | Sstring of string | Snull - + | Efield of exp * field_name + | Eclass of class_name + | Evar of var_ident + | Earray_elem of exp * exp and pattern = Pfield of pattern * field_name | Pclass of class_name @@ -114,7 +116,7 @@ let java_pervasive_class c = Names.qualname_of_string ("jeptagon.Pervasives."^c) let the_java_pervasives = Names.qualname_of_string "jeptagon.Pervasives" -let mk_var x = Eval (Pvar x) +let mk_var x = Evar x let mk_var_dec x ty = { vd_type = ty; vd_ident = x } diff --git a/compiler/obc/java/java_main.ml b/compiler/obc/java/java_main.ml index d4f128e..7c836db 100644 --- a/compiler/obc/java/java_main.ml +++ b/compiler/obc/java/java_main.ml @@ -7,7 +7,7 @@ open Java_printer (** returns the vd and the pat of a fresh ident from [name] *) let mk_var ty name = let id = Idents.gen_var "java_main" name in - mk_var_dec id ty, Pvar id + mk_var_dec id ty, Pvar id, Evar id let program p = (*Scalarize*) @@ -29,8 +29,8 @@ let program p = mk_field ~static:true ~final:true ~value:(Some (Sint 30000)) Tint id, id in let main_methode = - let vd_step, pat_step = mk_var Tint "step" in - let vd_args, pat_args = + let vd_step, pat_step, exp_step = mk_var Tint "step" in + let vd_args, _, exp_args = mk_var (Tarray (Tclass (Names.pervasives_qn "String"), (Sint 0))) "args" in let body = let vd_main, e_main, q_main, ty_main = @@ -39,16 +39,16 @@ let program p = (Modules.find_value q_main).node_outputs |> types_of_arg_list |> Types.prod in let q_main = Obc2java.qualname_to_package_classe q_main in (*java qual*) let id = Idents.gen_var "java_main" "main" in - mk_var_dec id (Tclass q_main), Eval (Pvar id), q_main, ty_main + mk_var_dec id (Tclass q_main), Evar id, q_main, ty_main in let acts = - let integer = Eval(Pclass(Names.pervasives_qn "Integer")) in - let args1 = Eval(Parray_elem(pat_args, Sint 1)) in - let out = Eval(Pclass(Names.qualname_of_string "java.lang.System.out")) in - let jarrays = Eval(Pclass(Names.qualname_of_string "java.util.Arrays")) in - let jint = Eval(Pclass(Names.qualname_of_string "Integer")) in - let jfloat = Eval(Pclass(Names.qualname_of_string "Float")) in - let jbool = Eval(Pclass(Names.qualname_of_string "Boolean")) in + let integer = Eclass(Names.pervasives_qn "Integer") in + let args1 = Earray_elem(exp_args, Sint 1) in + let out = Eclass(Names.qualname_of_string "java.lang.System.out") in + let jarrays = Eclass(Names.qualname_of_string "java.util.Arrays") in + let jint = Eclass(Names.qualname_of_string "Integer") in + let jfloat = Eclass(Names.qualname_of_string "Float") in + let jbool = Eclass(Names.qualname_of_string "Boolean") in let ret = Emethod_call(e_main, "step", []) in let print_ret = match ty_main with | Types.Tarray (Types.Tarray _, _) -> Emethod_call(jarrays, "deepToString", [ret]) @@ -59,13 +59,13 @@ let program p = | _ -> Emethod_call(ret, "toString", []) in [ Anewvar(vd_main, Enew (Tclass q_main, [])); - Aifelse( Efun(Names.pervasives_qn ">", [Eval (Pfield (pat_args, "length")); Sint 1]) + Aifelse( Efun(Names.pervasives_qn ">", [Efield (exp_args, "length"); Sint 1]) , mk_block [Aassgn(pat_step, Emethod_call(integer, "parseInt", [args1]))] - , mk_block [Aassgn(pat_step, Eval (Pvar id_step_dnb))]); - Obc2java.fresh_for (Eval pat_step) + , mk_block [Aassgn(pat_step, Evar id_step_dnb)]); + Obc2java.fresh_for exp_step (fun i -> [Aexp (Emethod_call(out, "printf", - [Sstring "%d => %s\\n"; Eval (Pvar i); print_ret]))] + [Sstring "%d => %s\\n"; Evar i; print_ret]))] ) ] in diff --git a/compiler/obc/java/java_printer.ml b/compiler/obc/java/java_printer.ml index 0903a1f..ee4466d 100644 --- a/compiler/obc/java/java_printer.ml +++ b/compiler/obc/java/java_printer.ml @@ -72,7 +72,6 @@ and field ff f = and exp ff = function | Ethis -> fprintf ff "this" - | Eval p -> pattern ff p | Efun (f,e_l) -> op ff (f, e_l) | Emethod_call (o,m,e_l) -> fprintf ff "%a.%a%a" exp o method_name m args e_l | Enew (c,e_l) -> fprintf ff "new %a%a" new_ty c args e_l @@ -89,6 +88,10 @@ and exp ff = function | Sconstructor c -> constructor_name ff c | Sstring s -> fprintf ff "\"%s\"" s | Snull -> fprintf ff "null" + | Efield (p,f) -> fprintf ff "%a.%a" exp p field_name f + | Evar v -> var_ident ff v + | Eclass c -> class_name ff c + | Earray_elem (p,e) -> fprintf ff "%a[%a]" exp p exp e and op ff (f, e_l) = let javaop = function @@ -128,7 +131,7 @@ and op ff (f, e_l) = and args ff e_l = fprintf ff "@[(%a)@]" (print_list_r exp """,""") e_l and pattern ff = function - | Pfield (p,f) -> fprintf ff "%a.%a" pattern p field_name f + | Pfield (p, f) -> fprintf ff "%a.%a" pattern p field_name f | Pvar v -> var_ident ff v | Pclass c -> class_name ff c | Parray_elem (p,e) -> fprintf ff "%a[%a]" pattern p exp e diff --git a/compiler/obc/java/obc2java.ml b/compiler/obc/java/obc2java.ml index 7b97289..074b00c 100644 --- a/compiler/obc/java/obc2java.ml +++ b/compiler/obc/java/obc2java.ml @@ -27,6 +27,7 @@ open Obc open Obc_utils open Java +let this_field_ident id = Efield (Ethis, Idents.name id) (** Additional classes created during the translation *) let add_classe, get_classes = @@ -177,8 +178,7 @@ and var_dec param_env vd = { vd_type = ty param_env vd.v_type; vd_ident = vd.v_i and var_dec_list param_env vd_l = List.map (var_dec param_env) vd_l and exp param_env e = match e.e_desc with - | Obc.Epattern p -> Eval (pattern param_env p) - | Obc.Econst se -> static_exp param_env se + | Obc.Eextvalue p -> ext_value param_env p | Obc.Eop (op,e_l) -> Efun (op, exp_list param_env e_l) | Obc.Estruct _ -> eprintf "ojEstruct@."; assert false (* TODO java *) | Obc.Earray e_l -> Enew_array (ty param_env e.e_ty, exp_list param_env e_l) @@ -196,9 +196,25 @@ and pattern param_env p = match p.pat_desc with | Obc.Lfield (p,f) -> Pfield (pattern param_env p, translate_field_name f) | Obc.Larray (p,e) -> Parray_elem (pattern param_env p, exp param_env e) +and pattern_to_exp param_env p = match p.pat_desc with + | Obc.Lvar v -> Evar v + | Obc.Lmem v -> this_field_ident v + | Obc.Lfield (p,f) -> + Efield (pattern_to_exp param_env p, translate_field_name f) + | Obc.Larray (p,e) -> + Earray_elem (pattern_to_exp param_env p, exp param_env e) + +and ext_value param_env w = match w.w_desc with + | Obc.Wvar v -> Evar v + | Obc.Wconst c -> static_exp param_env c + | Obc.Wmem v -> this_field_ident v + | Obc.Wfield (p,f) -> Efield (ext_value param_env p, translate_field_name f) + | Obc.Warray (p,e) -> Earray_elem (ext_value param_env p, exp param_env e) + + let obj_ref param_env o = match o with - | Oobj id -> Eval (Pvar id) - | Oarray (id,p) -> Eval (Parray_elem (Pvar id, Eval (pattern param_env p))) + | Oobj id -> Evar id + | Oarray (id,p) -> Earray_elem (Evar id, pattern_to_exp param_env p) let rec act_list param_env act_l acts = let _act act acts = match act with @@ -226,7 +242,7 @@ let rec act_list param_env act_l acts = | _ -> Ecast(t, e) in let p = pattern param_env p in - Aassgn (p, cast t (Eval (Pfield (Pvar return_id, "c"^(string_of_int i))))) + Aassgn (p, cast t (Efield (Evar return_id, "c"^(string_of_int i)))) in let copies = Misc.mapi copy_return_to_var p_l in assgn::(copies@acts) @@ -288,7 +304,7 @@ let sig_args_to_vds param_env a_l = (** [copy_to_this vd_l] creates [this.x = x] for all [x] in [vd_l] *) let copy_to_this vd_l = - let _vd vd = Aassgn (Pthis vd.vd_ident, Eval (Pvar vd.vd_ident)) in + let _vd vd = Aassgn (Pthis vd.vd_ident, Evar vd.vd_ident) in List.map _vd vd_l @@ -385,8 +401,8 @@ let class_def_list classes cd_l = let return_act = Areturn (match vd_output with | [] -> Evoid - | [vd] -> Eval (Pvar vd.vd_ident) - | vd_l -> Enew (return_ty, List.map (fun vd -> Eval (Pvar vd.vd_ident)) vd_l)) + | [vd] -> Evar vd.vd_ident + | vd_l -> Enew (return_ty, List.map (fun vd -> Evar vd.vd_ident) vd_l)) in let body = block param_env ~locals:vd_output ~end_acts:[return_act] ostep.Obc.m_body in mk_methode ~args:(var_dec_list param_env ostep.Obc.m_inputs) ~returns:return_ty body "step" diff --git a/compiler/obc/obc.ml b/compiler/obc/obc.ml index d532dd0..2fcf665 100644 --- a/compiler/obc/obc.ml +++ b/compiler/obc/obc.ml @@ -48,11 +48,19 @@ and pat_desc = | Lfield of pattern * field_name | Larray of pattern * exp +and ext_value = { w_desc : ext_value_desc; w_ty : ty; w_loc : location; } + +and ext_value_desc = + | Wvar of var_ident + | Wconst of static_exp + | Wmem of var_ident + | Wfield of ext_value * field_name + | Warray of ext_value * exp + and exp = { e_desc : exp_desc; e_ty : ty; e_loc : location } and exp_desc = - | Epattern of pattern - | Econst of static_exp + | Eextvalue of ext_value | Eop of op_name * exp list | Estruct of type_name * (field_name * exp) list | Earray of exp list diff --git a/compiler/obc/obc_mapfold.ml b/compiler/obc/obc_mapfold.ml index ad340c4..b11eab1 100644 --- a/compiler/obc/obc_mapfold.ml +++ b/compiler/obc/obc_mapfold.ml @@ -17,6 +17,8 @@ type 'a obc_it_funs = { edesc: 'a obc_it_funs -> 'a -> Obc.exp_desc -> Obc.exp_desc * 'a; lhs: 'a obc_it_funs -> 'a -> Obc.pattern -> Obc.pattern * 'a; lhsdesc: 'a obc_it_funs -> 'a -> Obc.pat_desc -> Obc.pat_desc * 'a; + extvalue: 'a obc_it_funs -> 'a -> Obc.ext_value -> Obc.ext_value * 'a; + evdesc: 'a obc_it_funs -> 'a -> Obc.ext_value_desc -> Obc.ext_value_desc * 'a; act: 'a obc_it_funs -> 'a -> Obc.act -> Obc.act * 'a; block: 'a obc_it_funs -> 'a -> Obc.block -> Obc.block * 'a; var_dec: 'a obc_it_funs -> 'a -> Obc.var_dec -> Obc.var_dec * 'a; @@ -43,12 +45,9 @@ and edesc_it funs acc ed = try funs.edesc funs acc ed with Fallback -> edesc funs acc ed and edesc funs acc ed = match ed with - | Epattern l -> - let l, acc = lhs_it funs acc l in - Epattern l, acc - | Econst se -> - let se, acc = static_exp_it funs.global_funs acc se in - Econst se, acc + | Eextvalue w -> + let w, acc = extvalue_it funs acc w in + Eextvalue w, acc | Eop (op, args) -> let args, acc = mapfold (exp_it funs) acc args in Eop (op, args), acc @@ -83,6 +82,25 @@ and lhsdesc funs acc ld = match ld with let e, acc = exp_it funs acc e in Larray(lhs, e), acc +and extvalue_it funs acc w = funs.extvalue funs acc w +and extvalue funs acc w = + let wd, acc = evdesc_it funs acc w.w_desc in + { w with w_desc = wd; }, acc + +and evdesc_it funs acc wd = funs.evdesc funs acc wd +and evdesc funs acc wd = match wd with + | Wvar x -> Wvar x, acc + | Wconst c -> + let c, acc = static_exp_it funs.global_funs acc c in + Wconst c, acc + | Wmem x -> Wmem x, acc + | Wfield(w, f) -> + let w, acc = extvalue_it funs acc w in + Wfield(w, f), acc + | Warray(w, e) -> + let w, acc = extvalue_it funs acc w in + let e, acc = exp_it funs acc e in + Warray(w, e), acc and act_it funs acc a = try funs.act funs acc a @@ -119,7 +137,7 @@ and block_it funs acc b = funs.block funs acc b and block 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 + { 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 = @@ -203,6 +221,8 @@ and program_desc funs acc pd = match pd with let defaults = { lhs = lhs; lhsdesc = lhsdesc; + extvalue = extvalue; + evdesc = evdesc; exp = exp; edesc = edesc; act = act; diff --git a/compiler/obc/obc_printer.ml b/compiler/obc/obc_printer.ml index 33852f4..9f6c89a 100644 --- a/compiler/obc/obc_printer.ml +++ b/compiler/obc/obc_printer.ml @@ -33,12 +33,23 @@ let rec print_lhs ff e = print_exp ff idx; fprintf ff "]" +and print_ext_value ff w = match w.w_desc with + | Wvar x -> print_ident ff x + | Wconst c -> print_static_exp ff c + | Wmem x -> fprintf ff "mem("; print_ident ff x; fprintf ff ")" + | Wfield (l, f) -> print_ext_value ff l; fprintf ff ".%s" (shortname f) + | Warray(x, idx) -> + print_ext_value ff x; + fprintf ff "["; + print_exp ff idx; + fprintf ff "]" + + and print_exps ff e_list = print_list_r print_exp "" "," "" ff e_list and print_exp ff e = match e.e_desc with - | Epattern lhs -> print_lhs ff lhs - | Econst c -> print_static_exp ff c + | Eextvalue lhs -> print_ext_value ff lhs | Eop(op, e_list) -> print_op ff op e_list | Estruct(_,f_e_list) -> fprintf ff "@["; diff --git a/compiler/obc/obc_utils.ml b/compiler/obc/obc_utils.ml index 1914d19..eabafc9 100644 --- a/compiler/obc/obc_utils.ml +++ b/compiler/obc/obc_utils.ml @@ -19,17 +19,26 @@ open Global_mapfold let mk_var_dec ?(loc=no_location) ?(mut=false) ident ty = { v_ident = ident; v_type = ty; v_mutable = mut; v_loc = loc } +let mk_ext_value ?(loc=no_location) ty desc = + { w_desc = desc; w_ty = ty; w_loc = loc; } + +let mk_ext_value_int ?(loc=no_location) desc = + mk_ext_value ~loc:loc Initial.tint desc + +let mk_ext_value_bool ?(loc=no_location) desc = + mk_ext_value ~loc:loc Initial.tbool desc + let mk_exp ?(loc=no_location) ty desc = { e_desc = desc; e_ty = ty; e_loc = loc } let mk_exp_int ?(loc=no_location) desc = - { e_desc = desc; e_ty = Initial.tint; e_loc = loc } + mk_exp ~loc:loc Initial.tint desc let mk_exp_static_int ?(loc=no_location) se = - mk_exp_int ~loc:loc (Econst se) + mk_exp_int ~loc:loc (Eextvalue (mk_ext_value_int (Wconst se))) let mk_exp_const_int ?(loc=no_location) i = - mk_exp_int ~loc:loc (Econst (Initial.mk_static_int i)) + mk_exp_static_int ~loc:loc (Initial.mk_static_int i) let mk_exp_bool ?(loc=no_location) desc = { e_desc = desc; e_ty = Initial.tbool; e_loc = loc } @@ -40,15 +49,21 @@ let mk_pattern ?(loc=no_location) ty desc = let mk_pattern_int ?(loc=no_location) desc = { pat_desc = desc; pat_ty = Initial.tint; pat_loc = loc } -let mk_pattern_exp ty desc = - let pat = mk_pattern ty desc in - mk_exp ty (Epattern pat) +let mk_ext_value_exp ty desc = + let w = mk_ext_value ty desc in + mk_exp ty (Eextvalue w) + +let mk_ext_value_exp_int desc = mk_ext_value_exp Initial.tint desc + +let mk_ext_value_exp_bool desc = mk_ext_value_exp Initial.tbool desc + +let mk_ext_value_static ty sed = mk_ext_value_exp ty (Wconst sed) let mk_evar ty id = - mk_exp ty (Epattern (mk_pattern ty (Lvar id))) + mk_ext_value_exp ty (Wvar id) let mk_evar_int id = - mk_exp Initial.tint (Epattern (mk_pattern Initial.tint (Lvar id))) + mk_evar Initial.tint id let mk_block ?(locals=[]) eq_list = { b_locals = locals; @@ -86,8 +101,8 @@ let pattern_list_to_type p_l = match p_l with | [p] -> p.pat_ty | _ -> Tprod (List.map (fun p -> p.pat_ty) p_l) -let pattern_of_exp e = match e.e_desc with - | Epattern l -> l +let ext_value_of_exp e = match e.e_desc with + | Eextvalue w -> w | _ -> assert false let find_step_method cd = @@ -102,8 +117,8 @@ let obj_ref_name o = (** Input a block [b] and remove all calls to [Reset] method from it *) let remove_resets b = - let block funs _ b = - let b,_ = Obc_mapfold.block funs () b in + let block funs () b = + let b, () = Obc_mapfold.block funs () b in let is_not_reset a = match a with | Acall( _,_,Mreset,_) -> false | _ -> true @@ -209,3 +224,15 @@ let program_classes p = | _ -> acc in List.fold_right add_class p.p_desc [] + +let rec ext_value_of_pattern patt = + let desc = match patt.pat_desc with + | Lvar id -> Wvar id + | Lmem id -> Wmem id + | Lfield (p, fn) -> Wfield (ext_value_of_pattern p, fn) + | Larray (p, e) -> Warray (ext_value_of_pattern p, e) in + mk_ext_value ~loc:patt.pat_loc patt.pat_ty desc + +let rec exp_of_pattern patt = + let w = ext_value_of_pattern patt in + mk_exp w.w_ty (Eextvalue w) diff --git a/compiler/obc/transformations/scalarize.ml b/compiler/obc/transformations/scalarize.ml index 969bbc6..2f6ecd2 100644 --- a/compiler/obc/transformations/scalarize.ml +++ b/compiler/obc/transformations/scalarize.ml @@ -35,7 +35,7 @@ let act funs () a = match a with let pat_array_ref = mk_pattern ~loc:e.e_loc p.pat_ty (Lvar array_ref) in let init_array_ref = Aassgn (pat_array_ref, e) in (* the copy loop *) - let array_ref_i i = mk_pattern_exp t (Larray (pat_array_ref, i)) in + let array_ref_i i = mk_ext_value_exp t (Warray (ext_value_of_pattern pat_array_ref, i)) in let p_i i = mk_pattern t (Larray (p, i)) in let copy_i i = (* recursive call to deal with multidimensional arrays (go deeper) *) diff --git a/heptc b/heptc index f28b279..b5648c8 100755 --- a/heptc +++ b/heptc @@ -1,20 +1,19 @@ #!/bin/bash #Small wrapper to deal with compilation of the compiler and the stdlib. - -RUN_DIR=`pwd` +RUN_DIR="`pwd`" -SCRIPT_DIR=$RUN_DIR/`dirname $0` +SCRIPT_DIR="$RUN_DIR/`dirname $0`" -COMPILER_DIR=$SCRIPT_DIR/compiler +COMPILER_DIR="$SCRIPT_DIR/compiler" COMPILER=heptc.byte COMPILER_DEBUG=heptc.d.byte -LIB_DIR=$SCRIPT_DIR/lib +LIB_DIR="$SCRIPT_DIR/lib" #the symlink -HEPTC=$COMPILER_DIR/$COMPILER -HEPTC_DEBUG=$COMPILER_DIR/$COMPILER_DEBUG +HEPTC="$COMPILER_DIR/$COMPILER" +HEPTC_DEBUG="$COMPILER_DIR/$COMPILER_DEBUG" #compile the compiler if [ ! -x "$HEPTC" ]