Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_common.ml @ 89137ae1

History | View | Annotate | Download (14.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

    
17

    
18
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
 
25
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
26
let mk_self m =
27
  let used name =
28
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
29
    || (List.exists (fun v -> v.var_id = name) m.mstep.step_outputs)
30
    || (List.exists (fun v -> v.var_id = name) m.mstep.step_locals)
31
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
32
  mk_new_name used "self"
33

    
34
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
35
let mk_instance m =
36
  let used name =
37
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
38
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
39
  mk_new_name used "inst"
40

    
41
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
42
let mk_attribute m =
43
  let used name =
44
       (List.exists (fun v -> v.var_id = name) m.mstep.step_inputs)
45
    || (List.exists (fun v -> v.var_id = name) m.mmemory) in
46
  mk_new_name used "attr"
47

    
48
let mk_call_var_decl loc id =
49
  { var_id = id;
50
    var_orig = false;
51
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
52
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
53
    var_dec_const = false;
54
    var_dec_value = None;
55
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
56
    var_clock = Clocks.new_var true;
57
    var_loc = loc }
58

    
59
(* counter for loop variable creation *)
60
let loop_cpt = ref (-1)
61

    
62
let reset_loop_counter () =
63
 loop_cpt := -1
64

    
65
let mk_loop_var m () =
66
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
67
  let rec aux () =
68
    incr loop_cpt;
69
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
70
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
71
  in aux ()
72
(*
73
let addr_cpt = ref (-1)
74

    
75
let reset_addr_counter () =
76
 addr_cpt := -1
77

    
78
let mk_addr_var m var =
79
  let vars = m.mmemory in
80
  let rec aux () =
81
    incr addr_cpt;
82
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
83
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
84
  in aux ()
85
*)
86
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
87
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
88
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
89
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
90
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
91
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
92
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
93
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
94

    
95
let rec pp_c_dimension fmt dim =
96
  match dim.Dimension.dim_desc with
97
  | Dimension.Dident id       ->
98
    fprintf fmt "%s" id
99
  | Dimension.Dint i          ->
100
    fprintf fmt "%d" i
101
  | Dimension.Dbool b         ->
102
    fprintf fmt "%B" b
103
  | Dimension.Dite (i, t, e)  ->
104
    fprintf fmt "((%a)?%a:%a)"
105
       pp_c_dimension i pp_c_dimension t pp_c_dimension e
106
 | Dimension.Dappl (f, args) ->
107
     fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args
108
 | Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
109
 | Dimension.Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id)
110
 | Dimension.Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
111

    
112
let is_basic_c_type t =
113
  match (Types.repr t).Types.tdesc with
114
  | Types.Tbool | Types.Treal | Types.Tint  -> true
115
  | _                                       -> false
116

    
117
let pp_basic_c_type fmt t =
118
  match (Types.repr t).Types.tdesc with
119
  | Types.Tbool           -> fprintf fmt "_Bool"
120
  | Types.Treal           -> fprintf fmt "double"
121
  | Types.Tint            -> fprintf fmt "int"
122
  | _ -> assert false (* Not a basic C type. Do not handle arrays or pointers *)
123

    
124
let pp_c_type var fmt t =
125
  let rec aux t pp_suffix =
126
    match (Types.repr t).Types.tdesc with
127
    | Types.Tclock t'       -> aux t' pp_suffix
128
    | Types.Tbool | Types.Treal | Types.Tint 
129
                            -> fprintf fmt "%a %s%a" pp_basic_c_type t var pp_suffix ()
130
    | Types.Tarray (d, t')  ->
131
      let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
132
      aux t' pp_suffix'
133
    | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
134
    | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
135
    | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
136
    | _                     -> eprintf "internal error: C_backend_common.pp_c_type %a@." Types.print_ty t; assert false
137
  in aux t (fun fmt () -> ())
138

    
139
let rec pp_c_initialize fmt t = 
140
  match (Types.repr t).Types.tdesc with
141
  | Types.Tint -> pp_print_string fmt "0"
142
  | Types.Tclock t' -> pp_c_initialize fmt t'
143
  | Types.Tbool -> pp_print_string fmt "0" 
144
  | Types.Treal -> pp_print_string fmt "0."
145
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
146
    fprintf fmt "{%a}"
147
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
148
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
149
  | _ -> assert false
150

    
151

    
152
let pp_c_tag fmt t =
153
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
154

    
155

    
156
(* Prints a constant value *)
157
let rec pp_c_const fmt c =
158
  match c with
159
    | Const_int i     -> pp_print_int fmt i
160
    | Const_real r    -> pp_print_string fmt r
161
    | Const_float r   -> pp_print_float fmt r
162
    | Const_tag t     -> pp_c_tag fmt t
163
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
164
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
165
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
166

    
167
(* Prints a value expression [v], with internal function calls only.
168
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
169
   but an offset suffix may be added for array variables
170
*)
171
let rec pp_c_val self pp_var fmt v =
172
  (*Format.eprintf "C_backend_common.pp_c_val %a@." pp_val v;*)
173
  match v with
174
  | Cst c         -> pp_c_const fmt c
175
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
176
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
177
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
178
  | LocalVar v    -> pp_var fmt v
179
  | StateVar v    ->
180
    (* array memory vars are represented by an indirection to a local var with the right type,
181
       in order to avoid casting everywhere. *)
182
    if Types.is_array_type v.var_type
183
    then fprintf fmt "%a" pp_var v
184
    else fprintf fmt "%s->_reg.%a" self pp_var v
185
  | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
186

    
187
(* Access to the value of a variable:
188
   - if it's not a scalar output, then its name is enough
189
   - otherwise, dereference it (it has been declared as a pointer,
190
     despite its scalar Lustre type)
191
   - moreover, dereference memory array variables.
192
*)
193
let pp_c_var_read m fmt id =
194
  if Types.is_address_type id.var_type
195
  then
196
    if is_memory m id
197
    then fprintf fmt "(*%s)" id.var_id
198
    else fprintf fmt "%s" id.var_id
199
  else
200
    if is_output m id
201
    then fprintf fmt "*%s" id.var_id
202
    else fprintf fmt "%s" id.var_id
203

    
204
(* Addressable value of a variable, the one that is passed around in calls:
205
   - if it's not a scalar non-output, then its name is enough
206
   - otherwise, reference it (it must be passed as a pointer,
207
     despite its scalar Lustre type)
208
*)
209
let pp_c_var_write m fmt id =
210
  if Types.is_address_type id.var_type
211
  then
212
    fprintf fmt "%s" id.var_id
213
  else
214
    if is_output m id
215
    then
216
      fprintf fmt "%s" id.var_id
217
    else
218
      fprintf fmt "&%s" id.var_id
219

    
220
(* Declaration of an input variable:
221
   - if its type is array/matrix/etc, then declare it as a mere pointer,
222
     in order to cope with unknown/parametric array dimensions, 
223
     as it is the case for generics
224
*)
225
let pp_c_decl_input_var fmt id =
226
  if !Options.ansi && Types.is_address_type id.var_type
227
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
228
  else pp_c_type id.var_id fmt id.var_type
229

    
230
(* Declaration of an output variable:
231
   - if its type is scalar, then pass its address
232
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
233
     in order to cope with unknown/parametric array dimensions, 
234
     as it is the case for generics
235
*)
236
let pp_c_decl_output_var fmt id =
237
  if (not !Options.ansi) && Types.is_address_type id.var_type
238
  then pp_c_type                  id.var_id  fmt id.var_type
239
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
240

    
241
(* Declaration of a local/mem variable:
242
   - if it's an array/matrix/etc, its size(s) should be
243
     known in order to statically allocate memory, 
244
     so we print the full type
245
*)
246
let pp_c_decl_local_var m fmt id =
247
  if id.var_dec_const
248
  then
249
    Format.fprintf fmt "%a = %a"
250
      (pp_c_type id.var_id) id.var_type
251
      (pp_c_val "" (pp_c_var_read m)) (get_const_assign m id)
252
  else
253
    Format.fprintf fmt "%a"
254
      (pp_c_type id.var_id) id.var_type
255

    
256
let pp_c_decl_array_mem self fmt id =
257
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
258
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
259
    (pp_c_type "(*)") id.var_type
260
    self
261
    id.var_id
262

    
263
(* Declaration of a struct variable:
264
   - if it's an array/matrix/etc, we declare it as a pointer
265
*)
266
let pp_c_decl_struct_var fmt id =
267
  if Types.is_array_type id.var_type
268
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
269
  else pp_c_type                  id.var_id  fmt id.var_type
270

    
271
let pp_c_decl_instance_var fmt (name, (node, static)) = 
272
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
273

    
274
let pp_c_checks self fmt m =
275
  Utils.fprintf_list ~sep:"" 
276
    (fun fmt (loc, check) -> 
277
      fprintf fmt 
278
	"@[<v>%a@,assert (%a);@]@," 
279
	Location.pp_c_loc loc
280
	(pp_c_val self (pp_c_var_read m)) check
281
    ) 
282
    fmt 
283
    m.mstep.step_checks
284

    
285
(********************************************************************************************)
286
(*                       Struct Printing functions                                          *)
287
(********************************************************************************************)
288

    
289
let pp_registers_struct fmt m =
290
  if m.mmemory <> []
291
  then
292
    fprintf fmt "@[%a {@[%a; @]}@] _reg; "
293
      pp_machine_regtype_name m.mname.node_id
294
      (Utils.fprintf_list ~sep:"; " pp_c_decl_struct_var) m.mmemory
295
  else
296
    ()
297

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

    
312
let print_machine_struct_from_header fmt inode =
313
  if inode.nodei_stateless then
314
    begin
315
    end
316
  else
317
    begin
318
      (* Declare struct *)
319
      fprintf fmt "@[%a;@]@."
320
	pp_machine_memtype_name inode.nodei_id
321
    end
322

    
323
(********************************************************************************************)
324
(*                      Prototype Printing functions                                        *)
325
(********************************************************************************************)
326

    
327
let print_alloc_prototype fmt (name, static) =
328
  fprintf fmt "%a * %a (%a)"
329
    pp_machine_memtype_name name
330
    pp_machine_alloc_name name
331
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
332

    
333
let print_reset_prototype self fmt (name, static) =
334
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
335
    pp_machine_reset_name name
336
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
337
    (Utils.pp_final_char_if_non_empty ",@," static) 
338
    pp_machine_memtype_name name
339
    self
340

    
341
let print_stateless_prototype fmt (name, inputs, outputs) =
342
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]@,@])"
343
    pp_machine_step_name name
344
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
345
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
346
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
347

    
348
let print_step_prototype self fmt (name, inputs, outputs) =
349
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
350
    pp_machine_step_name name
351
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
352
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
353
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
354
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
355
    pp_machine_memtype_name name
356
    self
357

    
358
let print_stateless_C_prototype fmt (name, inputs, outputs) =
359
  let output = 
360
    match outputs with
361
    | [hd] -> hd
362
    | _ -> assert false
363
  in
364
  fprintf fmt "%a %s (@[<v>@[%a@]@,@])"
365
    pp_basic_c_type output.var_type
366
    name
367
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
368
    
369
    
370

    
371
let print_import_prototype fmt (Dep (_, s, _, _)) =
372
  fprintf fmt "#include \"%s.h\"@," s
373

    
374
let print_import_alloc_prototype fmt (Dep (_, s, _, stateful)) =
375
  if stateful then
376
    fprintf fmt "#include \"%s_alloc.h\"@," s
377

    
378
let print_extern_alloc_prototypes fmt (Dep (_,_, header,_)) =
379
  List.iter (fun decl -> match decl.top_decl_desc with
380
  | ImportedNode ind when not ind.nodei_stateless ->
381
    let static = List.filter (fun v -> v.var_dec_const) ind.nodei_inputs
382
    in fprintf fmt "extern %a;@." print_alloc_prototype (ind.nodei_id, static)
383
  | _                -> ()
384
  ) header
385

    
386
(* Local Variables: *)
387
(* compile-command:"make -C ../../.." *)
388
(* End: *)