Project

General

Profile

Download (14 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

    
12
open Format
13
open Utils
14
open LustreSpec
15
open Corelang
16
open Machine_code
17

    
18
(********************************************************************************************)
19
(* Basic Printing functions *)
20
(********************************************************************************************)
21

    
22
let pp_final_char_if_non_empty c l fmt =
23
  match l with [] -> () | _ -> fprintf fmt "%s" c
24

    
25
let pp_newline_if_non_empty l fmt =
26
  match l with [] -> () | _ -> fprintf fmt "@,"
27

    
28
let pp_dimension fmt d = Printers.pp_expr fmt (expr_of_dimension d)
29

    
30
let pp_type fmt t =
31
  match (Types.repr t).Types.tdesc with
32
  | Types.Tbool ->
33
    pp_print_string fmt "boolean"
34
  | Types.Treal ->
35
    pp_print_string fmt "double"
36
  | _ ->
37
    Types.print_ty fmt t
38

    
39
let pp_var fmt id = fprintf fmt "%a %s" pp_type id.var_type id.var_id
40

    
41
let pp_tag fmt t = pp_print_string fmt t
42

    
43
let rec pp_const fmt c =
44
  match c with
45
  | Const_int i ->
46
    pp_print_int fmt i
47
  | Const_real r ->
48
    pp_print_string fmt r
49
  | Const_float r ->
50
    pp_print_float fmt r
51
  | Const_tag t ->
52
    pp_tag fmt t
53
  | Const_array ca ->
54
    Format.fprintf fmt "{%a}" (Utils.fprintf_list ~sep:"," pp_const) ca
55

    
56
let rec pp_val m fmt v =
57
  match v with
58
  | Cst c ->
59
    pp_const fmt c
60
  | Var v ->
61
    if is_state_vars m.memories v then fprintf fmt "%s" v
62
    else if List.exists (fun o -> o.var_id = v) m.mstep.step_outputs then
63
      fprintf fmt "*%s" v
64
    else pp_print_string fmt v
65
  | Fun (n, vl) ->
66
    if Basic_library.is_internal_fun n then
67
      Basic_library.pp_java n (pp_val m) fmt vl
68
    else fprintf fmt "%s (%a)" n (Utils.fprintf_list ~sep:", " (pp_val m)) vl
69

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

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

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

    
131
and pp_machine_branch m machines instance_out_list fmt (t, h) =
132
  Format.fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_tag t
133
    (Utils.fprintf_list ~sep:"@,"
134
       (pp_machine_instr m machines instance_out_list))
135
    h
136

    
137
(********************************************************************************************)
138
(* Java file Printing functions *)
139
(********************************************************************************************)
140

    
141
let get_class_name n =
142
  match n with "_arrow" -> "boolean" | _ -> String.capitalize n
143

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

    
147
let pp_local_field_instances =
148
  fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->
149
      fprintf fmt "protected %s %s;" (get_class_name node_type) node_inst)
150

    
151
let pp_output_constructor fmt outputs =
152
  fprintf fmt "@[<v 2>public Output(%a) {@,%a@]@,}"
153
    (fprintf_list ~sep:"; " pp_var)
154
    outputs
155
    (fprintf_list ~sep:"@," (fun fmt v ->
156
         fprintf fmt "this.%s = %s;" v.var_id v.var_id))
157
    outputs
158

    
159
let pp_output_class fmt step =
160
  fprintf fmt "@[<v 2>public class Output {@,%a@,@,%a@]@,}@,"
161
    (pp_local_fields "public") step.step_outputs pp_output_constructor
162
    step.step_outputs
163

    
164
let pp_constructor fmt (name, instances) =
165
  fprintf fmt "@[<v 2>public %s () {@,%a@]@,}@," (String.capitalize name)
166
    (fprintf_list ~sep:"@," (fun fmt (node_inst, node_type) ->
167
         match node_type with
168
         | "_arrow" ->
169
           fprintf fmt "%s = true;" node_inst
170
         | _ ->
171
           fprintf fmt "%s = new %s();" node_inst (get_class_name node_type)))
172
    instances
173

    
174
let pp_reset machines fmt m =
175
  fprintf fmt "@[<v 2>public void reset () {@,%a@]@,}@,"
176
    (fprintf_list ~sep:"@," (pp_machine_instr m machines []))
177
    m.minit
178

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

    
206
let print_machine machines fmt m =
207
  if m.mname.node_id = "_arrow" then ()
208
  else
209
    (* We don't print arrow function *)
210
    fprintf fmt "@[<v 2>class %s {@,%a%t%a%t%t%a@,%a@,%a@,%a@]@,}@.@.@."
211
      (String.capitalize m.mname.node_id)
212
      (* class name *)
213
      (pp_local_fields "protected")
214
      m.mmemory
215
      (* fields *)
216
      (pp_newline_if_non_empty m.mmemory)
217
      pp_local_field_instances m.minstances
218
      (* object fields *)
219
      (pp_newline_if_non_empty m.minstances)
220
      (pp_newline_if_non_empty m.minstances)
221
      pp_output_class m.mstep
222
      (* class for output of step method *)
223
      pp_constructor
224
      (m.mname.node_id, m.minstances)
225
      (* constructor to instanciate object fields *)
226
      (pp_reset machines)
227
      m
228
      (* reset method *)
229
      (pp_step machines)
230
      m
231
(* step method *)
232

    
233
(********************************************************************************************)
234
(* Main related functions *)
235
(********************************************************************************************)
236

    
237
(* let print_get_input fmt v = *)
238
(*   match v.var_type.Types.tdesc with *)
239
(*     | Types.Tint -> fprintf fmt "_get_int(\"%s\")" v.var_id *)
240
(*     | Types.Tbool -> fprintf fmt "_get_bool(\"%s\")" v.var_id *)
241
(*     | Types.Treal -> fprintf fmt "_get_double(\"%s\")" v.var_id *)
242
(*     | _ -> assert false *)
243

    
244
(* let print_put_outputs fmt ol =  *)
245
(*   let po fmt o = *)
246
(*     match o.var_type.Types.tdesc with *)
247
(*     | Types.Tint -> fprintf fmt "_put_int(\"%s\", %s)" o.var_id o.var_id *)
248
(*     | Types.Tbool -> fprintf fmt "_put_bool(\"%s\", %s)" o.var_id o.var_id *)
249
(* | Types.Treal -> fprintf fmt "_put_double(\"%s\", %s)" o.var_id o.var_id *)
250
(*     | _ -> assert false *)
251
(*   in *)
252
(*   List.iter (fprintf fmt "@ %a;" po) ol *)
253

    
254
let read_input fmt typ =
255
  match typ.Types.tdesc with
256
  | Types.Treal ->
257
    fprintf fmt "StdIn.readDouble()"
258
  | Types.Tint ->
259
    fprintf fmt "StdIn.readInt()"
260
  | Types.Tbool ->
261
    fprintf fmt "StdIn.readBoolean()"
262
  | _ ->
263
    assert false
264

    
265
let print_main_fun basename machines m fmt =
266
  let m_class = String.capitalize m.mname.node_id in
267
  fprintf fmt "@[<v 2>class %s {@,@,@[<v 2>%s {@,%t@,%t@]@,}@,@]@,}@."
268
    (String.capitalize basename)
269
    "public static void main (String[] args)"
270
    (fun fmt -> fprintf fmt "%s main_node = new %s();" m_class m_class)
271
    (fun fmt ->
272
      fprintf fmt "@[<v 2>while (true) {@,%a@,%t@,%a@]@,}@,"
273
        (fprintf_list ~sep:"@," (fun fmt v ->
274
             fprintf fmt "System.out.println(\"%s?\");@,%a = %a;" v.var_id
275
               pp_var v read_input v.var_type))
276
        m.mstep.step_inputs
277
        (fun fmt ->
278
          fprintf fmt "%s.Output out = main_node.step(%a);" m_class
279
            (fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
280
            m.mstep.step_inputs)
281
        (fprintf_list ~sep:"@," (fun fmt v ->
282
             fprintf fmt "System.out.println(\"%s = \" + out.%s);" v.var_id
283
               v.var_id))
284
        m.mstep.step_outputs)
285

    
286
(* let print_main_fun machines m fmt = *)
287
(*   let mname = m.mname.node_id in *)
288
(*   let main_mem = *)
289
(*     if (!Options.static_mem && !Options.main_node <> "") *)
290
(*     then "&main_mem" *)
291
(*     else "main_mem" in *)
292
(*   fprintf fmt "@[<v 2>int main (int argc, char *argv[]) {@ "; *)
293
(*   fprintf fmt "/* Declaration of inputs/outputs variables */@ "; *)
294
(*   List.iter  *)
295
(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id
296
   pp_c_initialize v.var_type *)
297
(*     ) m.mstep.step_inputs; *)
298
(*   List.iter  *)
299
(* (fun v -> fprintf fmt "%a %s = %a;@ " pp_c_type v.var_type v.var_id
300
   pp_c_initialize v.var_type *)
301
(*     ) m.mstep.step_outputs; *)
302
(*   fprintf fmt "@ /* Main memory allocation */@ "; *)
303
(*   if (!Options.static_mem && !Options.main_node <> "") *)
304
(*   then (fprintf fmt "%a(main_mem);@ " pp_machine_static_alloc_name mname) *)
305
(* else (fprintf fmt "%a *main_mem = %a();@ " pp_machine_memtype_name mname
306
   pp_machine_alloc_name mname); *)
307
(*   fprintf fmt "@ /* Initialize the main memory */@ "; *)
308
(*   fprintf fmt "%a(%s);@ " pp_machine_reset_name mname main_mem; *)
309
(*   fprintf fmt "@ ISATTY = isatty(0);@ "; *)
310
(*   fprintf fmt "@ /* Infinite loop */@ "; *)
311
(*   fprintf fmt "@[<v 2>while(1){@ "; *)
312
(*   fprintf fmt  "fflush(stdout);@ "; *)
313
(*   List.iter  *)
314
(*     (fun v -> fprintf fmt "%s = %a;@ " *)
315
(*       v.var_id *)
316
(*       print_get_input v *)
317
(*     ) m.mstep.step_inputs; *)
318
(*   (match m.mstep.step_outputs with *)
319
(*     | [] -> ( *)
320
(*       fprintf fmt "%a(%a%t%s);@ "  *)
321
(* 	pp_machine_step_name mname *)
322
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
323
   m.mstep.step_inputs *)
324
(* 	(pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
325
(* 	main_mem *)
326
(*     ) *)
327
(*     | [o] -> ( *)
328
(*       fprintf fmt "%s = %a(%a%t%a, %s);%a" *)
329
(* 	o.var_id *)
330
(* 	pp_machine_step_name mname *)
331
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
332
   m.mstep.step_inputs *)
333
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
334
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))
335
   m.mstep.step_outputs *)
336
(* 	main_mem *)
337
(* 	print_put_outputs [o]) *)
338
(*     | _ -> ( *)
339
(*       fprintf fmt "%a(%a%t%a, %s);%a" *)
340
(* 	pp_machine_step_name mname *)
341
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> pp_print_string fmt v.var_id))
342
   m.mstep.step_inputs *)
343
(* (pp_final_char_if_non_empty ", " m.mstep.step_inputs) *)
344
(* (Utils.fprintf_list ~sep:", " (fun fmt v -> fprintf fmt "&%s" v.var_id))
345
   m.mstep.step_outputs *)
346
(* 	main_mem *)
347
(* 	print_put_outputs m.mstep.step_outputs) *)
348
(*   ); *)
349
(*   fprintf fmt "@]@ }@ "; *)
350
(*   fprintf fmt "return 1;"; *)
351
(*   fprintf fmt "@]@ }@."        *)
352

    
353
(* let print_main_header fmt = *)
354
(* fprintf fmt "#include <stdio.h>@.#include <unistd.h>@.#include
355
   \"io_frontend.h\"@." *)
356

    
357
(********************************************************************************************)
358
(* Translation function *)
359
(********************************************************************************************)
360

    
361
let translate_to_java source_fmt basename prog machines =
362
  (* If a main node is identified, generate a main function for it *)
363
  let main_print =
364
    match !Options.main_node with
365
    | "" ->
366
      fun _ -> ()
367
    | main_node -> (
368
      let main_node_opt =
369
        List.fold_left
370
          (fun res m ->
371
            match res with
372
            | Some _ ->
373
              res
374
            | None ->
375
              if m.mname.node_id = main_node then Some m else None)
376
          None machines
377
      in
378
      match main_node_opt with
379
      | None ->
380
        eprintf "Unable to find a main node named %s@.@?" main_node;
381
        fun _ -> ()
382
      | Some m ->
383
        print_main_fun basename machines m)
384
  in
385

    
386
  (* Print nodes one by one (in the previous order) *)
387
  List.iter ((print_machine machines) source_fmt) machines;
388
  main_print source_fmt
389

    
390
(* Local Variables: *)
391
(* compile-command:"make -C .." *)
392
(* End: *)
    (1-1/1)