Project

General

Profile

Revision cd670fe1

View differences:

src/backends/C/c_backend.ml
23 23

  
24 24
(* This module is used for the lustre to C compiler *)
25 25

  
26
open Format
27
open LustreSpec
28
open Corelang
29
open Machine_code
30
open C_backend_common
31

  
32

  
33
let print_machine_decl_prefix = ref (fun fmt x -> ())
34
(********************************************************************************************)
35
(*                     Basic      Printing functions                                        *)
36
(********************************************************************************************)
37

  
38
let print_version fmt =
39
  Format.fprintf fmt 
40
    "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
41
    (Filename.basename Sys.executable_name) 
42
    Version.number 
43
    (if !Options.ansi then "ANSI C90" else "C99")
44

  
45

  
46
(********************************************************************************************)
47
(*                    Instruction Printing functions                                        *)
48
(********************************************************************************************)
49

  
50
(* Computes the depth to which multi-dimension array assignments should be expanded.
51
   It equals the maximum number of nested static array constructions accessible from root [v].
52
*)
53
let rec expansion_depth v =
54
 match v with
55
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
56
 | Cst _
57
 | LocalVar _
58
 | StateVar _  -> 0
59
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
60
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
61
 | Access (v, i) -> max 0 (expansion_depth v - 1)
62
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
63

  
64
type loop_index = LVar of ident | LInt of int ref
65

  
66
(* Computes the list of nested loop variables together with their dimension bounds.
67
   - LInt r stands for loop expansion (no loop variable, but int loop index)
68
   - LVar v stands for loop variable v
69
*)
70
let rec mk_loop_variables m ty depth =
71
 match (Types.repr ty).Types.tdesc, depth with
72
 | Types.Tarray (d, ty'), 0       ->
73
   let v = mk_loop_var m () in
74
   (d, LVar v) :: mk_loop_variables m ty' 0
75
 | Types.Tarray (d, ty'), _       ->
76
   let r = ref (-1) in
77
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
78
 | _                    , 0       -> []
79
 | _                              -> assert false
80

  
81
let reorder_loop_variables loop_vars =
82
  let (int_loops, var_loops) = 
83
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
84
  in
85
  var_loops @ int_loops
86
    
87
(* Prints a one loop variable suffix for arrays *)
88
let pp_loop_var fmt lv =
89
 match snd lv with
90
 | LVar v -> fprintf fmt "[%s]" v
91
 | LInt r -> fprintf fmt "[%d]" !r
92

  
93
(* Prints a suffix of loop variables for arrays *)
94
let pp_suffix fmt loop_vars =
95
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
96

  
97
(* Prints a [value] indexed by the suffix list [loop_vars] *)
98
let rec pp_value_suffix self loop_vars pp_value fmt value =
99
 match loop_vars, value with
100
 | (_, LInt r) :: q, Array vl     ->
101
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
102
 | _           :: q, Power (v, n) ->
103
   pp_value_suffix self loop_vars pp_value fmt v
104
 | _               , Fun (n, vl)  ->
105
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
106
 | _               , _            ->
107
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
108
   pp_c_val self pp_var_suffix fmt value
109

  
110
(* type_directed assignment: array vs. statically sized type
111
   - [var_type]: type of variable to be assigned
112
   - [var_name]: name of variable to be assigned
113
   - [value]: assigned value
114
   - [pp_var]: printer for variables
115
*)
116
let pp_assign m self pp_var fmt var_type var_name value =
117
  let depth = expansion_depth value in
118
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
119
  let loop_vars = mk_loop_variables m var_type depth in
120
  let reordered_loop_vars = reorder_loop_variables loop_vars in
121
  let rec aux fmt vars =
122
    match vars with
123
    | [] ->
124
      fprintf fmt "%a = %a;" 
125
	(pp_value_suffix self loop_vars pp_var) var_name
126
	(pp_value_suffix self loop_vars pp_var) value
127
    | (d, LVar i) :: q ->
128
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
129
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
130
	i i i Dimension.pp_dimension d i
131
	aux q
132
    | (d, LInt r) :: q ->
133
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
134
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
135
      fprintf fmt "@[<v 2>{@,%a@]@,}"
136
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
137
  in
138
  begin
139
    reset_loop_counter ();
140
    (*reset_addr_counter ();*)
141
    aux fmt reordered_loop_vars
142
  end
143

  
144
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
145
 try (* stateful node instance *)
146
   let (n,_) = List.assoc i m.minstances in
147
   fprintf fmt "%a (%a%t%a%t%s->%s);"
148
     pp_machine_step_name (node_name n)
149
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
150
     (Utils.pp_final_char_if_non_empty ", " inputs) 
151
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
152
     (Utils.pp_final_char_if_non_empty ", " outputs)
153
     self
154
     i
155
 with Not_found -> (* stateless node instance *)
156
   let (n,_) = List.assoc i m.mcalls in
157
   fprintf fmt "%a (%a%t%a);"
158
     pp_machine_step_name (node_name n)
159
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
160
     (Utils.pp_final_char_if_non_empty ", " inputs) 
161
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
162

  
163
let pp_machine_reset (m: machine_t) self fmt inst =
164
  let (node, static) = List.assoc inst m.minstances in
165
  fprintf fmt "%a(%a%t%s->%s);"
166
    pp_machine_reset_name (node_name node)
167
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
168
    (Utils.pp_final_char_if_non_empty ", " static)
169
    self inst
170

  
171
let has_c_prototype funname dependencies =
172
  let imported_node_opt = (* We select the last imported node with the name funname.
173
			       The order of evaluation of dependencies should be
174
			       compatible with overloading. (Not checked yet) *) 
175
      List.fold_left
176
	(fun res (_, _, decls) -> 
177
	  match res with
178
	  | Some _ -> res
179
	  | None -> 
180
	    let matched = fun t -> match t.top_decl_desc with 
181
	      | ImportedNode nd -> nd.nodei_id = funname 
182
	      | _ -> false
183
	    in
184
	    if List.exists matched decls then (
185
	      match (List.find matched decls).top_decl_desc with
186
	      | ImportedNode nd -> Some nd
187
	      | _ -> assert false
188
	    )
189
	    else
190
	      None
191
	) None dependencies in
192
    match imported_node_opt with
193
    | None -> false
194
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
195

  
196
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
197
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
198
    (pp_c_val self (pp_c_var_read m)) c
199
    (Utils.pp_newline_if_non_empty tl)
200
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
201
    (Utils.pp_newline_if_non_empty el)
202
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
203

  
204
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
205
  match instr with 
206
  | MReset i ->
207
    pp_machine_reset m self fmt i
208
  | MLocalAssign (i,v) ->
209
    pp_assign
210
      m self (pp_c_var_read m) fmt
211
      i.var_type (LocalVar i) v
212
  | MStateAssign (i,v) ->
213
    pp_assign
214
      m self (pp_c_var_read m) fmt
215
      i.var_type (StateVar i) v
216
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
217
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
218
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
219
    fprintf fmt "%a = %s(%a);" 
220
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
221
      i
222
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
223
  | MStep (il, i, vl) ->
224
    pp_instance_call m self fmt i vl il
225
  | MBranch (g,hl) ->
226
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
227
    then (* boolean case, needs special treatment in C because truth value is not unique *)
228
	 (* may disappear if we optimize code by replacing last branch test with default *)
229
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
230
      let el = try List.assoc tag_false hl with Not_found -> [] in
231
      pp_conditional dependencies m self fmt g tl el
232
    else (* enum type case *)
233
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
234
	(pp_c_val self (pp_c_var_read m)) g
235
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
236

  
237
and pp_machine_branch dependencies m self fmt (t, h) =
238
  fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
239

  
240

  
241

  
242
(********************************************************************************************)
243
(*                      Prototype Printing functions                                        *)
244
(********************************************************************************************)
245

  
246
let print_alloc_prototype fmt (name, static) =
247
  fprintf fmt "%a * %a (%a)"
248
    pp_machine_memtype_name name
249
    pp_machine_alloc_name name
250
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
251

  
252
let print_reset_prototype self fmt (name, static) =
253
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
254
    pp_machine_reset_name name
255
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
256
    (Utils.pp_final_char_if_non_empty ",@," static) 
257
    pp_machine_memtype_name name
258
    self
259

  
260
let print_stateless_prototype fmt (name, inputs, outputs) =
261
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
262
    pp_machine_step_name name
263
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
264
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
265
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
266

  
267
let print_step_prototype self fmt (name, inputs, outputs) =
268
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
269
    pp_machine_step_name name
270
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
271
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
272
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
273
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
274
    pp_machine_memtype_name name
275
    self
276

  
277
(********************************************************************************************)
278
(*                         Header Printing functions                                        *)
279
(********************************************************************************************)
280

  
281

  
282
let print_import_standard fmt =
283
  fprintf fmt "#include \"%s/include/lustrec/arrow.h\"@.@." Version.prefix
284

  
285
let print_import_prototype fmt (s, _, _) =
286
  fprintf fmt "#include \"%s.h\"@," s
287
    
288
let pp_registers_struct fmt m =
289
  if m.mmemory <> []
290
  then
291
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
292
      pp_machine_regtype_name m.mname.node_id
293
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
294
  else
295
    ()
296

  
297
let print_machine_struct fmt m =
298
  if fst (get_stateless_status m) then
299
    begin
300
    end
301
  else
302
    begin
303
      (* Define struct *)
304
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
305
	pp_machine_memtype_name m.mname.node_id
306
	pp_registers_struct m
307
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
308
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
309
    end
310

  
311
let print_static_declare_instance attr fmt (i, (m, static)) =
312
  fprintf fmt "%a(%s, %a%t%s)"
313
    pp_machine_static_declare_name (node_name m)
314
    attr
315
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
316
    (Utils.pp_final_char_if_non_empty ", " static)
317
    i
318

  
319
let print_static_declare_macro fmt m =
320
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
321
  let inst = mk_instance m in
322
  let attr = mk_attribute m in
323
  fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%s %a %s;\\@,%a%t%a;@,@]"
324
    pp_machine_static_declare_name m.mname.node_id
325
    attr
326
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
327
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
328
    inst
329
    attr
330
    pp_machine_memtype_name m.mname.node_id
331
    inst
332
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
333
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
334
    (Utils.fprintf_list ~sep:";\\@,"
335
       (fun fmt (i',m') ->
336
	 let path = sprintf "inst ## _%s" i' in
337
	 fprintf fmt "%a"
338
	   (print_static_declare_instance attr) (path,m')
339
       )) m.minstances
340

  
341
      
342
let print_static_link_instance fmt (i, (m, _)) =
343
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
344

  
345
(* Allocation of a node struct:
346
   - if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct)
347
*)
348
let print_static_link_macro fmt m =
349
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
350
  fprintf fmt "@[<v>@[<v 2>#define %a(inst) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
351
    pp_machine_static_link_name m.mname.node_id
352
    (Utils.fprintf_list ~sep:";\\@,"
353
       (fun fmt v ->
354
	 fprintf fmt "inst._reg.%s = (%a*) &%s"
355
	   v.var_id
356
           (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v
357
	   v.var_id
358
       )) array_mem
359
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
360
    (Utils.fprintf_list ~sep:";\\@,"
361
       (fun fmt (i',m') ->
362
	 let path = sprintf "inst ## _%s" i' in
363
	 fprintf fmt "%a;\\@,inst.%s = &%s"
364
	   print_static_link_instance (path,m')
365
	   i'
366
	   path
367
       )) m.minstances
368
      
369
let print_static_alloc_macro fmt m =
370
  fprintf fmt "@[<v>@[<v 2>#define %a(attr,%a%tinst)\\@,%a(attr,%a%tinst);\\@,%a(inst);@]@,@]@."
371
    pp_machine_static_alloc_name m.mname.node_id
372
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
373
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
374
    pp_machine_static_declare_name m.mname.node_id
375
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
376
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
377
    pp_machine_static_link_name m.mname.node_id
378

  
379
 
380
let print_machine_decl fmt m =
381
  !print_machine_decl_prefix fmt m;
382
  if fst (get_stateless_status m) then
383
    begin
384
      fprintf fmt "extern %a;@.@."
385
	print_stateless_prototype
386
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
387
    end
388
  else
389
    begin
390
      (* Static allocation *)
391
      if !Options.static_mem
392
      then (
393
	fprintf fmt "%a@.%a@.%a@."
394
	  print_static_declare_macro m
395
	  print_static_link_macro m
396
	  print_static_alloc_macro m
397
      )
398
      else ( 
399
        (* Dynamic allocation *)
400
	fprintf fmt "extern %a;@.@."
401
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
402
      );
403
      let self = mk_self m in
404
      fprintf fmt "extern %a;@.@."
405
	(print_reset_prototype self) (m.mname.node_id, m.mstatic);
406

  
407
      fprintf fmt "extern %a;@.@."
408
	(print_step_prototype self)
409
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
410
    end
411

  
412

  
413
(********************************************************************************************)
414
(*                         C file Printing functions                                        *)
415
(********************************************************************************************)
416

  
417
let print_const_def fmt cdecl =
418
  fprintf fmt "%a = %a;@." 
419
    (pp_c_type cdecl.const_id) cdecl.const_type
420
    pp_c_const cdecl.const_value 
421

  
422
let print_const_decl fmt cdecl =
423
  fprintf fmt "extern %a;@." 
424
    (pp_c_type cdecl.const_id) cdecl.const_type
425

  
426
let print_alloc_instance fmt (i, (m, static)) =
427
  fprintf fmt "_alloc->%s = %a (%a);@,"
428
    i
429
    pp_machine_alloc_name (node_name m)
430
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
431

  
432
let print_alloc_array fmt vdecl =
433
  let base_type = Types.array_base_type vdecl.var_type in
434
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
435
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
436
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
437
    vdecl.var_id
438
    (pp_c_type "") base_type
439
    Dimension.pp_dimension size_type
440
    (pp_c_type "") base_type
441
    vdecl.var_id
442

  
443
let print_alloc_code fmt m =
444
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
445
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
446
    pp_machine_memtype_name m.mname.node_id
447
    pp_machine_memtype_name m.mname.node_id
448
    pp_machine_memtype_name m.mname.node_id
449
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
450
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
451

  
452
let print_stateless_code dependencies fmt m =
453
  let self = "__ERROR__" in
454
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
455
  then
456
    (* C99 code *)
457
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
458
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
459
      (* locals *)
460
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
461
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
462
      (* check assertions *)
463
      (pp_c_checks self) m
464
      (* instrs *)
465
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
466
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
467
      (fun fmt -> fprintf fmt "return;")
468
  else
469
    (* C90 code *)
470
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
471
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
472
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
473
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
474
      (* locals *)
475
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
476
      (Utils.pp_final_char_if_non_empty ";" base_locals)
477
      (* check assertions *)
478
      (pp_c_checks self) m
479
      (* instrs *)
480
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
481
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
482
      (fun fmt -> fprintf fmt "return;")
483

  
484
let print_reset_code dependencies fmt m self =
485
  fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
486
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
487
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
488
    (Utils.pp_newline_if_non_empty m.minit)
489

  
490
let print_step_code dependencies fmt m self =
491
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
492
  then
493
    (* C99 code *)
494
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
495
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
496
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
497
      (* locals *)
498
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
499
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
500
      (* array mems *)
501
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
502
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
503
      (* check assertions *)
504
      (pp_c_checks self) m
505
      (* instrs *)
506
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
507
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
508
      (fun fmt -> fprintf fmt "return;")
509
  else
510
    (* C90 code *)
511
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
512
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
513
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
514
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
515
      (* locals *)
516
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
517
      (Utils.pp_final_char_if_non_empty ";" base_locals)
518
      (* check assertions *)
519
      (pp_c_checks self) m
520
      (* instrs *)
521
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
522
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
523
      (fun fmt -> fprintf fmt "return;")
524

  
525
let print_machine dependencies fmt m =
526
  if fst (get_stateless_status m) then
527
    begin
528
      (* Step function *)
529
      print_stateless_code dependencies fmt m
530
    end
531
  else
532
    begin
533
      (* Alloc function, only if non static mode *)
534
      if (not !Options.static_mem) then  
535
	(
536
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
537
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
538
	    print_alloc_code m;
539
	);
540
      let self = mk_self m in
541
      (* Reset function *)
542
      print_reset_code dependencies fmt m self;
543
      (* Step function *)
544
      print_step_code dependencies fmt m self
545
    end
546

  
547

  
548

  
549
let header_has_code header =
550
  List.exists 
551
    (fun top -> 
552
      match top.top_decl_desc with
553
      | Consts _ -> true 
554
      | ImportedNode nd -> nd.nodei_in_lib = None
555
      | _ -> false
556
    )
557
    header
558

  
559
let header_libs header =
560
  List.fold_left (fun accu top ->
561
    match top.top_decl_desc with
562
      | ImportedNode nd -> (match nd.nodei_in_lib with 
563
	| None -> accu 
564
	| Some lib -> Utils.list_union [lib] accu)
565
      | _ -> accu 
566
  ) [] header 
567
    
568
let print_makefile basename nodename dependencies fmt =
569
  let compiled_dependencies = 
570
    List.filter (fun (_, _, header) -> header_has_code header) dependencies
571
  in
572
  let lib_dependencies = 
573
    List.fold_left 
574
      (fun accu (_, _, header) -> Utils.list_union (header_libs header) accu) [] dependencies 
575
  in
576
  fprintf fmt "GCC=gcc@.";
577
  fprintf fmt "LUSTREC=%s@." Sys.executable_name;
578
  fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
579
  fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
580
  fprintf fmt "@.";
581
  fprintf fmt "%s_%s:@." basename nodename;
582
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;    
583
  List.iter (fun s -> (* Format.eprintf "Adding dependency: %s@." s;  *)
584
    fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
585
    (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
586
	(List.map 
587
	   (fun (s, local, _) -> 
588
	     (if local then s else Version.prefix ^ "/include/lustrec/" ^ s) ^ ".c")
589
	   compiled_dependencies));    
590
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %a@." basename nodename 
591
    (Utils.fprintf_list ~sep:" " (fun fmt (s, _, _) -> Format.fprintf fmt "%s.o" s)) compiled_dependencies 
592
    basename
593
    (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) lib_dependencies
594
    ;
595
 fprintf fmt "@.";
596
 fprintf fmt "clean:@.";
597
 fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename
598

  
599

  
600
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
601
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
602
and pp_c_type_decl filename cpt var fmt tdecl =
603
  match tdecl with
604
  | Tydec_any           -> assert false
605
  | Tydec_int           -> fprintf fmt "int %s" var
606
  | Tydec_real          -> fprintf fmt "double %s" var
607
  | Tydec_float         -> fprintf fmt "float %s" var
608
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
609
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
610
  | Tydec_const c       -> fprintf fmt "%s %s" c var
611
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
612
  | Tydec_enum tl ->
613
    begin
614
      incr cpt;
615
      fprintf fmt "enum _enum_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
616
    end
617
  | Tydec_struct fl ->
618
    begin
619
      incr cpt;
620
      fprintf fmt "struct _struct_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var
621
    end
622

  
623
let print_type_definitions fmt filename =
624
  let cpt_type = ref 0 in
625
  Hashtbl.iter (fun typ def ->
626
    match typ with
627
    | Tydec_const var ->
628
      fprintf fmt "typedef %a;@.@."
629
	(pp_c_type_decl filename cpt_type var) def
630
    | _        -> ()) type_table
631

  
632

  
633 26

  
634 27
(********************************************************************************************)
635 28
(*                         Translation function                                             *)
636 29
(********************************************************************************************)
637
let print_header header_fmt basename prog machines =
638
  (* Include once: start *)
639
  let baseNAME = String.uppercase basename in
640
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
641
  (* Print the svn version number and the supported C standard (C90 or C99) *)
642
  print_version header_fmt;
643
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
644
  pp_print_newline header_fmt ();
645
  fprintf header_fmt "/* Imports standard library */@.";
646
  (* imports standard library definitions (arrow) *)
647
  print_import_standard header_fmt;
648
  pp_print_newline header_fmt ();
649
  fprintf header_fmt "/* Types definitions */@.";
650
  (* Print the type definitions from the type table *)
651
  print_type_definitions header_fmt basename;
652
  pp_print_newline header_fmt ();
653
  (* Print the global constant declarations. *)
654
  fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
655
  List.iter (fun c -> print_const_decl header_fmt c) (get_consts prog);
656
  pp_print_newline header_fmt ();
657
  (* Print the struct declarations of all machines. *)
658
  fprintf header_fmt "/* Struct declarations */@.";
659
  List.iter (print_machine_struct header_fmt) machines;
660
  pp_print_newline header_fmt ();
661
  (* Print the prototypes of all machines *)
662
  fprintf header_fmt "/* Nodes declarations */@.";
663
  List.iter (print_machine_decl header_fmt) machines;
664
  pp_print_newline header_fmt ();
665
  (* Include once: end *)
666
  fprintf header_fmt "#endif@.";
667
  pp_print_newline header_fmt ()
668

  
669
let print_c source_fmt basename prog machines dependencies =
670

  
671
  (* If a main node is identified, generate a main function for it *)
672
  let main_include, main_print, main_makefile =
673
    match !Options.main_node with
674
      | "" -> (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
675
      | main_node -> (
676
	match Machine_code.get_machine_opt main_node machines with
677
	| None -> eprintf "Unable to find a main node named %s@.@?" main_node; (fun _ -> ()), (fun _ -> ()), (fun _ -> ())
678
	| Some m -> C_backend_main.print_main_header, C_backend_main.print_main_fun machines m, print_makefile basename !Options.main_node dependencies
679
      )
680
  in
681
  main_include source_fmt;
682
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
683
  (* Print the svn version number and the supported C standard (C90 or C99) *)
684
  print_version source_fmt;
685
  (* Print the prototype of imported nodes *)
686
  fprintf source_fmt "/* Imported nodes declarations */@.";
687
  fprintf source_fmt "@[<v>";
688
  List.iter (print_import_prototype source_fmt) dependencies;
689
  fprintf source_fmt "@]@.";
690
  (* Print consts *)
691
  fprintf source_fmt "/* Global constants (definitions) */@.";
692
  List.iter (fun c -> print_const_def source_fmt c) (get_consts prog);
693
  pp_print_newline source_fmt ();
694
  (* Print nodes one by one (in the previous order) *)
695
  List.iter (print_machine dependencies source_fmt) machines;
696
  main_print source_fmt
697 30

  
698 31
let translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt 
699 32
                   basename prog machines dependencies =
700 33

  
701 34
  (* Generating H file *)
702
  print_header header_fmt basename prog machines;
35
  C_backend_header.print_header header_fmt basename prog machines;
703 36

  
704 37
  (* Generating C file *)
705
  print_c source_fmt basename prog machines dependencies;
38
  C_backend_src.print_c source_fmt basename prog machines dependencies;
706 39

  
707 40
  (* Generating Makefile *)
708 41
  (* If a main node is identified, generate a main target for it *)
......
710 43
      | "" ->  ()
711 44
      | main_node -> (
712 45
	match Machine_code.get_machine_opt main_node machines with
713
	| None -> eprintf "Unable to find a main node named %s@.@?" main_node; 
46
	| None -> Format.eprintf "Unable to find a main node named %s@.@?" main_node; 
714 47
	  ()
715
	| Some m -> print_makefile basename !Options.main_node dependencies makefile_fmt
48
	| Some _ -> C_backend_makefile.print_makefile basename !Options.main_node dependencies makefile_fmt
716 49
      )
717 50

  
718 51
(* Local Variables: *)
719
(* compile-command:"make -C .." *)
52
(* compile-command:"make -C ../../.." *)
720 53
(* End: *)
src/backends/C/c_backend_common.ml
4 4
open Machine_code
5 5

  
6 6

  
7
let print_version fmt =
8
  Format.fprintf fmt 
9
    "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
10
    (Filename.basename Sys.executable_name) 
11
    Version.number 
12
    (if !Options.ansi then "ANSI C90" else "C99")
13

  
14

  
7 15
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
8 16
let mk_self m =
9 17
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
......
207 215
let pp_c_checks self fmt m =
208 216
  Utils.fprintf_list ~sep:"" (fun fmt (loc, check) -> fprintf fmt "@[<v>%a@,assert (%a);@]@," Location.pp_c_loc loc (pp_c_val self (pp_c_var_read m)) check) fmt m.mstep.step_checks
209 217

  
218

  
219
(********************************************************************************************)
220
(*                      Prototype Printing functions                                        *)
221
(********************************************************************************************)
222

  
223
let print_alloc_prototype fmt (name, static) =
224
  fprintf fmt "%a * %a (%a)"
225
    pp_machine_memtype_name name
226
    pp_machine_alloc_name name
227
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
228

  
229
let print_reset_prototype self fmt (name, static) =
230
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
231
    pp_machine_reset_name name
232
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
233
    (Utils.pp_final_char_if_non_empty ",@," static) 
234
    pp_machine_memtype_name name
235
    self
236

  
237
let print_stateless_prototype fmt (name, inputs, outputs) =
238
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
239
    pp_machine_step_name name
240
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
241
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
242
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
243

  
244
let print_step_prototype self fmt (name, inputs, outputs) =
245
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
246
    pp_machine_step_name name
247
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
248
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
249
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
250
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
251
    pp_machine_memtype_name name
252
    self
253

  
254
let print_import_prototype fmt (s, _, _) =
255
  fprintf fmt "#include \"%s.h\"@," s
256

  
210 257
(* Local Variables: *)
211
(* compile-command:"make -C .." *)
258
(* compile-command:"make -C ../../.." *)
212 259
(* End: *)
src/backends/C/c_backend_header.ml
1
open Format 
2
open LustreSpec
3
open Corelang
4
open Machine_code
5
open C_backend_common
6

  
7
(********************************************************************************************)
8
(*                         Header Printing functions                                        *)
9
(********************************************************************************************)
10
let print_machine_decl_prefix = ref (fun fmt x -> ())
11

  
12

  
13
let print_import_standard fmt =
14
  fprintf fmt "#include \"%s/include/lustrec/arrow.h\"@.@." Version.prefix
15

  
16
    
17
let pp_registers_struct fmt m =
18
  if m.mmemory <> []
19
  then
20
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
21
      pp_machine_regtype_name m.mname.node_id
22
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
23
  else
24
    ()
25

  
26
let print_machine_struct fmt m =
27
  if fst (get_stateless_status m) then
28
    begin
29
    end
30
  else
31
    begin
32
      (* Define struct *)
33
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
34
	pp_machine_memtype_name m.mname.node_id
35
	pp_registers_struct m
36
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
37
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
38
    end
39

  
40
let print_static_declare_instance attr fmt (i, (m, static)) =
41
  fprintf fmt "%a(%s, %a%t%s)"
42
    pp_machine_static_declare_name (node_name m)
43
    attr
44
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
45
    (Utils.pp_final_char_if_non_empty ", " static)
46
    i
47

  
48
let print_static_declare_macro fmt m =
49
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
50
  let inst = mk_instance m in
51
  let attr = mk_attribute m in
52
  fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%s %a %s;\\@,%a%t%a;@,@]"
53
    pp_machine_static_declare_name m.mname.node_id
54
    attr
55
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
56
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
57
    inst
58
    attr
59
    pp_machine_memtype_name m.mname.node_id
60
    inst
61
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
62
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
63
    (Utils.fprintf_list ~sep:";\\@,"
64
       (fun fmt (i',m') ->
65
	 let path = sprintf "inst ## _%s" i' in
66
	 fprintf fmt "%a"
67
	   (print_static_declare_instance attr) (path,m')
68
       )) m.minstances
69

  
70
      
71
let print_static_link_instance fmt (i, (m, _)) =
72
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
73

  
74
(* Allocation of a node struct:
75
   - if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct)
76
*)
77
let print_static_link_macro fmt m =
78
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
79
  fprintf fmt "@[<v>@[<v 2>#define %a(inst) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
80
    pp_machine_static_link_name m.mname.node_id
81
    (Utils.fprintf_list ~sep:";\\@,"
82
       (fun fmt v ->
83
	 fprintf fmt "inst._reg.%s = (%a*) &%s"
84
	   v.var_id
85
           (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v
86
	   v.var_id
87
       )) array_mem
88
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
89
    (Utils.fprintf_list ~sep:";\\@,"
90
       (fun fmt (i',m') ->
91
	 let path = sprintf "inst ## _%s" i' in
92
	 fprintf fmt "%a;\\@,inst.%s = &%s"
93
	   print_static_link_instance (path,m')
94
	   i'
95
	   path
96
       )) m.minstances
97
      
98
let print_static_alloc_macro fmt m =
99
  fprintf fmt "@[<v>@[<v 2>#define %a(attr,%a%tinst)\\@,%a(attr,%a%tinst);\\@,%a(inst);@]@,@]@."
100
    pp_machine_static_alloc_name m.mname.node_id
101
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
102
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
103
    pp_machine_static_declare_name m.mname.node_id
104
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
105
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
106
    pp_machine_static_link_name m.mname.node_id
107

  
108
 
109
let print_machine_decl fmt m =
110
  !print_machine_decl_prefix fmt m;
111
  if fst (get_stateless_status m) then
112
    begin
113
      fprintf fmt "extern %a;@.@."
114
	print_stateless_prototype
115
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
116
    end
117
  else
118
    begin
119
      (* Static allocation *)
120
      if !Options.static_mem
121
      then (
122
	fprintf fmt "%a@.%a@.%a@."
123
	  print_static_declare_macro m
124
	  print_static_link_macro m
125
	  print_static_alloc_macro m
126
      )
127
      else ( 
128
        (* Dynamic allocation *)
129
	fprintf fmt "extern %a;@.@."
130
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
131
      );
132
      let self = mk_self m in
133
      fprintf fmt "extern %a;@.@."
134
	(print_reset_prototype self) (m.mname.node_id, m.mstatic);
135

  
136
      fprintf fmt "extern %a;@.@."
137
	(print_step_prototype self)
138
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
139
    end
140

  
141
let print_const_decl fmt cdecl =
142
  fprintf fmt "extern %a;@." 
143
    (pp_c_type cdecl.const_id) cdecl.const_type
144

  
145
(********************************************************************************************)
146
(*                      Struct/TypeDef Printing functions                                   *)
147
(********************************************************************************************)
148

  
149

  
150
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
151
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
152
and pp_c_type_decl filename cpt var fmt tdecl =
153
  match tdecl with
154
  | Tydec_any           -> assert false
155
  | Tydec_int           -> fprintf fmt "int %s" var
156
  | Tydec_real          -> fprintf fmt "double %s" var
157
  | Tydec_float         -> fprintf fmt "float %s" var
158
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
159
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
160
  | Tydec_const c       -> fprintf fmt "%s %s" c var
161
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
162
  | Tydec_enum tl ->
163
    begin
164
      incr cpt;
165
      fprintf fmt "enum _enum_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
166
    end
167
  | Tydec_struct fl ->
168
    begin
169
      incr cpt;
170
      fprintf fmt "struct _struct_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var
171
    end
172

  
173
let print_type_definitions fmt filename =
174
  let cpt_type = ref 0 in
175
  Hashtbl.iter (fun typ def ->
176
    match typ with
177
    | Tydec_const var ->
178
      fprintf fmt "typedef %a;@.@."
179
	(pp_c_type_decl filename cpt_type var) def
180
    | _        -> ()) type_table
181

  
182
(********************************************************************************************)
183
(*                         MAIN Header Printing functions                                   *)
184
(********************************************************************************************)
185

  
186
let print_header header_fmt basename prog machines =
187
  (* Include once: start *)
188
  let baseNAME = String.uppercase basename in
189
  let baseNAME = Str.global_replace (Str.regexp "\\.\\|\\ ") "_" baseNAME in
190
  (* Print the svn version number and the supported C standard (C90 or C99) *)
191
  print_version header_fmt;
192
  fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
193
  pp_print_newline header_fmt ();
194
  fprintf header_fmt "/* Imports standard library */@.";
195
  (* imports standard library definitions (arrow) *)
196
  print_import_standard header_fmt;
197
  pp_print_newline header_fmt ();
198
  fprintf header_fmt "/* Types definitions */@.";
199
  (* Print the type definitions from the type table *)
200
  print_type_definitions header_fmt basename;
201
  pp_print_newline header_fmt ();
202
  (* Print the global constant declarations. *)
203
  fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
204
  List.iter (fun c -> print_const_decl header_fmt c) (get_consts prog);
205
  pp_print_newline header_fmt ();
206
  (* Print the struct declarations of all machines. *)
207
  fprintf header_fmt "/* Struct declarations */@.";
208
  List.iter (print_machine_struct header_fmt) machines;
209
  pp_print_newline header_fmt ();
210
  (* Print the prototypes of all machines *)
211
  fprintf header_fmt "/* Nodes declarations */@.";
212
  List.iter (print_machine_decl header_fmt) machines;
213
  pp_print_newline header_fmt ();
214
  (* Include once: end *)
215
  fprintf header_fmt "#endif@.";
216
  pp_print_newline header_fmt ()
217

  
218
(* Local Variables: *)
219
(* compile-command:"make -C ../../.." *)
220
(* End: *)
src/backends/C/c_backend_main.ml
90 90

  
91 91

  
92 92
(* Local Variables: *)
93
(* compile-command:"make -C .." *)
93
(* compile-command:"make -C ../../.." *)
94 94
(* End: *)
src/backends/C/c_backend_makefile.ml
1
open Format
2
open Corelang
3

  
4
let header_has_code header =
5
  List.exists 
6
    (fun top -> 
7
      match top.top_decl_desc with
8
      | Consts _ -> true 
9
      | ImportedNode nd -> nd.nodei_in_lib = None
10
      | _ -> false
11
    )
12
    header
13

  
14
let header_libs header =
15
  List.fold_left (fun accu top ->
16
    match top.top_decl_desc with
17
      | ImportedNode nd -> (match nd.nodei_in_lib with 
18
	| None -> accu 
19
	| Some lib -> Utils.list_union [lib] accu)
20
      | _ -> accu 
21
  ) [] header 
22
    
23
let print_makefile basename nodename dependencies fmt =
24
  let compiled_dependencies = 
25
    List.filter (fun (_, _, header) -> header_has_code header) dependencies
26
  in
27
  let lib_dependencies = 
28
    List.fold_left 
29
      (fun accu (_, _, header) -> Utils.list_union (header_libs header) accu) [] dependencies 
30
  in
31
  fprintf fmt "GCC=gcc@.";
32
  fprintf fmt "LUSTREC=%s@." Sys.executable_name;
33
  fprintf fmt "LUSTREC_BASE=%s@." (Filename.dirname (Filename.dirname Sys.executable_name));
34
  fprintf fmt "INC=${LUSTREC_BASE}/include/lustrec@.";
35
  fprintf fmt "@.";
36
  fprintf fmt "%s_%s:@." basename nodename;
37
  fprintf fmt "\t${GCC} -I${INC} -I. -c %s.c@." basename;    
38
  List.iter (fun s -> (* Format.eprintf "Adding dependency: %s@." s;  *)
39
    fprintf fmt "\t${GCC} -I${INC} -c %s@." s)
40
    (("${INC}/io_frontend.c"):: (* IO functions when a main function is computed *)
41
	(List.map 
42
	   (fun (s, local, _) -> 
43
	     (if local then s else Version.prefix ^ "/include/lustrec/" ^ s) ^ ".c")
44
	   compiled_dependencies));    
45
  fprintf fmt "\t${GCC} -o %s_%s io_frontend.o %a %s.o %a@." basename nodename 
46
    (Utils.fprintf_list ~sep:" " (fun fmt (s, _, _) -> Format.fprintf fmt "%s.o" s)) compiled_dependencies 
47
    basename
48
    (Utils.fprintf_list ~sep:" " (fun fmt lib -> fprintf fmt "-l%s" lib)) lib_dependencies
49
    ;
50
 fprintf fmt "@.";
51
 fprintf fmt "clean:@.";
52
 fprintf fmt "\t\\rm -f *.o %s_%s@." basename nodename
53

  
54

  
55
(* Local Variables: *)
56
(* compile-command:"make -C ../../.." *)
57
(* End: *)
src/backends/C/c_backend_spec.ml
98 98
  )
99 99

  
100 100
(* Local Variables: *)
101
(* compile-command:"make -C .." *)
101
(* compile-command:"make -C ../../.." *)
102 102
(* End: *)
src/backends/C/c_backend_src.ml
1
open Format
2
open LustreSpec
3
open Corelang
4
open Machine_code
5
open C_backend_common
6

  
7
(********************************************************************************************)
8
(*                    Instruction Printing functions                                        *)
9
(********************************************************************************************)
10

  
11
(* Computes the depth to which multi-dimension array assignments should be expanded.
12
   It equals the maximum number of nested static array constructions accessible from root [v].
13
*)
14
let rec expansion_depth v =
15
 match v with
16
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
17
 | Cst _
18
 | LocalVar _
19
 | StateVar _  -> 0
20
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
21
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
22
 | Access (v, i) -> max 0 (expansion_depth v - 1)
23
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
24

  
25
type loop_index = LVar of ident | LInt of int ref
26

  
27
(* Computes the list of nested loop variables together with their dimension bounds.
28
   - LInt r stands for loop expansion (no loop variable, but int loop index)
29
   - LVar v stands for loop variable v
30
*)
31
let rec mk_loop_variables m ty depth =
32
 match (Types.repr ty).Types.tdesc, depth with
33
 | Types.Tarray (d, ty'), 0       ->
34
   let v = mk_loop_var m () in
35
   (d, LVar v) :: mk_loop_variables m ty' 0
36
 | Types.Tarray (d, ty'), _       ->
37
   let r = ref (-1) in
38
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
39
 | _                    , 0       -> []
40
 | _                              -> assert false
41

  
42
let reorder_loop_variables loop_vars =
43
  let (int_loops, var_loops) = 
44
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
45
  in
46
  var_loops @ int_loops
47
    
48
(* Prints a one loop variable suffix for arrays *)
49
let pp_loop_var fmt lv =
50
 match snd lv with
51
 | LVar v -> fprintf fmt "[%s]" v
52
 | LInt r -> fprintf fmt "[%d]" !r
53

  
54
(* Prints a suffix of loop variables for arrays *)
55
let pp_suffix fmt loop_vars =
56
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
57

  
58
(* Prints a [value] indexed by the suffix list [loop_vars] *)
59
let rec pp_value_suffix self loop_vars pp_value fmt value =
60
 match loop_vars, value with
61
 | (_, LInt r) :: q, Array vl     ->
62
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
63
 | _           :: q, Power (v, n) ->
64
   pp_value_suffix self loop_vars pp_value fmt v
65
 | _               , Fun (n, vl)  ->
66
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
67
 | _               , _            ->
68
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
69
   pp_c_val self pp_var_suffix fmt value
70

  
71
(* type_directed assignment: array vs. statically sized type
72
   - [var_type]: type of variable to be assigned
73
   - [var_name]: name of variable to be assigned
74
   - [value]: assigned value
75
   - [pp_var]: printer for variables
76
*)
77
let pp_assign m self pp_var fmt var_type var_name value =
78
  let depth = expansion_depth value in
79
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
80
  let loop_vars = mk_loop_variables m var_type depth in
81
  let reordered_loop_vars = reorder_loop_variables loop_vars in
82
  let rec aux fmt vars =
83
    match vars with
84
    | [] ->
85
      fprintf fmt "%a = %a;" 
86
	(pp_value_suffix self loop_vars pp_var) var_name
87
	(pp_value_suffix self loop_vars pp_var) value
88
    | (d, LVar i) :: q ->
89
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
90
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
91
	i i i Dimension.pp_dimension d i
92
	aux q
93
    | (d, LInt r) :: q ->
94
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
95
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
96
      fprintf fmt "@[<v 2>{@,%a@]@,}"
97
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
98
  in
99
  begin
100
    reset_loop_counter ();
101
    (*reset_addr_counter ();*)
102
    aux fmt reordered_loop_vars
103
  end
104

  
105
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
106
 try (* stateful node instance *)
107
   let (n,_) = List.assoc i m.minstances in
108
   fprintf fmt "%a (%a%t%a%t%s->%s);"
109
     pp_machine_step_name (node_name n)
110
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
111
     (Utils.pp_final_char_if_non_empty ", " inputs) 
112
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
113
     (Utils.pp_final_char_if_non_empty ", " outputs)
114
     self
115
     i
116
 with Not_found -> (* stateless node instance *)
117
   let (n,_) = List.assoc i m.mcalls in
118
   fprintf fmt "%a (%a%t%a);"
119
     pp_machine_step_name (node_name n)
120
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
121
     (Utils.pp_final_char_if_non_empty ", " inputs) 
122
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
123

  
124
let pp_machine_reset (m: machine_t) self fmt inst =
125
  let (node, static) = List.assoc inst m.minstances in
126
  fprintf fmt "%a(%a%t%s->%s);"
127
    pp_machine_reset_name (node_name node)
128
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
129
    (Utils.pp_final_char_if_non_empty ", " static)
130
    self inst
131

  
132
let has_c_prototype funname dependencies =
133
  let imported_node_opt = (* We select the last imported node with the name funname.
134
			       The order of evaluation of dependencies should be
135
			       compatible with overloading. (Not checked yet) *) 
136
      List.fold_left
137
	(fun res (_, _, decls) -> 
138
	  match res with
139
	  | Some _ -> res
140
	  | None -> 
141
	    let matched = fun t -> match t.top_decl_desc with 
142
	      | ImportedNode nd -> nd.nodei_id = funname 
143
	      | _ -> false
144
	    in
145
	    if List.exists matched decls then (
146
	      match (List.find matched decls).top_decl_desc with
147
	      | ImportedNode nd -> Some nd
148
	      | _ -> assert false
149
	    )
150
	    else
151
	      None
152
	) None dependencies in
153
    match imported_node_opt with
154
    | None -> false
155
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
156

  
157
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
158
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
159
    (pp_c_val self (pp_c_var_read m)) c
160
    (Utils.pp_newline_if_non_empty tl)
161
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
162
    (Utils.pp_newline_if_non_empty el)
163
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
164

  
165
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
166
  match instr with 
167
  | MReset i ->
168
    pp_machine_reset m self fmt i
169
  | MLocalAssign (i,v) ->
170
    pp_assign
171
      m self (pp_c_var_read m) fmt
172
      i.var_type (LocalVar i) v
173
  | MStateAssign (i,v) ->
174
    pp_assign
175
      m self (pp_c_var_read m) fmt
176
      i.var_type (StateVar i) v
177
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
178
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
179
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
180
    fprintf fmt "%a = %s(%a);" 
181
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
182
      i
183
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
184
  | MStep (il, i, vl) ->
185
    pp_instance_call m self fmt i vl il
186
  | MBranch (g,hl) ->
187
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
188
    then (* boolean case, needs special treatment in C because truth value is not unique *)
189
	 (* may disappear if we optimize code by replacing last branch test with default *)
190
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
191
      let el = try List.assoc tag_false hl with Not_found -> [] in
192
      pp_conditional dependencies m self fmt g tl el
193
    else (* enum type case *)
194
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
195
	(pp_c_val self (pp_c_var_read m)) g
196
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
197

  
198
and pp_machine_branch dependencies m self fmt (t, h) =
199
  fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
200

  
201

  
202
(********************************************************************************************)
203
(*                         C file Printing functions                                        *)
204
(********************************************************************************************)
205

  
206
let print_const_def fmt cdecl =
207
  fprintf fmt "%a = %a;@." 
208
    (pp_c_type cdecl.const_id) cdecl.const_type
209
    pp_c_const cdecl.const_value 
210

  
211

  
212
let print_alloc_instance fmt (i, (m, static)) =
213
  fprintf fmt "_alloc->%s = %a (%a);@,"
214
    i
215
    pp_machine_alloc_name (node_name m)
216
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
217

  
218
let print_alloc_array fmt vdecl =
219
  let base_type = Types.array_base_type vdecl.var_type in
220
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
221
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
222
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
223
    vdecl.var_id
224
    (pp_c_type "") base_type
225
    Dimension.pp_dimension size_type
226
    (pp_c_type "") base_type
227
    vdecl.var_id
228

  
229
let print_alloc_code fmt m =
230
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
231
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
232
    pp_machine_memtype_name m.mname.node_id
233
    pp_machine_memtype_name m.mname.node_id
234
    pp_machine_memtype_name m.mname.node_id
235
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
236
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
237

  
238
let print_stateless_code dependencies fmt m =
239
  let self = "__ERROR__" in
240
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
241
  then
242
    (* C99 code *)
243
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
244
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
245
      (* locals *)
246
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
247
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
248
      (* check assertions *)
249
      (pp_c_checks self) m
250
      (* instrs *)
251
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
252
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
253
      (fun fmt -> fprintf fmt "return;")
254
  else
255
    (* C90 code *)
256
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
257
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
258
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
259
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
260
      (* locals *)
261
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
262
      (Utils.pp_final_char_if_non_empty ";" base_locals)
263
      (* check assertions *)
264
      (pp_c_checks self) m
265
      (* instrs *)
266
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
267
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
268
      (fun fmt -> fprintf fmt "return;")
269

  
270
let print_reset_code dependencies fmt m self =
271
  fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
272
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
273
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
274
    (Utils.pp_newline_if_non_empty m.minit)
275

  
276
let print_step_code dependencies fmt m self =
277
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
278
  then
279
    (* C99 code *)
280
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
281
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
282
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
283
      (* locals *)
284
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
285
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
286
      (* array mems *)
287
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
288
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
289
      (* check assertions *)
290
      (pp_c_checks self) m
291
      (* instrs *)
292
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
293
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
294
      (fun fmt -> fprintf fmt "return;")
295
  else
296
    (* C90 code *)
297
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
298
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
299
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
300
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
301
      (* locals *)
302
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
303
      (Utils.pp_final_char_if_non_empty ";" base_locals)
304
      (* check assertions *)
305
      (pp_c_checks self) m
306
      (* instrs *)
307
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
308
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
309
      (fun fmt -> fprintf fmt "return;")
310

  
311

  
312
(********************************************************************************************)
313
(*                     MAIN C file Printing functions                                       *)
314
(********************************************************************************************)
315

  
316
let print_machine dependencies fmt m =
317
  if fst (get_stateless_status m) then
318
    begin
319
      (* Step function *)
320
      print_stateless_code dependencies fmt m
321
    end
322
  else
323
    begin
324
      (* Alloc function, only if non static mode *)
325
      if (not !Options.static_mem) then  
326
	(
327
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
328
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
329
	    print_alloc_code m;
330
	);
331
      let self = mk_self m in
332
      (* Reset function *)
333
      print_reset_code dependencies fmt m self;
334
      (* Step function *)
335
      print_step_code dependencies fmt m self
336
    end
337

  
338

  
339

  
340

  
341
let print_c source_fmt basename prog machines dependencies =
342

  
343
  (* If a main node is identified, generate a main function for it *)
344
  let main_include, main_print =
345
    match !Options.main_node with
346
      | "" -> (fun _ -> ()), (fun _ -> ())
347
      | main_node -> (
348
	match Machine_code.get_machine_opt main_node machines with
349
	| None -> (
350
	  eprintf "Unable to find a main node named %s@.@?" main_node; 
351
	  (fun _ -> ()), (fun _ -> ())
352
	)
353
	| Some m -> 
354
	  C_backend_main.print_main_header, C_backend_main.print_main_fun machines m
355
      )
356
  in
357
  main_include source_fmt;
358
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
359
  (* Print the svn version number and the supported C standard (C90 or C99) *)
360
  print_version source_fmt;
361
  (* Print the prototype of imported nodes *)
362
  fprintf source_fmt "/* Imported nodes declarations */@.";
363
  fprintf source_fmt "@[<v>";
364
  List.iter (print_import_prototype source_fmt) dependencies;
365
  fprintf source_fmt "@]@.";
366
  (* Print consts *)
367
  fprintf source_fmt "/* Global constants (definitions) */@.";
368
  List.iter (fun c -> print_const_def source_fmt c) (get_consts prog);
369
  pp_print_newline source_fmt ();
370
  (* Print nodes one by one (in the previous order) *)
371
  List.iter (print_machine dependencies source_fmt) machines;
372
  main_print source_fmt
373

  
374

  
375
(* Local Variables: *)
376
(* compile-command:"make -C ../../.." *)
377
(* End: *)
src/scheduling.ml
112 112
      try
113 113
	Hashtbl.find eq_equiv v1 = Hashtbl.find eq_equiv v2
114 114
      with Not_found -> false in
115

  
115 116
    let n', g = global_dependency n in
116 117
    Log.report ~level:5 
117 118
      (fun fmt -> 

Also available in: Unified diff