Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_header.ml @ cefc3744

History | View | Annotate | Download (8.21 KB)

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

    
11

    
12
module type MODIFIERS_HDR =
13
sig
14
  val print_machine_decl_prefix: Format.formatter -> Machine_code.machine_t -> unit
15
end
16

    
17
module EmptyMod =
18
struct
19
  let print_machine_decl_prefix = fun fmt x -> ()
20
end
21

    
22
module Main = functor (Mod: MODIFIERS_HDR) -> 
23
struct
24

    
25
let print_import_standard fmt =
26
  fprintf fmt "#include \"%s/include/lustrec/arrow.h\"@.@." Version.prefix
27

    
28
    
29
let pp_registers_struct fmt m =
30
  if m.mmemory <> []
31
  then
32
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
33
      pp_machine_regtype_name m.mname.node_id
34
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
35
  else
36
    ()
37

    
38
let print_machine_struct fmt m =
39
  if fst (get_stateless_status m) then
40
    begin
41
    end
42
  else
43
    begin
44
      (* Define struct *)
45
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
46
	pp_machine_memtype_name m.mname.node_id
47
	pp_registers_struct m
48
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
49
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
50
    end
51

    
52
let print_static_declare_instance attr fmt (i, (m, static)) =
53
  fprintf fmt "%a(%s, %a%t%s)"
54
    pp_machine_static_declare_name (node_name m)
55
    attr
56
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
57
    (Utils.pp_final_char_if_non_empty ", " static)
58
    i
59

    
60
let print_static_declare_macro fmt m =
61
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
62
  let inst = mk_instance m in
63
  let attr = mk_attribute m in
64
  fprintf fmt "@[<v 2>#define %a(%s, %a%t%s)\\@,%s %a %s;\\@,%a%t%a;@,@]"
65
    pp_machine_static_declare_name m.mname.node_id
66
    attr
67
    (Utils.fprintf_list ~sep:", " (pp_c_var_read m)) m.mstatic
68
    (Utils.pp_final_char_if_non_empty ", " m.mstatic)
69
    inst
70
    attr
71
    pp_machine_memtype_name m.mname.node_id
72
    inst
73
    (Utils.fprintf_list ~sep:";\\@," pp_c_decl_local_var) array_mem
74
    (Utils.pp_final_char_if_non_empty ";\\@," array_mem)
75
    (Utils.fprintf_list ~sep:";\\@,"
76
       (fun fmt (i',m') ->
77
	 let path = sprintf "inst ## _%s" i' in
78
	 fprintf fmt "%a"
79
	   (print_static_declare_instance attr) (path,m')
80
       )) m.minstances
81

    
82
      
83
let print_static_link_instance fmt (i, (m, _)) =
84
 fprintf fmt "%a(%s)" pp_machine_static_link_name (node_name m) i
85

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

    
120
 
121
let print_machine_decl fmt m =
122
  Mod.print_machine_decl_prefix fmt m;
123
  if fst (get_stateless_status m) then
124
    begin
125
      fprintf fmt "extern %a;@.@."
126
	print_stateless_prototype
127
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
128
    end
129
  else
130
    begin
131
      (* Static allocation *)
132
      if !Options.static_mem
133
      then (
134
	fprintf fmt "%a@.%a@.%a@."
135
	  print_static_declare_macro m
136
	  print_static_link_macro m
137
	  print_static_alloc_macro m
138
      )
139
      else ( 
140
        (* Dynamic allocation *)
141
	fprintf fmt "extern %a;@.@."
142
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
143
      );
144
      let self = mk_self m in
145
      fprintf fmt "extern %a;@.@."
146
	(print_reset_prototype self) (m.mname.node_id, m.mstatic);
147

    
148
      fprintf fmt "extern %a;@.@."
149
	(print_step_prototype self)
150
	(m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
151
    end
152

    
153
let print_const_decl fmt cdecl =
154
  fprintf fmt "extern %a;@." 
155
    (pp_c_type cdecl.const_id) cdecl.const_type
156

    
157
(********************************************************************************************)
158
(*                      Struct/TypeDef Printing functions                                   *)
159
(********************************************************************************************)
160

    
161

    
162
let rec pp_c_struct_type_field filename cpt fmt (label, tdesc) =
163
  fprintf fmt "%a;" (pp_c_type_decl filename cpt label) tdesc
164
and pp_c_type_decl filename cpt var fmt tdecl =
165
  match tdecl with
166
  | Tydec_any           -> assert false
167
  | Tydec_int           -> fprintf fmt "int %s" var
168
  | Tydec_real          -> fprintf fmt "double %s" var
169
  | Tydec_float         -> fprintf fmt "float %s" var
170
  | Tydec_bool          -> fprintf fmt "_Bool %s" var
171
  | Tydec_clock ty      -> pp_c_type_decl filename cpt var fmt ty
172
  | Tydec_const c       -> fprintf fmt "%s %s" c var
173
  | Tydec_array (d, ty) -> fprintf fmt "%a[%a]" (pp_c_type_decl filename cpt var) ty pp_c_dimension d
174
  | Tydec_enum tl ->
175
    begin
176
      incr cpt;
177
      fprintf fmt "enum _enum_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:", " pp_print_string) tl var
178
    end
179
  | Tydec_struct fl ->
180
    begin
181
      incr cpt;
182
      fprintf fmt "struct _struct_%s_%d { %a } %s" filename !cpt (Utils.fprintf_list ~sep:" " (pp_c_struct_type_field filename cpt)) fl var
183
    end
184

    
185
let print_type_definitions fmt filename =
186
  let cpt_type = ref 0 in
187
  Hashtbl.iter (fun typ def ->
188
    match typ with
189
    | Tydec_const var ->
190
      fprintf fmt "typedef %a;@.@."
191
	(pp_c_type_decl filename cpt_type var) def
192
    | _        -> ()) type_table
193

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

    
230
(* Local Variables: *)
231
(* compile-command:"make -C ../../.." *)
232
(* End: *)