Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_header.ml @ 66359a5e

History | View | Annotate | Download (17.3 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

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

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

    
22

    
23
module type MODIFIERS_HDR =
24
sig
25
  val print_machine_decl_prefix: Format.formatter -> Machine_code.machine_t -> unit
26
end
27

    
28
module EmptyMod =
29
struct
30
  let print_machine_decl_prefix = fun fmt x -> ()
31
end
32

    
33
module Main = functor (Mod: MODIFIERS_HDR) -> 
34
struct
35

    
36
let print_import_standard fmt =
37
  begin
38
    (* if Machine_types.has_machine_type () then *)
39
    (*   begin *)
40
	fprintf fmt "#include <stdint.h>@.";
41
      (* end; *)
42
    if !Options.mpfr then
43
      begin
44
	fprintf fmt "#include <mpfr.h>@."
45
      end;
46
    if !Options.cpp then
47
      fprintf fmt "#include \"%s/arrow.hpp\"@.@." arrow_top_decl.top_decl_owner 
48
    else
49
      fprintf fmt "#include \"%s/arrow.h\"@.@." arrow_top_decl.top_decl_owner 
50
	
51
  end
52

    
53
let rec print_static_val pp_var fmt v =
54
  match v.value_desc with
55
  | Cst c         -> pp_c_const fmt c
56
  | LocalVar v    -> pp_var fmt v
57
  | Fun (n, vl)   -> Basic_library.pp_c n (print_static_val pp_var) fmt vl
58
  | _             -> (Format.eprintf "Internal error: C_backend_header.print_static_val"; assert false)
59

    
60
let print_constant_decl (m, attr, inst) pp_var fmt v =
61
  Format.fprintf fmt "%s %a = %a"
62
    attr
63
    (pp_c_type (Format.sprintf "%s ## %s" inst v.var_id)) v.var_type
64
    (print_static_val pp_var) (Machine_code.get_const_assign m v)
65

    
66
let print_static_constant_decl (m, attr, inst) fmt const_locals =
67
  let pp_var fmt v =
68
    if List.mem v const_locals
69
    then
70
      Format.fprintf fmt "%s ## %s" inst v.var_id
71
    else 
72
      Format.fprintf fmt "%s" v.var_id in
73
  Format.fprintf fmt "%a%t"
74
    (Utils.fprintf_list ~sep:";\\@," (print_constant_decl (m, attr, inst) pp_var)) const_locals
75
    (Utils.pp_final_char_if_non_empty ";\\@," const_locals)
76

    
77
let print_static_declare_instance (m, attr, inst) const_locals fmt (i, (n, static)) =
78
  let pp_var fmt v =
79
    if List.mem v const_locals
80
    then
81
      Format.fprintf fmt "%s ## %s" inst v.var_id
82
    else 
83
      Format.fprintf fmt "%s" v.var_id in
84
  let values = List.map (Machine_code.value_of_dimension m) static in
85
  fprintf fmt "%a(%s, %a%t%s)"
86
    pp_machine_static_declare_name (node_name n)
87
    attr
88
    (Utils.fprintf_list ~sep:", " (print_static_val pp_var)) values
89
    (Utils.pp_final_char_if_non_empty ", " static)
90
    i
91

    
92
let print_static_declare_macro fmt (m, attr, inst) =
93
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
94
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
95
  fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%a%s %a %s;\\@,%a%t%a;@,@]"
96
    pp_machine_static_declare_name m.mname.node_id
97
    attr
98
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
99
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
100
    inst
101
    (* constants *)
102
    (print_static_constant_decl (m, attr, inst)) const_locals
103
    attr
104
    pp_machine_memtype_name m.mname.node_id
105
    inst
106
    (Utils.fprintf_list ~sep:";\\@," (pp_c_decl_local_var m)) array_mem
107
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
108
    (Utils.fprintf_list ~sep:";\\@,"
109
       (fun fmt (i',m') ->
110
	 let path = sprintf "%s ## _%s" inst i' in
111
	 fprintf fmt "%a"
112
	   (print_static_declare_instance (m, attr, inst) const_locals) (path, m')
113
       )) m.minstances
114

    
115
      
116
let print_static_link_instance fmt (i, (m, _)) =
117
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
118

    
119
(* Allocation of a node struct:
120
   - if node memory is an array/matrix/etc, we cast it to a pointer (see pp_registers_struct)
121
*)
122
let print_static_link_macro fmt (m, attr, inst) =
123
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
124
  fprintf fmt "@[<v>@[<v 2>#define %a(%s) do {\\@,%a%t%a;\\@]@,} while (0)@.@]"
125
    pp_machine_static_link_name m.mname.node_id
126
    inst
127
    (Utils.fprintf_list ~sep:";\\@,"
128
       (fun fmt v ->
129
	 fprintf fmt "%s._reg.%s = (%a*) &%s"
130
	   inst
131
	   v.var_id
132
           (fun fmt v -> pp_c_type "" fmt (Types.array_base_type v.var_type)) v
133
	   v.var_id
134
       )) array_mem
135
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
136
    (Utils.fprintf_list ~sep:";\\@,"
137
       (fun fmt (i',m') ->
138
	 let path = sprintf "%s ## _%s" inst i' in
139
	 fprintf fmt "%a;\\@,%s.%s = &%s"
140
	   print_static_link_instance (path,m')
141
	   inst
142
	   i'
143
	   path
144
       )) m.minstances
145

    
146
let print_static_alloc_macro fmt (m, attr, inst) =
147
  fprintf fmt "@[<v>@[<v 2>#define %a(%s, %a%t%s)\\@,%a(%s, %a%t%s);\\@,%a(%s);@]@,@]@."
148
    pp_machine_static_alloc_name m.mname.node_id
149
    attr
150
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
151
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
152
    inst
153
    pp_machine_static_declare_name m.mname.node_id
154
    attr
155
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
156
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
157
    inst
158
    pp_machine_static_link_name m.mname.node_id
159
    inst
160

    
161
let print_machine_decl fmt m =
162
  begin
163
    Mod.print_machine_decl_prefix fmt m;
164
    if fst (get_stateless_status m) then
165
      begin
166
	fprintf fmt "extern %a;@.@."
167
	  print_stateless_prototype
168
	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
169
      end
170
    else
171
      begin
172
        (* Static allocation *)
173
	if !Options.static_mem
174
	then
175
	  begin
176
	    let inst = mk_instance m in
177
	    let attr = mk_attribute m in
178
	    fprintf fmt "%a@.%a@.%a@."
179
	      print_static_declare_macro (m, attr, inst)
180
	      print_static_link_macro (m, attr, inst)
181
	      print_static_alloc_macro (m, attr, inst)
182
	  end
183
	else
184
	  begin 
185
            (* Dynamic allocation *)
186
	    fprintf fmt "extern %a;@.@."
187
	      print_alloc_prototype (m.mname.node_id, m.mstatic);
188

    
189
	    fprintf fmt "extern %a;@.@."
190
	      print_dealloc_prototype m.mname.node_id;
191
	  end;
192
	let self = mk_self m in
193
	fprintf fmt "extern %a;@.@."
194
	  (print_reset_prototype self) (m.mname.node_id, m.mstatic);
195

    
196
	fprintf fmt "extern %a;@.@."
197
	  (print_step_prototype self)
198
	  (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs);
199
	
200
	if !Options.mpfr then
201
	  begin
202
	    fprintf fmt "extern %a;@.@."
203
	      (print_init_prototype self) (m.mname.node_id, m.mstatic);
204

    
205
	    fprintf fmt "extern %a;@.@."
206
	      (print_clear_prototype self) (m.mname.node_id, m.mstatic);
207
	  end
208
      end
209
  end
210

    
211
let print_machine_alloc_decl fmt m =
212
  Mod.print_machine_decl_prefix fmt m;
213
  if fst (get_stateless_status m) then
214
    begin
215
    end
216
  else
217
    begin
218
      if !Options.static_mem
219
      then
220
	begin
221
	  (* Static allocation *)
222
	  let inst = mk_instance m in
223
	  let attr = mk_attribute m in
224
	  fprintf fmt "%a@.%a@.%a@."
225
		  print_static_declare_macro (m, attr, inst)
226
		  print_static_link_macro (m, attr, inst)
227
		  print_static_alloc_macro (m, attr, inst)
228
	end
229
      else
230
	begin 
231
          (* Dynamic allocation *)
232
	  fprintf fmt "extern %a;@.@."
233
	    print_alloc_prototype (m.mname.node_id, m.mstatic);
234

    
235
	  fprintf fmt "extern %a;@.@."
236
	    print_dealloc_prototype m.mname.node_id
237
	end
238
    end
239

    
240
let print_machine_decl_from_header fmt inode =
241
  (*Mod.print_machine_decl_prefix fmt m;*)
242
  if inode.nodei_prototype = Some "C" then
243
    if inode.nodei_stateless then
244
      begin
245
	fprintf fmt "extern %a;@.@."
246
	  print_stateless_C_prototype
247
	  (inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
248
      end
249
    else (Format.eprintf "internal error: print_machine_decl_from_header"; assert false)
250
  else
251
    if inode.nodei_stateless then
252
    begin
253
      fprintf fmt "extern %a;@.@."
254
	print_stateless_prototype 
255
	(inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
256
    end
257
    else 
258
      begin
259
	let static_inputs = List.filter (fun v -> v.var_dec_const) inode.nodei_inputs in
260
	let used name =
261
	  (List.exists (fun v -> v.var_id = name) inode.nodei_inputs)
262
	  || (List.exists (fun v -> v.var_id = name) inode.nodei_outputs) in
263
	let self = mk_new_name used "self" in
264
	fprintf fmt "extern %a;@.@."
265
	  (print_reset_prototype self) (inode.nodei_id, static_inputs);
266

    
267
	fprintf fmt "extern %a;@.@."
268
	  (print_init_prototype self) (inode.nodei_id, static_inputs);
269

    
270
	fprintf fmt "extern %a;@.@."
271
	  (print_clear_prototype self) (inode.nodei_id, static_inputs);
272

    
273
	fprintf fmt "extern %a;@.@."
274
	  (print_step_prototype self)
275
	  (inode.nodei_id, inode.nodei_inputs, inode.nodei_outputs)
276
      end
277

    
278
let print_const_decl fmt cdecl =
279
  if !Options.mpfr &&  Types.is_real_type (Types.array_base_type cdecl.const_type)
280
  then
281
    fprintf fmt "extern %a;@." 
282
      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 
283
  else
284
    fprintf fmt "extern %a;@." 
285
      (pp_c_type cdecl.const_id) cdecl.const_type
286

    
287
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
288
   fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
289
and pp_c_type_decl filename cpt var fmt tdecl =
290
  match tdecl with
291
  | Tydec_any           -> assert false
292
  | Tydec_int           -> fprintf fmt "int %s" var
293
  | Tydec_real when !Options.mpfr
294
                        -> fprintf fmt "%s %s" Mpfr.mpfr_t var
295
  | Tydec_real          -> fprintf fmt "double %s" var
296
  (* | Tydec_float         -> fprintf fmt "float %s" var *)
297
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
298
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
299
  | Tydec_const c       -> fprintf fmt "%s %s" c var
300
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
301
  | Tydec_enum tl ->
302
    begin
303
      incr cpt;
304
      fprintf fmt "enum _enum_%s_%d { %a } %s" (protect_filename filename) !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
305
    end
306
  | Tydec_struct fl ->
307
    begin
308
      incr cpt;
309
      fprintf fmt "struct _struct_%s_%d { %a } %s" (protect_filename filename) !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var
310
    end
311

    
312
let print_type_definitions fmt filename =
313
  let cpt_type = ref 0 in
314
  Hashtbl.iter (fun typ decl ->
315
		match typ with
316
		| Tydec_const var ->
317
		   (match decl.top_decl_desc with
318
		    | TypeDef tdef ->
319
		       fprintf fmt "typedef %a;@.@."
320
			       (pp_c_type_decl filename cpt_type var) tdef.tydef_desc
321
		    | _ -> assert false)
322
		| _        -> ()) type_table
323

    
324
let reset_type_definitions, print_type_definition_from_header =
325
  let cpt_type =ref 0 in
326
  ((fun () -> cpt_type := 0),
327
   (fun fmt typ filename ->
328
    fprintf fmt "typedef %a;@.@."
329
	(pp_c_type_decl filename cpt_type typ.tydef_id) typ.tydef_desc))
330

    
331
(********************************************************************************************)
332
(*                         MAIN Header Printing functions                                   *)
333
(********************************************************************************************)
334
let print_header header_fmt basename prog machines dependencies =
335
  (* Include once: start *)
336
  let baseNAME = file_to_module_name basename in
337
  begin
338
    (* Print the version number and the supported C standard (C90 or C99) *)
339
    print_version header_fmt;
340
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
341
    pp_print_newline header_fmt ();
342
    fprintf header_fmt "/* Imports standard library */@.";
343
    (* imports standard library definitions (arrow) *)
344
    print_import_standard header_fmt;
345
    pp_print_newline header_fmt ();
346
    (* imports dependencies *)
347
    fprintf header_fmt "/* Import dependencies */@.";
348
    fprintf header_fmt "@[<v>";
349
    List.iter (print_import_prototype header_fmt) dependencies;
350
    fprintf header_fmt "@]@.";
351
    fprintf header_fmt "/* Types definitions */@.";
352
    (* Print the type definitions from the type table *)
353
    print_type_definitions header_fmt basename;
354
    pp_print_newline header_fmt ();
355
    (* Print the global constant declarations. *)
356
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
357
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) (get_consts prog);
358
    pp_print_newline header_fmt ();
359
    if !Options.mpfr then
360
      begin
361
	fprintf header_fmt "/* Global initialization declaration */@.";
362
	fprintf header_fmt "extern %a;@.@."
363
	  print_global_init_prototype baseNAME;
364
	
365
	fprintf header_fmt "/* Global clear declaration */@.";
366
	fprintf header_fmt "extern %a;@.@."
367
	  print_global_clear_prototype baseNAME;
368
      end;
369
    (* Print the struct declarations of all machines. *)
370
    fprintf header_fmt "/* Structs declarations */@.";
371
    List.iter (print_machine_struct header_fmt) machines;
372
    pp_print_newline header_fmt ();
373
    (* Print the prototypes of all machines *)
374
    fprintf header_fmt "/* Nodes declarations */@.";
375
    List.iter (print_machine_decl header_fmt) machines;
376
    pp_print_newline header_fmt ();
377
    (* Include once: end *)
378
    fprintf header_fmt "#endif@.";
379
    pp_print_newline header_fmt ()
380
  end
381

    
382
let print_alloc_header header_fmt basename prog machines dependencies =
383
  (* Include once: start *)
384
  let baseNAME = file_to_module_name basename in
385
  begin
386
    (* Print the svn version number and the supported C standard (C90 or C99) *)
387
    print_version header_fmt;
388
    fprintf header_fmt "#ifndef _%s_alloc@.#define _%s_alloc@." baseNAME baseNAME;
389
    pp_print_newline header_fmt ();
390
    (* Import the header *)
391
    fprintf header_fmt "/* Import header from %s */@." basename;
392
    fprintf header_fmt "@[<v>";
393
    print_import_prototype header_fmt (Dep (true, basename, [], true (* assuming it is staful *) ));
394
    fprintf header_fmt "@]@.";
395
    fprintf header_fmt "/* Import dependencies */@.";
396
    fprintf header_fmt "@[<v>";
397
    List.iter (print_import_alloc_prototype header_fmt) dependencies;
398
    fprintf header_fmt "@]@.";
399
    (* Print the struct definitions of all machines. *)
400
    fprintf header_fmt "/* Struct definitions */@.";
401
    List.iter (print_machine_struct header_fmt) machines;
402
    pp_print_newline header_fmt ();
403
    (* Print the prototypes of all machines *)
404
    fprintf header_fmt "/* Node allocation function/macro prototypes */@.";
405
    List.iter (print_machine_alloc_decl header_fmt) machines;
406
    pp_print_newline header_fmt ();
407
    (* Include once: end *)
408
    fprintf header_fmt "#endif@.";
409
    pp_print_newline header_fmt ()
410
  end
411

    
412
(* Function called when compiling a lusi file and generating the associated C
413
   header. *)
414
let print_header_from_header header_fmt basename header =
415
  (* Include once: start *)
416
  let baseNAME = file_to_module_name basename in
417
  let types = get_typedefs header in
418
  let consts = get_consts header in
419
  let nodes = get_imported_nodes header in
420
  let dependencies = get_dependencies header in
421
  begin
422
    (* Print the version number and the supported C standard (C90 or C99) *)
423
    print_version header_fmt;
424
    fprintf header_fmt "#ifndef _%s@.#define _%s@." baseNAME baseNAME;
425
    pp_print_newline header_fmt ();
426
    fprintf header_fmt "/* Imports standard library */@.";
427
    (* imports standard library definitions (arrow) *)
428
    print_import_standard header_fmt;
429
    pp_print_newline header_fmt ();
430
    (* imports dependencies *)
431
    fprintf header_fmt "/* Import dependencies */@.";
432
    fprintf header_fmt "@[<v>";
433
    List.iter
434
      (fun dep -> 
435
	let (local, s) = dependency_of_top dep in 
436
	print_import_prototype header_fmt (Dep (local, s, [], true (* assuming it is stateful *))))
437
      dependencies;
438
    fprintf header_fmt "@]@.";
439
    fprintf header_fmt "/* Types definitions */@.";
440
    (* Print the type definitions from the type table *)
441
    reset_type_definitions ();
442
    List.iter (fun typ -> print_type_definition_from_header header_fmt (typedef_of_top typ) basename) types;
443
    pp_print_newline header_fmt ();
444
    (* Print the global constant declarations. *)
445
    fprintf header_fmt "/* Global constant (declarations, definitions are in C file) */@.";
446
    List.iter (fun c -> print_const_decl header_fmt (const_of_top c)) consts;
447
    pp_print_newline header_fmt ();
448
    if !Options.mpfr then
449
      begin
450
	fprintf header_fmt "/* Global initialization declaration */@.";
451
	fprintf header_fmt "extern %a;@.@."
452
	  print_global_init_prototype baseNAME;
453
	
454
	fprintf header_fmt "/* Global clear declaration */@.";
455
	fprintf header_fmt "extern %a;@.@."
456
	  print_global_clear_prototype baseNAME;
457
      end;
458
    (* Print the struct declarations of all machines. *)
459
    fprintf header_fmt "/* Structs declarations */@.";
460
    List.iter (fun node -> print_machine_struct_from_header header_fmt (imported_node_of_top node)) nodes;
461
    pp_print_newline header_fmt ();
462
    (* Print the prototypes of all machines *)
463
    fprintf header_fmt "/* Nodes declarations */@.";
464
    List.iter (fun node -> print_machine_decl_from_header header_fmt (imported_node_of_top node)) nodes;
465
    pp_print_newline header_fmt ();
466
    (* Include once: end *)
467
    fprintf header_fmt "#endif@.";
468
    pp_print_newline header_fmt ()
469
  end
470

    
471
end
472
(* Local Variables: *)
473
(* compile-command:"make -C ../../.." *)
474
(* End: *)