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