Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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