Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 70e1006b

History | View | Annotate | Download (12.1 KB)

1 b38ffff3 ploc
(********************************************************************)
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 d2be420e ploc
open Format
13
open LustreSpec
14
open Corelang
15
open Machine_code
16
17
18 522938b5 ploc
let print_version fmt =
19
  Format.fprintf fmt 
20
    "/* @[<v>C code generated by %s@,SVN version number %s@,Code is %s compliant */@,@]@."
21
    (Filename.basename Sys.executable_name) 
22
    Version.number 
23
    (if !Options.ansi then "ANSI C90" else "C99")
24 70e1006b xthirioux
 
25 d2be420e ploc
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
26
let mk_self m =
27
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
28
29
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
30
let mk_instance m =
31
  mk_new_name (m.mstep.step_inputs@m.mmemory) "inst"
32
33
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
34
let mk_attribute m =
35
  mk_new_name (m.mstep.step_inputs@m.mmemory) "attr"
36
37
let mk_call_var_decl loc id =
38
  { var_id = id;
39
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
40
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
41
    var_dec_const = false;
42
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
43
    var_clock = Clocks.new_var true;
44
    var_loc = loc }
45
46
(* counter for loop variable creation *)
47
let loop_cpt = ref (-1)
48
49
let reset_loop_counter () =
50
 loop_cpt := -1
51
52
let mk_loop_var m () =
53
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
54
  let rec aux () =
55
    incr loop_cpt;
56
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
57
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
58
  in aux ()
59
(*
60
let addr_cpt = ref (-1)
61
62
let reset_addr_counter () =
63
 addr_cpt := -1
64
65
let mk_addr_var m var =
66
  let vars = m.mmemory in
67
  let rec aux () =
68
    incr addr_cpt;
69
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
70
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
71
  in aux ()
72
*)
73
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
74
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
75
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
76
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
77
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
78
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
79
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
80
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
81
82
let pp_c_dimension fmt d =
83
 fprintf fmt "%a" Dimension.pp_dimension d
84
85
let pp_c_type var fmt t =
86
  let rec aux t pp_suffix =
87
  match (Types.repr t).Types.tdesc with
88
  | Types.Tclock t'       -> aux t' pp_suffix
89
  | Types.Tbool           -> fprintf fmt "_Bool %s%a" var pp_suffix ()
90
  | Types.Treal           -> fprintf fmt "double %s%a" var pp_suffix ()
91
  | Types.Tint            -> fprintf fmt "int %s%a" var pp_suffix ()
92
  | Types.Tarray (d, t')  ->
93
    let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
94
    aux t' pp_suffix'
95
  | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
96
  | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
97
  | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
98
  | _                     -> eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false
99
  in aux t (fun fmt () -> ())
100
101
let rec pp_c_initialize fmt t = 
102
  match (Types.repr t).Types.tdesc with
103
  | Types.Tint -> pp_print_string fmt "0"
104
  | Types.Tclock t' -> pp_c_initialize fmt t'
105
  | Types.Tbool -> pp_print_string fmt "0" 
106
  | Types.Treal -> pp_print_string fmt "0."
107
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
108
    fprintf fmt "{%a}"
109
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
110
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
111
  | _ -> assert false
112
113
(* Declaration of an input variable:
114
   - if its type is array/matrix/etc, then declare it as a mere pointer,
115
     in order to cope with unknown/parametric array dimensions, 
116
     as it is the case for generics
117
*)
118
let pp_c_decl_input_var fmt id =
119
  if !Options.ansi && Types.is_address_type id.var_type
120
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
121
  else pp_c_type id.var_id fmt id.var_type
122
123
(* Declaration of an output variable:
124
   - if its type is scalar, then pass its address
125
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
126
     in order to cope with unknown/parametric array dimensions, 
127
     as it is the case for generics
128
*)
129
let pp_c_decl_output_var fmt id =
130
  if (not !Options.ansi) && Types.is_address_type id.var_type
131
  then pp_c_type                  id.var_id  fmt id.var_type
132
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
133
134
(* Declaration of a local/mem variable:
135
   - if it's an array/matrix/etc, its size(s) should be
136
     known in order to statically allocate memory, 
137
     so we print the full type
138
*)
139
let pp_c_decl_local_var fmt id =
140
  pp_c_type id.var_id fmt id.var_type
141
142
let pp_c_decl_array_mem self fmt id =
143
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
144
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
145
    (pp_c_type "(*)") id.var_type
146
    self
147
    id.var_id
148
149
(* Declaration of a struct variable:
150
   - if it's an array/matrix/etc, we declare it as a pointer
151
*)
152
let pp_c_decl_struct_var fmt id =
153
  if Types.is_array_type id.var_type
154
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
155
  else pp_c_type                  id.var_id  fmt id.var_type
156
157
(* Access to the value of a variable:
158
   - if it's not a scalar output, then its name is enough
159
   - otherwise, dereference it (it has been declared as a pointer,
160
     despite its scalar Lustre type)
161
   - moreover, dereference memory array variables.
162
*)
163
let pp_c_var_read m fmt id =
164
  if Types.is_address_type id.var_type
165
  then
166
    if is_memory m id
167
    then fprintf fmt "(*%s)" id.var_id
168
    else fprintf fmt "%s" id.var_id
169
  else
170
    if is_output m id
171
    then fprintf fmt "*%s" id.var_id
172
    else fprintf fmt "%s" id.var_id
173
174
(* Addressable value of a variable, the one that is passed around in calls:
175
   - if it's not a scalar non-output, then its name is enough
176
   - otherwise, reference it (it must be passed as a pointer,
177
     despite its scalar Lustre type)
178
*)
179
let pp_c_var_write m fmt id =
180
  if Types.is_address_type id.var_type
181
  then
182
    fprintf fmt "%s" id.var_id
183
  else
184
    if is_output m id
185
    then
186
      fprintf fmt "%s" id.var_id
187
    else
188
      fprintf fmt "&%s" id.var_id
189
190
let pp_c_decl_instance_var fmt (name, (node, static)) = 
191
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
192
193
let pp_c_tag fmt t =
194
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
195
196
(* Prints a constant value *)
197
let rec pp_c_const fmt c =
198
  match c with
199
    | Const_int i     -> pp_print_int fmt i
200
    | Const_real r    -> pp_print_string fmt r
201
    | Const_float r   -> pp_print_float fmt r
202
    | Const_tag t     -> pp_c_tag fmt t
203
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
204
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
205 0038002e ploc
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
206 d2be420e ploc
207
(* Prints a value expression [v], with internal function calls only.
208
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
209
   but an offset suffix may be added for array variables
210
*)
211
let rec pp_c_val self pp_var fmt v =
212
  match v with
213
    | Cst c         -> pp_c_const fmt c
214
    | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
215
    | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
216
    | Power (v, n)  -> assert false
217
    | LocalVar v    -> pp_var fmt v
218
    | StateVar v    ->
219
    (* array memory vars are represented by an indirection to a local var with the right type,
220
       in order to avoid casting everywhere. *)
221
      if Types.is_array_type v.var_type
222
      then fprintf fmt "%a" pp_var v
223
      else fprintf fmt "%s->_reg.%a" self pp_var v
224
    | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
225
226
let pp_c_checks self fmt m =
227 713176a4 ploc
  Utils.fprintf_list ~sep:"" 
228
    (fun fmt (loc, check) -> 
229
      fprintf fmt 
230
	"@[<v>%a@,assert (%a);@]@," 
231
	Location.pp_c_loc loc
232
	(pp_c_val self (pp_c_var_read m)) check
233
    ) 
234
    fmt 
235
    m.mstep.step_checks
236 d2be420e ploc
237 70e1006b xthirioux
(********************************************************************************************)
238
(*                       Struct Printing functions                                          *)
239
(********************************************************************************************)
240
241
let pp_registers_struct fmt m =
242
  if m.mmemory <> []
243
  then
244
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
245
      pp_machine_regtype_name m.mname.node_id
246
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
247
  else
248
    ()
249
250
let print_machine_struct fmt m =
251
  if fst (get_stateless_status m) then
252
    begin
253
    end
254
  else
255
    begin
256
      (* Define struct *)
257
      fprintf fmt "@[%a {@[%a%a%t@]};@]@."
258
	pp_machine_memtype_name m.mname.node_id
259
	pp_registers_struct m
260
	(Utils.fprintf_list ~sep:"; " pp_c_decl_instance_var) m.minstances
261
	(Utils.pp_final_char_if_non_empty "; " m.minstances)
262
    end
263
264
let print_machine_struct_from_header fmt inode =
265
  if inode.nodei_stateless then
266
    begin
267
    end
268
  else
269
    begin
270
      (* Declare struct *)
271
      fprintf fmt "@[%a;@]@."
272
	pp_machine_memtype_name inode.nodei_id
273
    end
274 522938b5 ploc
275
(********************************************************************************************)
276
(*                      Prototype Printing functions                                        *)
277
(********************************************************************************************)
278
279
let print_alloc_prototype fmt (name, static) =
280
  fprintf fmt "%a * %a (%a)"
281
    pp_machine_memtype_name name
282
    pp_machine_alloc_name name
283
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
284
285
let print_reset_prototype self fmt (name, static) =
286
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
287
    pp_machine_reset_name name
288
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
289
    (Utils.pp_final_char_if_non_empty ",@," static) 
290
    pp_machine_memtype_name name
291
    self
292
293
let print_stateless_prototype fmt (name, inputs, outputs) =
294
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
295
    pp_machine_step_name name
296
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
297
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
298
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
299
300
let print_step_prototype self fmt (name, inputs, outputs) =
301
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
302
    pp_machine_step_name name
303
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
304
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
305
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
306
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
307
    pp_machine_memtype_name name
308
    self
309
310 70e1006b xthirioux
let print_import_prototype fmt (_, s, _) =
311 522938b5 ploc
  fprintf fmt "#include \"%s.h\"@," s
312
313 70e1006b xthirioux
let print_import_alloc_prototype fmt (_, s, _) =
314
  fprintf fmt "#include \"%s_alloc.h\"@," s
315
316
let print_extern_alloc_prototypes fmt (_,_, header) =
317
  List.iter (fun decl -> match decl.top_decl_desc with
318
  | ImportedNode ind when not ind.nodei_stateless ->
319
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs
320
    in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static)
321
  | _                -> ()
322
  ) header
323
324 d2be420e ploc
(* Local Variables: *)
325 522938b5 ploc
(* compile-command:"make -C ../../.." *)
326 d2be420e ploc
(* End: *)