Project

General

Profile

Download (14.6 KB) Statistics
| Branch: | Tag: | Revision:
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
open Lustrec
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
  Lustrec.Printers.pp_expr fmt (expr_of_dimension d)
31

    
32
let pp_type fmt t = 
33
  match (Lustrec.Types.repr t).Lustrec.Types.tdesc with
34
    | Lustrec.Types.Tbool -> pp_print_string fmt "boolean" 
35
    | Lustrec.Types.Treal -> pp_print_string fmt "double" 
36
    | _ -> Lustrec.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}" (Lustrec.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
    | Var v ->
55
       if is_state_vars m.memories v then
56
         fprintf fmt "%s" v
57
       else
58
         if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then
59
	   fprintf fmt "*%s" v
60
         else
61
	   pp_print_string fmt v
62
    | Fun (n, vl) -> if Lustrec.Basic_library.is_internal_fun n then
63
	Basic_library.pp_java n (pp_val m) fmt vl
64
      else
65
	fprintf fmt "%s (%a)" n (Lustrec.Utils.fprintf_list ~sep:", " (pp_val m)) vl
66

    
67
let pp_add_val m fmt i =
68
  if List.exists (fun o -> o.var_id = i) m.mstep.step_outputs
69
  then
70
    fprintf fmt "%s" i
71
  else
72
    fprintf fmt "&%s" i
73

    
74
(********************************************************************************************)
75
(*                    Instruction Printing functions                                        *)
76
(********************************************************************************************)
77
let get_output_of_machine machines i =
78
  try 
79
    let m = List.find (fun m -> m.mname.node_id = i) machines in
80
    m.mstep.step_outputs
81
  with Not_found -> assert false
82

    
83
let rec pp_machine_instr m machines instance_out_list fmt instr =
84
  match instr with
85
    | MReset i -> (
86
      match List.assoc i m.minstances with
87
	| "_arrow" -> fprintf fmt "%s = true;" i
88
	| _ -> fprintf fmt "%s.reset();" i
89
    )
90
    | MLocalAssign (i,v) -> (
91
      fprintf fmt "%s = %a;" 
92
	i (pp_val m) v
93
    )
94
    | MStateAssign (i,v) ->
95
      fprintf fmt "%s = %a;" i (pp_val m) v
96
    | MStep ([i0], i, vl) when Lustrec.Basic_library.is_internal_fun i ->
97
      fprintf fmt "%s = %a;" i0 (Basic_library.pp_java i (pp_val m)) vl    
98
    | MStep ([i0], i, [init; step]) when ((List.assoc i m.minstances) = "_arrow") -> (
99
      fprintf fmt "@[<v 2>if (%s) {@,%s = false;@,%s = %a;@]@,@[<v 2>} else {@,%s = %a;@]@,};@,"
100
	    i i i0 (pp_val m) init i0 (pp_val m) step
101
    )
102
    | MStep (il, i, vl) -> (
103
      let out = 
104
	try
105
	  List.assoc i instance_out_list 
106
	with Not_found -> (eprintf "impossible to find instance %s in the list@.@?" i; 
107
			   assert false) 
108
      in 
109
	  fprintf fmt "%s = %s.step (%a);@,"
110
    	    out i
111
     	    (Lustrec.Utils.fprintf_list ~sep:", " (pp_val m)) vl;
112
	  Lustrec.Utils.fprintf_list ~sep:"@," 
113
	    (fun fmt (o, oname) -> fprintf fmt "%s = %s.%s;" o out oname) fmt 
114
	    (List.map2 
115
	       (fun x y -> x, y.var_id) 
116
	       il 
117
	       (get_output_of_machine machines (List.assoc i m.minstances))
118
	    ) 
119
    ) 
120
      	
121
    | MBranch (g,hl) ->
122
      Format.fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
123
	(pp_val m) g
124
	(Lustrec.Utils.fprintf_list ~sep:"@," (pp_machine_branch m machines instance_out_list)) hl
125

    
126
and pp_machine_branch m machines instance_out_list fmt (t, h) =
127
  Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t (Lustrec.Utils.fprintf_list ~sep:"@," (pp_machine_instr m machines instance_out_list)) h
128

    
129
(********************************************************************************************)
130
(*                         Java file Printing functions                                        *)
131
(********************************************************************************************)
132

    
133
let get_class_name n = match n with "_arrow" -> "boolean" | _ -> String.capitalize n
134

    
135
let pp_local_fields visibility = 
136
  fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "%s %a;" visibility pp_var v) 
137

    
138
let pp_local_field_instances = 
139
  fprintf_list ~sep:"@," 
140
    (fun fmt (node_inst, node_type) -> fprintf fmt "protected %s %s;" 
141
      (get_class_name node_type) 
142
      node_inst
143
    ) 
144

    
145
let pp_output_constructor fmt outputs =
146
  fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}"
147
    (fprintf_list ~sep:"; " pp_var) outputs
148
    (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "this.%s = %s;" v.var_id v.var_id)) outputs
149

    
150
let pp_output_class fmt step = 
151
  fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"
152
    (pp_local_fields "public") step.step_outputs
153
    pp_output_constructor step.step_outputs
154

    
155
let pp_constructor fmt (name, instances) = 
156
  fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@,"
157
    (String.capitalize name)
158
    (
159
      fprintf_list ~sep:"@," 
160
	(fun fmt (node_inst, node_type) -> 
161
	  match node_type with
162
	      "_arrow" -> fprintf fmt "%s = true;" node_inst
163
	    | _ -> fprintf fmt "%s = new %s();" node_inst (get_class_name node_type) 
164
	) 
165
    ) 
166
    instances
167

    
168
let pp_reset machines fmt m = 
169
  fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@,"
170
    (fprintf_list ~sep:"@," (pp_machine_instr m machines [])) m.minit
171

    
172
let pp_step machines fmt m : unit = 
173
  let out_assoc_list = 
174
    List.map (fun (node_inst, _) -> node_inst, "out_" ^ node_inst) m.minstances
175
  in
176
  fprintf fmt 
177
    "@[<v 2>public Output step (%a) {@,%a%t@,%a%a%t@,%a@,%t@]@,}@,"
178
    (Lustrec.Utils.fprintf_list ~sep:",@ " pp_var) m.mstep.step_inputs
179
    (* locals *)
180
    (Lustrec.Utils.fprintf_list ~sep:";@," pp_var) m.mstep.step_locals
181
    (pp_final_char_if_non_empty ";" m.mstep.step_locals) 
182
    (* declare out variables of subnode instances + out of this node *)
183
    (fprintf_list ~sep:"" 
184
       (fun fmt (ninst, ntype) -> fprintf fmt "%s.Output out_%s;@," (get_class_name ntype) ninst )) 
185
    (List.filter (fun (_,ntyp) -> not (ntyp = "_arrow")) m.minstances)
186
    (fprintf_list ~sep:";@," pp_var) m.mstep.step_outputs
187
    (pp_final_char_if_non_empty ";" m.mstep.step_outputs) 
188
    (* instructions *)
189
    (fprintf_list ~sep:"@," (pp_machine_instr m machines out_assoc_list)) m.mstep.step_instrs     
190
    (* create out object and return it *)
191
    (fun fmt -> fprintf fmt "return new Output(%a);" 
192
      (fprintf_list ~sep:"," (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_outputs 
193
    )
194
  
195

    
196

    
197
let print_machine machines fmt m =
198
  if m.mname.node_id = "_arrow" then () else ( (* We don't print arrow function *)
199
    fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."
200
      (String.capitalize m.mname.node_id) (* class name *)
201
      (pp_local_fields "protected") m.mmemory                      (* fields *)
202
      (pp_newline_if_non_empty m.mmemory)            
203
      pp_local_field_instances m.minstances          (* object fields *)
204
      (pp_newline_if_non_empty m.minstances)         
205
      (pp_newline_if_non_empty m.minstances)         
206
      pp_output_class m.mstep                        (* class for output of step method *)
207
      pp_constructor (m.mname.node_id, m.minstances) (* constructor to instanciate object fields *)
208
      (pp_reset machines) m                               (* reset method *)
209
      (pp_step machines) m             (* step method *)
210

    
211
  )
212

    
213
(********************************************************************************************)
214
(*                         Main related functions                                           *)
215
(********************************************************************************************)
216

    
217
(* let print_get_input fmt v = *)
218
(*   match v.var_type.Lustrec.Types.tdesc with *)
219
(*     | Lustrec.Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id *)
220
(*     | Lustrec.Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id *)
221
(*     | Lustrec.Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id *)
222
(*     | _ -> assert false *)
223

    
224
(* let print_put_outputs fmt ol =  *)
225
(*   let po fmt o = *)
226
(*     match o.var_type.Lustrec.Types.tdesc with *)
227
(*     | Lustrec.Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id *)
228
(*     | Lustrec.Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id *)
229
(*     | Lustrec.Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)
230
(*     | _ -> assert false *)
231
(*   in *)
232
(*   List.iter (fprintf fmt "@ %a;" po) ol *)
233

    
234
let read_input fmt typ = match typ.Lustrec.Types.tdesc with
235
  | Lustrec.Types.Treal -> fprintf fmt "StdIn.readDouble()"
236
  | Lustrec.Types.Tint ->  fprintf fmt "StdIn.readInt()"
237
  | Lustrec.Types.Tbool ->  fprintf fmt "StdIn.readBoolean()"
238
  | _ -> assert false
239

    
240
let print_main_fun basename machines m fmt =
241
  let m_class = String.capitalize m.mname.node_id in
242
  fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."
243
    (String.capitalize basename)
244
    "public static void main (String[] args)"
245
    (fun fmt -> fprintf fmt "%s main_node = new %s();"  m_class m_class)
246
    (fun fmt -> fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"  
247
      (fprintf_list ~sep:"@," 
248
	 (fun fmt v -> fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" 
249
	   v.var_id pp_var v read_input v.var_type))
250
      m.mstep.step_inputs
251
      (fun fmt -> fprintf fmt "%s.Output out = main_node.step(%a);" 
252
	m_class  
253
	(fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs
254
      )
255
      (fprintf_list ~sep:"@," (fun fmt v -> fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id v.var_id))
256
      m.mstep.step_outputs
257
    )
258
    
259
    
260
(* let print_main_fun machines m fmt = *)
261
(*   let mname = m.mname.node_id in *)
262
(*   let main_mem = *)
263
(*     if (!Lustrec.Options.static_mem && !Lustrec.Options.main_node <> "") *)
264
(*     then "&main_mem" *)
265
(*     else "main_mem" in *)
266
(*   fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ "; *)
267
(*   fprintf fmt "/* Declaration of inputs/outputs variables */@ "; *)
268
(*   List.iter  *)
269
(*     (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)
270
(*     ) m.mstep.step_inputs; *)
271
(*   List.iter  *)
272
(*     (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id pp_c_initialize v.var_type *)
273
(*     ) m.mstep.step_outputs; *)
274
(*   fprintf fmt "@ /* Main memory allocation */@ "; *)
275
(*   if (!Lustrec.Options.static_mem && !Lustrec.Options.main_node <> "") *)
276
(*   then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname) *)
277
(*   else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname pp_machine_alloc_name mname); *)
278
(*   fprintf fmt "@ /* Initialize the main memory */@ "; *)
279
(*   fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem; *)
280
(*   fprintf fmt "@ ISATTY = isatty(0);@ "; *)
281
(*   fprintf fmt "@ /* Infinite loop */@ "; *)
282
(*   fprintf fmt "@[<v 2>while(1){@ "; *)
283
(*   fprintf fmt  "fflush(stdout);@ "; *)
284
(*   List.iter  *)
285
(*     (fun v -> fprintf fmt "%s = %a;@ " *)
286
(*       v.var_id *)
287
(*       print_get_input v *)
288
(*     ) m.mstep.step_inputs; *)
289
(*   (match m.mstep.step_outputs with *)
290
(*     | [] -> ( *)
291
(*       fprintf fmt "%a(%a%t%s);@ "  *)
292
(* 	pp_machine_step_name mname *)
293
(* 	(Lustrec.Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
294
(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
295
(* 	main_mem *)
296
(*     ) *)
297
(*     | [o] -> ( *)
298
(*       fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
299
(* 	o.var_id *)
300
(* 	pp_machine_step_name mname *)
301
(* 	(Lustrec.Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
302
(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
303
(* 	(Lustrec.Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
304
(* 	main_mem *)
305
(* 	print_put_outputs [o]) *)
306
(*     | _ -> ( *)
307
(*       fprintf fmt "%a(%a%t%a, %s);%a" *)
308
(* 	pp_machine_step_name mname *)
309
(* 	(Lustrec.Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id)) m.mstep.step_inputs *)
310
(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
311
(* 	(Lustrec.Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id)) m.mstep.step_outputs *)
312
(* 	main_mem *)
313
(* 	print_put_outputs m.mstep.step_outputs) *)
314
(*   ); *)
315
(*   fprintf fmt "@]@ }@ "; *)
316
(*   fprintf fmt "return 1;"; *)
317
(*   fprintf fmt "@]@ }@."        *)
318

    
319
(* let print_main_header fmt = *)
320
(*   fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include \"io_frontend.h\"@." *)
321
  
322
      
323
(********************************************************************************************)
324
(*                         Translation function                                             *)
325
(********************************************************************************************)
326

    
327
let translate_to_java source_fmt basename prog machines =
328

    
329
  
330
  (* If a main node is identified, generate a main function for it *)
331
  let main_print =
332
    match !Lustrec.Options.main_node with
333
      | "" -> (fun _ -> ())
334
      | main_node -> (
335
  	let main_node_opt =
336
  	  List.fold_left
337
  	    (fun res m ->
338
  	      match res with
339
  		| Some _ -> res
340
  		| None -> if m.mname.node_id = main_node then Some m else None)
341
  	    None machines
342
	in
343
	match main_node_opt with
344
  	  | None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ())
345
  	  | Some m -> print_main_fun basename machines m
346
      )
347
  in
348
  
349
  (* Print nodes one by one (in the previous order) *)
350
  List.iter ((print_machine machines) source_fmt) machines;
351
  main_print source_fmt 
352

    
353

    
354

    
355

    
356
(* Local Variables: *)
357
(* compile-command:"make -C .." *)
358
(* End: *)
    (1-1/1)