lustrec / src / backends / Java / java_backend.ml @ b38ffff3
History | View | Annotate | Download (14.2 KB)
1 |
(********************************************************************) |
---|---|
2 |
(* *) |
3 |
(* The LustreC compiler toolset / The LustreC Development Team *) |
4 |
(* Copyright 2012 - -- ONERA - CNRS - INPT *) |
5 |
(* *) |
6 |
(* LustreC is free software, distributed WITHOUT ANY WARRANTY *) |
7 |
(* under the terms of the GNU Lesser General Public License *) |
8 |
(* version 2.1. *) |
9 |
(* *) |
10 |
(********************************************************************) |
11 |
|
12 |
open Format |
13 |
open Utils |
14 |
open LustreSpec |
15 |
open Corelang |
16 |
open Machine_code |
17 |
|
18 |
|
19 |
(********************************************************************************************) |
20 |
(* Basic Printing functions *) |
21 |
(********************************************************************************************) |
22 |
|
23 |
let pp_final_char_if_non_empty c l = |
24 |
(fun fmt -> match l with [] -> () | _ -> fprintf fmt "%s" c) |
25 |
|
26 |
let pp_newline_if_non_empty l = |
27 |
(fun fmt -> match l with [] -> () | _ -> fprintf fmt "@,") |
28 |
|
29 |
let pp_dimension fmt d = |
30 |
Printers.pp_expr fmt (expr_of_dimension d) |
31 |
|
32 |
let pp_type fmt t = |
33 |
match (Types.repr t).Types.tdesc with |
34 |
| Types.Tbool -> pp_print_string fmt "boolean" |
35 |
| Types.Treal -> pp_print_string fmt "double" |
36 |
| _ -> Types.print_ty fmt t |
37 |
|
38 |
let pp_var fmt id = fprintf fmt "%a %s" pp_type id.var_type id.var_id |
39 |
|
40 |
let pp_tag fmt t = |
41 |
pp_print_string fmt t |
42 |
|
43 |
let rec pp_const fmt c = |
44 |
match c with |
45 |
| Const_int i -> pp_print_int fmt i |
46 |
| Const_real r -> pp_print_string fmt r |
47 |
| Const_float r -> pp_print_float fmt r |
48 |
| Const_tag t -> pp_tag fmt t |
49 |
| Const_array ca -> Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca |
50 |
|
51 |
let rec pp_val m fmt v = |
52 |
match v with |
53 |
| Cst c -> pp_const fmt c |
54 |
| LocalVar v -> |
55 |
if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then |
56 |
fprintf fmt "*%s" v |
57 |
else |
58 |
pp_print_string fmt v |
59 |
| StateVar v -> fprintf fmt "%s" v |
60 |
| Fun (n, vl) -> if Basic_library.is_internal_fun n then |
61 |
Basic_library.pp_java n (pp_val m) fmt vl |
62 |
else |
63 |
fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl |
64 |
|
65 |
let pp_add_val m fmt i = |
66 |
if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs |
67 |
then |
68 |
fprintf fmt "%s" i |
69 |
else |
70 |
fprintf fmt "&%s" i |
71 |
|
72 |
(********************************************************************************************) |
73 |
(* Instruction Printing functions *) |
74 |
(********************************************************************************************) |
75 |
let get_output_of_machine machines i = |
76 |
try |
77 |
let m = List.find (fun m -> m.mname.node_id = i) machines in |
78 |
m.mstep.step_outputs |
79 |
with Not_found -> assert false |
80 |
|
81 |
let rec pp_machine_instr m machines instance_out_list fmt instr = |
82 |
match instr with |
83 |
| MReset i -> ( |
84 |
match List.assoc i m.minstances with |
85 |
| "_arrow" -> fprintf fmt "%s = true;" i |
86 |
| _ -> fprintf fmt "%s.reset();" i |
87 |
) |
88 |
| MLocalAssign (i,v) -> ( |
89 |
fprintf fmt "%s = %a;" |
90 |
i (pp_val m) v |
91 |
) |
92 |
| MStateAssign (i,v) -> |
93 |
fprintf fmt "%s = %a;" i (pp_val m) v |
94 |
| MStep ([i0], i, vl) when Basic_library.is_internal_fun i -> |
95 |
fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl |
96 |
| MStep ([i0], i, [init; step]) when ((List.assoc i m.minstances) = "_arrow") -> ( |
97 |
fprintf fmt "@[<v 2>if (%s) {@,%s = false;@,%s = %a;@]@,@[<v 2>} else {@,%s = %a;@]@,};@," |
98 |
i i i0 (pp_val m) init i0 (pp_val m) step |
99 |
) |
100 |
| MStep (il, i, vl) -> ( |
101 |
let out = |
102 |
try |
103 |
List.assoc i instance_out_list |
104 |
with Not_found -> (eprintf "impossible to find instance %s in the list@.@?" i; |
105 |
assert false) |
106 |
in |
107 |
fprintf fmt "%s = %s.step (%a);@," |
108 |
out i |
109 |
(Utils.fprintf_list ~sep:", " (pp_val m)) vl; |
110 |
Utils.fprintf_list ~sep:"@," |
111 |
(fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname) fmt |
112 |
(List.map2 |
113 |
(fun x y -> x, y.var_id) |
114 |
il |
115 |
(get_output_of_machine machines (List.assoc i m.minstances)) |
116 |
) |
117 |
) |
118 |
|
119 |
| MBranch (g,hl) -> |
120 |
Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]" |
121 |
(pp_val m) g |
122 |
(Utils.fprintf_list ~sep:"@," (pp_machine_branch m machines instance_out_list)) hl |
123 |
|
124 |
and pp_machine_branch m machines instance_out_list fmt (t, h) = |
125 |
Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr m machines instance_out_list)) h |
126 |
|
127 |
(********************************************************************************************) |
128 |
(* Java file Printing functions *) |
129 |
(********************************************************************************************) |
130 |
|
131 |
let get_class_name n = match n with "_arrow" -> "boolean" | _ -> String.capitalize n |
132 |
|
133 |
let pp_local_fields visibility = |
134 |
fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v) |
135 |
|
136 |
let pp_local_field_instances = |
137 |
fprintf_list ~sep:"@," |
138 |
(fun fmt (node_inst, node_type) -> fprintf fmt "protected %s %s;" |
139 |
(get_class_name node_type) |
140 |
node_inst |
141 |
) |
142 |
|
143 |
let pp_output_constructor fmt outputs = |
144 |
fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}" |
145 |
(fprintf_list ~sep:"; " pp_var) outputs |
146 |
(fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "this.%s = %s;" v.var_id v.var_id)) outputs |
147 |
|
148 |
let pp_output_class fmt step = |
149 |
fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@," |
150 |
(pp_local_fields "public") step.step_outputs |
151 |
pp_output_constructor step.step_outputs |
152 |
|
153 |
let pp_constructor fmt (name, instances) = |
154 |
fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@," |
155 |
(String.capitalize name) |
156 |
( |
157 |
fprintf_list ~sep:"@," |
158 |
(fun fmt (node_inst, node_type) -> |
159 |
match node_type with |
160 |
"_arrow" -> fprintf fmt "%s = true;" node_inst |
161 |
| _ -> fprintf fmt "%s = new %s();" node_inst (get_class_name node_type) |
162 |
) |
163 |
) |
164 |
instances |
165 |
|
166 |
let pp_reset machines fmt m = |
167 |
fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@," |
168 |
(fprintf_list ~sep:"@," (pp_machine_instr m machines [])) m.minit |
169 |
|
170 |
let pp_step machines fmt m : unit = |
171 |
let out_assoc_list = |
172 |
List.map (fun (node_inst, _) -> node_inst, "out_" ^ node_inst) m.minstances |
173 |
in |
174 |
fprintf fmt |
175 |
"@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@," |
176 |
(Utils.fprintf_list ~sep:",@ " pp_var) m.mstep.step_inputs |
177 |
(* locals *) |
178 |
(Utils.fprintf_list ~sep:";@," pp_var) m.mstep.step_locals |
179 |
(pp_final_char_if_non_empty ";" m.mstep.step_locals) |
180 |
(* declare out variables of subnode instances + out of this node *) |
181 |
(fprintf_list ~sep:"" |
182 |
(fun fmt (ninst, ntype) -> fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst )) |
183 |
(List.filter (fun (_,ntyp) -> not (ntyp = "_arrow")) m.minstances) |
184 |
(fprintf_list ~sep:";@," pp_var) m.mstep.step_outputs |
185 |
(pp_final_char_if_non_empty ";" m.mstep.step_outputs) |
186 |
(* instructions *) |
187 |
(fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list)) m.mstep.step_instrs |
188 |
(* create out object and return it *) |
189 |
(fun fmt -> fprintf fmt "return new Output(%a);" |
190 |
(fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_outputs |
191 |
) |
192 |
|
193 |
|
194 |
|
195 |
let print_machine machines fmt m = |
196 |
if m.mname.node_id = "_arrow" then () else ( (* We don't print arrow function *) |
197 |
fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@." |
198 |
(String.capitalize m.mname.node_id) (* class name *) |
199 |
(pp_local_fields "protected") m.mmemory (* fields *) |
200 |
(pp_newline_if_non_empty m.mmemory) |
201 |
pp_local_field_instances m.minstances (* object fields *) |
202 |
(pp_newline_if_non_empty m.minstances) |
203 |
(pp_newline_if_non_empty m.minstances) |
204 |
pp_output_class m.mstep (* class for output of step method *) |
205 |
pp_constructor (m.mname.node_id, m.minstances) (* constructor to instanciate object fields *) |
206 |
(pp_reset machines) m (* reset method *) |
207 |
(pp_step machines) m (* step method *) |
208 |
|
209 |
) |
210 |
|
211 |
(********************************************************************************************) |
212 |
(* Main related functions *) |
213 |
(********************************************************************************************) |
214 |
|
215 |
(* let print_get_input fmt v = *) |
216 |
(* match v.var_type.Types.tdesc with *) |
217 |
(* | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id *) |
218 |
(* | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id *) |
219 |
(* | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id *) |
220 |
(* | _ -> assert false *) |
221 |
|
222 |
(* let print_put_outputs fmt ol = *) |
223 |
(* let po fmt o = *) |
224 |
(* match o.var_type.Types.tdesc with *) |
225 |
(* | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id *) |
226 |
(* | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id *) |
227 |
(* | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *) |
228 |
(* | _ -> assert false *) |
229 |
(* in *) |
230 |
(* List.iter (fprintf fmt "@ %a;" po) ol *) |
231 |
|
232 |
let read_input fmt typ = match typ.Types.tdesc with |
233 |
| Types.Treal -> fprintf fmt "StdIn.readDouble()" |
234 |
| Types.Tint -> fprintf fmt "StdIn.readInt()" |
235 |
| Types.Tbool -> fprintf fmt "StdIn.readBoolean()" |
236 |
| _ -> assert false |
237 |
|
238 |
let print_main_fun basename machines m fmt = |
239 |
let m_class = String.capitalize m.mname.node_id in |
240 |
fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@." |
241 |
(String.capitalize basename) |
242 |
"public static void main (String[] args)" |
243 |
(fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class) |
244 |
(fun fmt -> fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@," |
245 |
(fprintf_list ~sep:"@," |
246 |
(fun fmt v -> fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" |
247 |
v.var_id pp_var v read_input v.var_type)) |
248 |
m.mstep.step_inputs |
249 |
(fun fmt -> fprintf fmt "%s.Output out = main_node.step(%a);" |
250 |
m_class |
251 |
(fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs |
252 |
) |
253 |
(fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id v.var_id)) |
254 |
m.mstep.step_outputs |
255 |
) |
256 |
|
257 |
|
258 |
(* let print_main_fun machines m fmt = *) |
259 |
(* let mname = m.mname.node_id in *) |
260 |
(* let main_mem = *) |
261 |
(* if (!Options.static_mem && !Options.main_node <> "") *) |
262 |
(* then "&main_mem" *) |
263 |
(* else "main_mem" in *) |
264 |
(* fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ "; *) |
265 |
(* fprintf fmt "/* Declaration of inputs/outputs variables */@ "; *) |
266 |
(* List.iter *) |
267 |
(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *) |
268 |
(* ) m.mstep.step_inputs; *) |
269 |
(* List.iter *) |
270 |
(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *) |
271 |
(* ) m.mstep.step_outputs; *) |
272 |
(* fprintf fmt "@ /* Main memory allocation */@ "; *) |
273 |
(* if (!Options.static_mem && !Options.main_node <> "") *) |
274 |
(* then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname) *) |
275 |
(* else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname); *) |
276 |
(* fprintf fmt "@ /* Initialize the main memory */@ "; *) |
277 |
(* fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem; *) |
278 |
(* fprintf fmt "@ ISATTY = isatty(0);@ "; *) |
279 |
(* fprintf fmt "@ /* Infinite loop */@ "; *) |
280 |
(* fprintf fmt "@[<v 2>while(1){@ "; *) |
281 |
(* fprintf fmt "fflush(stdout);@ "; *) |
282 |
(* List.iter *) |
283 |
(* (fun v -> fprintf fmt "%s = %a;@ " *) |
284 |
(* v.var_id *) |
285 |
(* print_get_input v *) |
286 |
(* ) m.mstep.step_inputs; *) |
287 |
(* (match m.mstep.step_outputs with *) |
288 |
(* | [] -> ( *) |
289 |
(* fprintf fmt "%a(%a%t%s);@ " *) |
290 |
(* pp_machine_step_name mname *) |
291 |
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *) |
292 |
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *) |
293 |
(* main_mem *) |
294 |
(* ) *) |
295 |
(* | [o] -> ( *) |
296 |
(* fprintf fmt "%s = %a(%a%t%a, %s);%a" *) |
297 |
(* o.var_id *) |
298 |
(* pp_machine_step_name mname *) |
299 |
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *) |
300 |
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *) |
301 |
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *) |
302 |
(* main_mem *) |
303 |
(* print_put_outputs [o]) *) |
304 |
(* | _ -> ( *) |
305 |
(* fprintf fmt "%a(%a%t%a, %s);%a" *) |
306 |
(* pp_machine_step_name mname *) |
307 |
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *) |
308 |
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *) |
309 |
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *) |
310 |
(* main_mem *) |
311 |
(* print_put_outputs m.mstep.step_outputs) *) |
312 |
(* ); *) |
313 |
(* fprintf fmt "@]@ }@ "; *) |
314 |
(* fprintf fmt "return 1;"; *) |
315 |
(* fprintf fmt "@]@ }@." *) |
316 |
|
317 |
(* let print_main_header fmt = *) |
318 |
(* fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@." *) |
319 |
|
320 |
|
321 |
(********************************************************************************************) |
322 |
(* Translation function *) |
323 |
(********************************************************************************************) |
324 |
|
325 |
let translate_to_java source_fmt basename prog machines = |
326 |
|
327 |
|
328 |
(* If a main node is identified, generate a main function for it *) |
329 |
let main_print = |
330 |
match !Options.main_node with |
331 |
| "" -> (fun _ -> ()) |
332 |
| main_node -> ( |
333 |
let main_node_opt = |
334 |
List.fold_left |
335 |
(fun res m -> |
336 |
match res with |
337 |
| Some _ -> res |
338 |
| None -> if m.mname.node_id = main_node then Some m else None) |
339 |
None machines |
340 |
in |
341 |
match main_node_opt with |
342 |
| None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ()) |
343 |
| Some m -> print_main_fun basename machines m |
344 |
) |
345 |
in |
346 |
|
347 |
(* Print nodes one by one (in the previous order) *) |
348 |
List.iter ((print_machine machines) source_fmt) machines; |
349 |
main_print source_fmt |
350 |
|
351 |
|
352 |
|
353 |
|
354 |
(* Local Variables: *) |
355 |
(* compile-command:"make -C .." *) |
356 |
(* End: *) |