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

Reworked Obc AST: from right patterns to extvalues.

Browse source 
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.
This commit is contained in:
Adrien Guatto 2011-05-30 10:06:16 +02:00
parent fd0b3efd2c
commit 4794045208
17 changed files with 487 additions and 537 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

190
compiler/main/mls2obc.ml
View file

@ -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

59
compiler/obc/c/c.ml
View file

@ -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 "@[<v>@[<v 2>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

135
compiler/obc/c/c.mli
View file

@ -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

301
compiler/obc/c/cgen.ml
View file

@ -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);

69
compiler/obc/c/cmain.ml
View file

@ -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);
];
}
}

60
compiler/obc/c/csubst.ml
View file

@ -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

4
compiler/obc/control.ml
View file

@ -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

10
compiler/obc/java/java.ml
View file

@ -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 }

30
compiler/obc/java/java_main.ml
View file

@ -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

7
compiler/obc/java/java_printer.ml
View file

@ -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

32
compiler/obc/java/obc2java.ml
View file

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

12
compiler/obc/obc.ml
View file

@ -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

34
compiler/obc/obc_mapfold.ml
View file

@ -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;

15
compiler/obc/obc_printer.ml
View file

@ -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 "@[<v 1>";

51
compiler/obc/obc_utils.ml
View file

@ -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)

2
compiler/obc/transformations/scalarize.ml
View file

@ -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) *)

13
heptc
View file

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