2010-07-01 14:44:08 +02:00
|
|
|
(**************************************************************************)
|
|
|
|
(* *)
|
|
|
|
(* Heptagon *)
|
|
|
|
(* *)
|
|
|
|
(* Author : Marc Pouzet *)
|
|
|
|
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
|
|
|
|
(* *)
|
|
|
|
(**************************************************************************)
|
|
|
|
|
|
|
|
open Format
|
|
|
|
open List
|
|
|
|
open Misc
|
|
|
|
open Names
|
2010-07-23 19:45:19 +02:00
|
|
|
open Idents
|
2010-07-01 14:44:08 +02:00
|
|
|
open Obc
|
2011-03-08 09:22:02 +01:00
|
|
|
open Obc_utils
|
2010-07-13 14:03:39 +02:00
|
|
|
open Types
|
2010-07-01 14:44:08 +02:00
|
|
|
open Modules
|
|
|
|
open Signature
|
|
|
|
open C
|
|
|
|
open Cgen
|
|
|
|
open Location
|
2010-08-24 17:23:50 +02:00
|
|
|
open Format
|
2010-07-13 14:03:39 +02:00
|
|
|
open Compiler_utils
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
(** {1 Main C function generation} *)
|
|
|
|
|
2010-12-14 18:29:55 +01:00
|
|
|
let _ = Idents.enter_node (Modules.fresh_value "cmain" "main")
|
|
|
|
|
|
|
|
let fresh n = Idents.name (Idents.gen_var "cmain" n)
|
|
|
|
|
2010-07-01 14:44:08 +02:00
|
|
|
(* Unique names for C variables handling step counts. *)
|
2010-12-14 18:29:55 +01:00
|
|
|
let step_counter = fresh "step_c"
|
|
|
|
and max_step = fresh"step_max"
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
let assert_node_res cd =
|
2010-07-13 14:03:39 +02:00
|
|
|
let stepm = find_step_method cd in
|
|
|
|
if List.length stepm.m_inputs > 0 then
|
2010-09-01 13:31:28 +02:00
|
|
|
(Format.eprintf "Cannot generate run-time check for node %s with inputs.@."
|
2010-09-13 09:03:15 +02:00
|
|
|
(cname_of_qn cd.cd_name);
|
2010-07-01 14:44:08 +02:00
|
|
|
exit 1);
|
2010-07-13 14:03:39 +02:00
|
|
|
if (match stepm.m_outputs with
|
|
|
|
| [{ v_type = Tid nbool; }] when nbool = Initial.pbool -> false
|
2010-07-01 14:44:08 +02:00
|
|
|
| _ -> true) then
|
2010-08-24 17:23:50 +02:00
|
|
|
(Format.eprintf
|
2010-09-01 13:31:28 +02:00
|
|
|
"Cannot generate run-time check for node %s with non-boolean output.@."
|
2010-09-13 09:03:15 +02:00
|
|
|
(cname_of_qn cd.cd_name);
|
2010-07-01 14:44:08 +02:00
|
|
|
exit 1);
|
2010-09-13 09:03:15 +02:00
|
|
|
let name = cname_of_qn cd.cd_name in
|
2011-04-27 15:29:33 +02:00
|
|
|
let out =
|
2010-12-14 18:29:55 +01:00
|
|
|
(fresh ("out_for_" ^ name),
|
2010-09-13 15:16:12 +02:00
|
|
|
Cty_id (qn_append cd.cd_name "_out")) in
|
2011-04-27 15:29:33 +02:00
|
|
|
let mem, reset_i =
|
|
|
|
if cd.cd_stateful
|
|
|
|
then ([], [])
|
|
|
|
else
|
|
|
|
let mem =
|
|
|
|
(fresh ("mem_for_" ^ name), Cty_id (qn_append cd.cd_name "_mem")) in
|
|
|
|
([mem],
|
|
|
|
[Csexpr (Cfun_call (name ^ "_reset", [Caddrof (Cvar (fst mem))]))]) in
|
2010-07-01 14:44:08 +02:00
|
|
|
let step_i =
|
|
|
|
(*
|
2010-07-01 15:21:11 +02:00
|
|
|
step(&out, &mem);
|
|
|
|
if (!out.proper_name) {
|
2010-07-01 14:44:08 +02:00
|
|
|
printf("Node $node failed at step %d.\n", step_count);
|
|
|
|
return 1;
|
|
|
|
}
|
|
|
|
*)
|
2010-07-23 19:45:19 +02:00
|
|
|
let outn = Idents.name ((List.hd stepm.m_outputs).v_ident) in
|
2010-07-01 15:21:11 +02:00
|
|
|
Csblock
|
|
|
|
{ var_decls = [];
|
|
|
|
block_body =
|
|
|
|
[
|
2010-09-13 09:03:15 +02:00
|
|
|
Csexpr (Cfun_call (name ^ "_step",
|
2011-04-27 15:29:33 +02:00
|
|
|
Caddrof (Cvar (fst out))
|
|
|
|
:: (if cd.cd_stateful
|
|
|
|
then [Caddrof (Cvar (fst (List.hd mem)))]
|
|
|
|
else [])));
|
2010-09-13 15:16:12 +02:00
|
|
|
Cif (Cuop ("!", Clhs (Cfield (Cvar (fst out), local_qn outn))),
|
2010-07-01 15:21:11 +02:00
|
|
|
[Csexpr (Cfun_call ("printf",
|
2010-09-13 09:03:15 +02:00
|
|
|
[Cconst (Cstrlit ("Node \\\"" ^ name
|
2010-07-01 15:21:11 +02:00
|
|
|
^ "\\\" failed at step" ^
|
|
|
|
" %d.\\n"));
|
2010-12-14 18:29:55 +01:00
|
|
|
Clhs (Cvar step_counter)]));
|
2010-07-01 15:21:11 +02:00
|
|
|
Creturn (Cconst (Ccint 1))],
|
|
|
|
[]);
|
|
|
|
];
|
|
|
|
} in
|
2011-04-27 15:29:33 +02:00
|
|
|
(out :: mem, reset_i, step_i);;
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
(** [main_def_of_class_def cd] returns a [(var_list, rst_i, step_i)] where
|
|
|
|
[var_list] (resp. [rst_i] and [step_i]) is a list of variables (resp. of
|
|
|
|
statements) needed for a main() function calling [cd]. *)
|
|
|
|
let main_def_of_class_def cd =
|
|
|
|
let format_for_type ty = match ty with
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tarray _ | Tprod _ | Tinvalid -> assert false
|
2010-07-13 14:03:39 +02:00
|
|
|
| Types.Tid id when id = Initial.pfloat -> "%f"
|
|
|
|
| Types.Tid id when id = Initial.pint -> "%d"
|
|
|
|
| Types.Tid id when id = Initial.pbool -> "%d"
|
2011-01-05 15:51:55 +01:00
|
|
|
| Tid _ -> "%s"
|
2011-03-09 00:02:30 +01:00
|
|
|
in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
(** Does reading type [ty] need a buffer? When it is the case,
|
|
|
|
[need_buf_for_ty] also returns the type's name. *)
|
|
|
|
let need_buf_for_ty ty = match ty with
|
2011-04-14 18:06:54 +02:00
|
|
|
| Tarray _ | Tprod _ | Tinvalid -> assert false
|
2010-07-13 14:03:39 +02:00
|
|
|
| Types.Tid id when id = Initial.pfloat -> None
|
|
|
|
| Types.Tid id when id = Initial.pint -> None
|
|
|
|
| Types.Tid id when id = Initial.pbool -> None
|
2011-01-05 15:51:55 +01:00
|
|
|
| Tid { name = n } -> Some n
|
2011-03-09 00:02:30 +01:00
|
|
|
in
|
2010-07-01 18:56:18 +02:00
|
|
|
let cprint_string s = Csexpr (Cfun_call ("printf", [Cconst (Cstrlit s)])) in
|
|
|
|
|
2010-07-01 14:44:08 +02:00
|
|
|
(** Generates scanf statements. *)
|
|
|
|
let rec read_lhs_of_ty lhs ty = match ty with
|
|
|
|
| Tarray (ty, n) ->
|
2010-12-14 18:29:55 +01:00
|
|
|
let iter_var = fresh "i" in
|
2010-07-01 14:44:08 +02:00
|
|
|
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
|
|
|
|
let (reads, bufs) = read_lhs_of_ty lhs ty in
|
2011-04-18 15:38:42 +02:00
|
|
|
([Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, reads)], bufs)
|
2010-07-01 14:44:08 +02:00
|
|
|
| _ ->
|
|
|
|
let rec mk_prompt lhs = match lhs with
|
|
|
|
| Cvar vn -> (vn, [])
|
|
|
|
| Carray (lhs, cvn) ->
|
|
|
|
let (vn, args) = mk_prompt lhs in
|
|
|
|
(vn ^ "[%d]", cvn :: args)
|
|
|
|
| _ -> assert false in
|
|
|
|
let (prompt, args_format_s) = mk_prompt lhs in
|
|
|
|
let scan_exp =
|
2010-08-24 17:23:50 +02:00
|
|
|
let printf_s = Format.sprintf "%s ? " prompt in
|
2010-07-01 14:44:08 +02:00
|
|
|
let format_s = format_for_type ty in
|
|
|
|
Csblock { var_decls = [];
|
|
|
|
block_body = [
|
|
|
|
Csexpr (Cfun_call ("printf",
|
|
|
|
Cconst (Cstrlit printf_s)
|
|
|
|
:: args_format_s));
|
|
|
|
Csexpr (Cfun_call ("scanf",
|
|
|
|
[Cconst (Cstrlit format_s);
|
|
|
|
Caddrof lhs])); ]; } in
|
|
|
|
match need_buf_for_ty ty with
|
|
|
|
| None -> ([scan_exp], [])
|
|
|
|
| Some tyn ->
|
2010-12-14 18:29:55 +01:00
|
|
|
let varn = fresh "buf" in
|
2010-07-01 14:44:08 +02:00
|
|
|
([scan_exp;
|
|
|
|
Csexpr (Cfun_call (tyn ^ "_of_string",
|
|
|
|
[Clhs (Cvar varn)]))],
|
|
|
|
[(varn, Cty_arr (20, Cty_char))]) in
|
|
|
|
|
|
|
|
(** Generates printf statements and buffer declarations needed for printing
|
|
|
|
resulting values of enum types. *)
|
|
|
|
let rec write_lhs_of_ty lhs ty = match ty with
|
|
|
|
| Tarray (ty, n) ->
|
2010-12-14 18:29:55 +01:00
|
|
|
let iter_var = fresh "i" in
|
2010-07-01 14:44:08 +02:00
|
|
|
let lhs = Carray (lhs, Clhs (Cvar iter_var)) in
|
|
|
|
let (reads, bufs) = write_lhs_of_ty lhs ty in
|
2010-07-13 14:03:39 +02:00
|
|
|
([cprint_string "[ ";
|
2011-04-18 15:38:42 +02:00
|
|
|
Cfor (iter_var, Cconst (Ccint 0), cexpr_of_static_exp n, reads);
|
2010-07-13 14:03:39 +02:00
|
|
|
cprint_string "]"], bufs)
|
2010-07-01 14:44:08 +02:00
|
|
|
| _ ->
|
2010-12-14 18:29:55 +01:00
|
|
|
let varn = fresh "buf" in
|
2010-07-01 14:44:08 +02:00
|
|
|
let format_s = format_for_type ty in
|
|
|
|
let nbuf_opt = need_buf_for_ty ty in
|
|
|
|
let ep = match nbuf_opt with
|
|
|
|
| None -> [Clhs lhs]
|
|
|
|
| Some sid -> [Cfun_call ("string_of_" ^ sid,
|
|
|
|
[Clhs lhs;
|
|
|
|
Clhs (Cvar varn)])] in
|
2010-07-01 18:56:18 +02:00
|
|
|
([Csexpr (Cfun_call ("printf",
|
|
|
|
Cconst (Cstrlit (format_s ^ " "))
|
|
|
|
:: ep))],
|
2010-07-01 14:44:08 +02:00
|
|
|
match nbuf_opt with
|
|
|
|
| None -> []
|
2010-09-14 09:39:02 +02:00
|
|
|
| Some _ -> [(varn, Cty_arr (20, Cty_char))]) in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
2010-07-13 14:03:39 +02:00
|
|
|
let stepm = find_step_method cd in
|
2010-07-01 14:44:08 +02:00
|
|
|
let (scanf_calls, scanf_decls) =
|
|
|
|
let read_lhs_of_ty_for_vd vd =
|
2010-07-23 19:45:19 +02:00
|
|
|
read_lhs_of_ty (Cvar (Idents.name vd.v_ident)) vd.v_type in
|
2010-07-13 14:03:39 +02:00
|
|
|
split (map read_lhs_of_ty_for_vd stepm.m_inputs) in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
let (printf_calls, printf_decls) =
|
2010-07-01 15:21:11 +02:00
|
|
|
let write_lhs_of_ty_for_vd vd =
|
2010-07-01 18:56:18 +02:00
|
|
|
let (stm, vars) =
|
2010-09-13 15:16:12 +02:00
|
|
|
write_lhs_of_ty (Cfield (Cvar "res",
|
|
|
|
local_qn (name vd.v_ident))) vd.v_type in
|
2010-07-01 18:56:18 +02:00
|
|
|
(cprint_string "=> " :: stm, vars) in
|
2010-07-13 14:03:39 +02:00
|
|
|
split (map write_lhs_of_ty_for_vd stepm.m_outputs) in
|
2010-07-01 18:56:18 +02:00
|
|
|
let printf_calls = List.concat printf_calls in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
2010-07-13 14:03:39 +02:00
|
|
|
let cinp = cvarlist_of_ovarlist stepm.m_inputs in
|
2010-09-13 15:16:12 +02:00
|
|
|
let cout = ["res", (Cty_id (qn_append cd.cd_name "_out"))] in
|
2010-07-01 15:21:11 +02:00
|
|
|
|
2010-07-01 14:44:08 +02:00
|
|
|
let varlist =
|
2011-04-27 15:29:33 +02:00
|
|
|
(if cd.cd_stateful
|
|
|
|
then [("mem", Cty_id (qn_append cd.cd_name "_mem"))]
|
|
|
|
else [])
|
|
|
|
@ cinp
|
2010-07-01 14:44:08 +02:00
|
|
|
@ cout
|
|
|
|
@ concat scanf_decls
|
|
|
|
@ concat printf_decls in
|
|
|
|
|
|
|
|
(** The main function loops (while (1) { ... }) reading arguments for our node
|
|
|
|
and prints the results. *)
|
|
|
|
let step_l =
|
|
|
|
let funcall =
|
|
|
|
let args =
|
2010-07-13 14:03:39 +02:00
|
|
|
map (fun vd -> Clhs (Cvar (name vd.v_ident))) stepm.m_inputs
|
2011-04-27 15:29:33 +02:00
|
|
|
@ (Caddrof (Cvar "res")
|
|
|
|
:: if cd.cd_stateful then [Caddrof (Cvar "mem")] else []) in
|
2010-09-13 09:03:15 +02:00
|
|
|
Cfun_call ((cname_of_qn cd.cd_name) ^ "_step", args) in
|
2010-07-01 14:44:08 +02:00
|
|
|
concat scanf_calls
|
2010-07-01 15:21:11 +02:00
|
|
|
@ [Csexpr funcall]
|
2010-07-01 14:44:08 +02:00
|
|
|
@ printf_calls
|
|
|
|
@ [Csexpr (Cfun_call ("puts", [Cconst (Cstrlit "")]));
|
|
|
|
Csexpr (Cfun_call ("fflush", [Clhs (Cvar "stdout")]))] in
|
|
|
|
|
2011-04-27 15:29:33 +02:00
|
|
|
(** Do not forget to initialize memory via reset if needed. *)
|
2010-07-01 14:44:08 +02:00
|
|
|
let rst_i =
|
2011-04-27 15:29:33 +02:00
|
|
|
if cd.cd_stateful
|
|
|
|
then [Csexpr (Cfun_call ((cname_of_qn cd.cd_name) ^ "_reset",
|
|
|
|
[Caddrof (Cvar "mem")]))]
|
|
|
|
else [] in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
(varlist, rst_i, step_l)
|
|
|
|
|
|
|
|
(** [main_skel var_list prologue body] generates a C main() function using the
|
|
|
|
variable list [var_list], prologue [prologue] and loop body [body]. *)
|
|
|
|
let main_skel var_list prologue body =
|
|
|
|
Cfundef {
|
|
|
|
f_name = "main";
|
|
|
|
f_retty = Cty_int;
|
|
|
|
f_args = [("argc", Cty_int); ("argv", Cty_ptr (Cty_ptr Cty_char))];
|
|
|
|
f_body = {
|
|
|
|
var_decls =
|
2010-12-14 18:29:55 +01:00
|
|
|
(step_counter, Cty_int) :: (max_step, Cty_int) :: var_list;
|
2010-07-01 14:44:08 +02:00
|
|
|
block_body =
|
|
|
|
[
|
|
|
|
(*
|
|
|
|
step_count = 0;
|
|
|
|
max_step = 0;
|
|
|
|
if (argc == 2)
|
|
|
|
max_step = atoi(argv[1]);
|
|
|
|
*)
|
2010-12-14 18:29:55 +01:00
|
|
|
Caffect (Cvar step_counter, Cconst (Ccint 0));
|
|
|
|
Caffect (Cvar max_step, Cconst (Ccint 0));
|
2010-07-01 14:44:08 +02:00
|
|
|
Cif (Cbop ("==", Clhs (Cvar "argc"), Cconst (Ccint 2)),
|
2010-12-14 18:29:55 +01:00
|
|
|
[Caffect (Cvar max_step,
|
2010-07-01 14:44:08 +02:00
|
|
|
Cfun_call ("atoi",
|
|
|
|
[Clhs (Carray (Cvar "argv",
|
|
|
|
Cconst (Ccint 1)))]))], []);
|
|
|
|
]
|
|
|
|
@ prologue
|
|
|
|
(* while (!max_step || step_c < max_step) *)
|
|
|
|
@ [
|
|
|
|
Cwhile (Cbop ("||",
|
2010-12-14 18:29:55 +01:00
|
|
|
Cuop ("!", Clhs (Cvar max_step)),
|
2010-07-01 14:44:08 +02:00
|
|
|
Cbop ("<",
|
2010-12-14 18:29:55 +01:00
|
|
|
Clhs (Cvar step_counter),
|
|
|
|
Clhs (Cvar max_step))),
|
2010-07-01 14:44:08 +02:00
|
|
|
(* step_counter = step_counter + 1; *)
|
2010-12-14 18:29:55 +01:00
|
|
|
Caffect (Cvar step_counter,
|
2010-07-01 14:44:08 +02:00
|
|
|
Cbop ("+",
|
2010-12-14 18:29:55 +01:00
|
|
|
Clhs (Cvar step_counter),
|
2010-07-01 14:44:08 +02:00
|
|
|
Cconst (Ccint 1)))
|
2010-07-02 15:38:11 +02:00
|
|
|
:: body);
|
2010-07-02 15:45:50 +02:00
|
|
|
Creturn (Cconst (Ccint 0));
|
2010-07-01 14:44:08 +02:00
|
|
|
];
|
|
|
|
}
|
|
|
|
}
|
|
|
|
|
2010-09-15 09:38:52 +02:00
|
|
|
let mk_main name p =
|
2011-03-08 09:22:02 +01:00
|
|
|
if !Compiler_options.simulation then (
|
2011-04-19 09:49:00 +02:00
|
|
|
let classes = program_classes p in
|
2011-03-08 09:22:02 +01:00
|
|
|
let n_names = !Compiler_options.assert_nodes in
|
2010-10-04 00:33:05 +02:00
|
|
|
let find_class n =
|
2011-04-19 09:49:00 +02:00
|
|
|
try List.find (fun cd -> cd.cd_name.name = n) classes
|
2010-07-01 14:44:08 +02:00
|
|
|
with Not_found ->
|
2010-10-04 00:33:05 +02:00
|
|
|
Format.eprintf "Unknown node %s.@." n;
|
2010-07-01 14:44:08 +02:00
|
|
|
exit 1 in
|
|
|
|
|
|
|
|
let a_classes = List.map find_class n_names in
|
|
|
|
|
|
|
|
let (var_l, res_l, step_l) =
|
|
|
|
let add cd (var_l, res_l, step_l) =
|
|
|
|
let (var, res, step) = assert_node_res cd in
|
2011-04-27 15:29:33 +02:00
|
|
|
(var @ var_l, res @ res_l, step :: step_l) in
|
2010-07-01 14:44:08 +02:00
|
|
|
List.fold_right add a_classes ([], [], []) in
|
|
|
|
|
2011-03-08 09:22:02 +01:00
|
|
|
let n = !Compiler_options.simulation_node in
|
|
|
|
let (nvar_l, res, nstep_l) = main_def_of_class_def (find_class n) in
|
|
|
|
let (var_l, res_l, step_l) =
|
2011-04-27 15:29:33 +02:00
|
|
|
(nvar_l @ var_l, res @ res_l, nstep_l @ step_l) in
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
[("_main.c", Csource [main_skel var_l res_l step_l]);
|
2010-07-27 16:27:07 +02:00
|
|
|
("_main.h", Cheader ([name], []))];
|
2011-03-08 09:22:02 +01:00
|
|
|
) else
|
|
|
|
[]
|
|
|
|
|
2010-07-01 14:44:08 +02:00
|
|
|
|
|
|
|
|
|
|
|
(******************************)
|
|
|
|
|
|
|
|
let translate name prog =
|
|
|
|
let modname = (Filename.basename name) in
|
|
|
|
global_name := String.capitalize modname;
|
2010-07-27 16:27:07 +02:00
|
|
|
(global_file_header modname prog) @ (mk_main name prog)
|
2010-07-13 14:03:39 +02:00
|
|
|
|
|
|
|
let program p =
|
2011-03-08 09:22:02 +01:00
|
|
|
let filename =
|
|
|
|
filename_of_name (cname_of_name (modul_to_string p.p_modname)) in
|
2010-07-13 14:03:39 +02:00
|
|
|
let dirname = build_path (filename ^ "_c") in
|
|
|
|
let dir = clean_dir dirname in
|
|
|
|
let c_ast = translate filename p in
|
|
|
|
C.output dir c_ast
|