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" ]