Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (9.79 KB)

1
open Format
2
open LustreSpec
3
open Corelang
4
open Machine_code
5

    
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

    
15
(* Generation of a non-clashing name for the self memory variable (for step and reset functions) *)
16
let mk_self m =
17
  mk_new_name (m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory) "self"
18

    
19
(* Generation of a non-clashing name for the instance variable of static allocation macro *)
20
let mk_instance m =
21
  mk_new_name (m.mstep.step_inputs@m.mmemory) "inst"
22

    
23
(* Generation of a non-clashing name for the attribute variable of static allocation macro *)
24
let mk_attribute m =
25
  mk_new_name (m.mstep.step_inputs@m.mmemory) "attr"
26

    
27
let mk_call_var_decl loc id =
28
  { var_id = id;
29
    var_dec_type = mktyp Location.dummy_loc Tydec_any;
30
    var_dec_clock = mkclock Location.dummy_loc Ckdec_any;
31
    var_dec_const = false;
32
    var_type = Type_predef.type_arrow (Types.new_var ()) (Types.new_var ());
33
    var_clock = Clocks.new_var true;
34
    var_loc = loc }
35

    
36
(* counter for loop variable creation *)
37
let loop_cpt = ref (-1)
38

    
39
let reset_loop_counter () =
40
 loop_cpt := -1
41

    
42
let mk_loop_var m () =
43
  let vars = m.mstep.step_inputs@m.mstep.step_outputs@m.mstep.step_locals@m.mmemory in
44
  let rec aux () =
45
    incr loop_cpt;
46
    let s = Printf.sprintf "__%s_%d" "i" !loop_cpt in
47
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
48
  in aux ()
49
(*
50
let addr_cpt = ref (-1)
51

    
52
let reset_addr_counter () =
53
 addr_cpt := -1
54

    
55
let mk_addr_var m var =
56
  let vars = m.mmemory in
57
  let rec aux () =
58
    incr addr_cpt;
59
    let s = Printf.sprintf "%s_%s_%d" var "addr" !addr_cpt in
60
    if List.exists (fun v -> v.var_id = s) vars then aux () else s
61
  in aux ()
62
*)
63
let pp_machine_memtype_name fmt id = fprintf fmt "struct %s_mem" id
64
let pp_machine_regtype_name fmt id = fprintf fmt "struct %s_reg" id
65
let pp_machine_alloc_name fmt id = fprintf fmt "%s_alloc" id
66
let pp_machine_static_declare_name fmt id = fprintf fmt "%s_DECLARE" id
67
let pp_machine_static_link_name fmt id = fprintf fmt "%s_LINK" id
68
let pp_machine_static_alloc_name fmt id = fprintf fmt "%s_ALLOC" id
69
let pp_machine_reset_name fmt id = fprintf fmt "%s_reset" id
70
let pp_machine_step_name fmt id = fprintf fmt "%s_step" id
71

    
72
let pp_c_dimension fmt d =
73
 fprintf fmt "%a" Dimension.pp_dimension d
74

    
75
let pp_c_type var fmt t =
76
  let rec aux t pp_suffix =
77
  match (Types.repr t).Types.tdesc with
78
  | Types.Tclock t'       -> aux t' pp_suffix
79
  | Types.Tbool           -> fprintf fmt "_Bool %s%a" var pp_suffix ()
80
  | Types.Treal           -> fprintf fmt "double %s%a" var pp_suffix ()
81
  | Types.Tint            -> fprintf fmt "int %s%a" var pp_suffix ()
82
  | Types.Tarray (d, t')  ->
83
    let pp_suffix' fmt () = fprintf fmt "%a[%a]" pp_suffix () pp_c_dimension d in
84
    aux t' pp_suffix'
85
  | Types.Tstatic (_, t') -> fprintf fmt "const "; aux t' pp_suffix
86
  | Types.Tconst ty       -> fprintf fmt "%s %s" ty var
87
  | Types.Tarrow (_, _)   -> fprintf fmt "void (*%s)()" var
88
  | _                     -> eprintf "internal error: pp_c_type %a@." Types.print_ty t; assert false
89
  in aux t (fun fmt () -> ())
90

    
91
let rec pp_c_initialize fmt t = 
92
  match (Types.repr t).Types.tdesc with
93
  | Types.Tint -> pp_print_string fmt "0"
94
  | Types.Tclock t' -> pp_c_initialize fmt t'
95
  | Types.Tbool -> pp_print_string fmt "0" 
96
  | Types.Treal -> pp_print_string fmt "0."
97
  | Types.Tarray (d, t') when Dimension.is_dimension_const d ->
98
    fprintf fmt "{%a}"
99
      (Utils.fprintf_list ~sep:"," (fun fmt _ -> pp_c_initialize fmt t'))
100
      (Utils.duplicate 0 (Dimension.size_const_dimension d))
101
  | _ -> assert false
102

    
103
(* Declaration of an input variable:
104
   - if its type is array/matrix/etc, then declare it as a mere pointer,
105
     in order to cope with unknown/parametric array dimensions, 
106
     as it is the case for generics
107
*)
108
let pp_c_decl_input_var fmt id =
109
  if !Options.ansi && Types.is_address_type id.var_type
110
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
111
  else pp_c_type id.var_id fmt id.var_type
112

    
113
(* Declaration of an output variable:
114
   - if its type is scalar, then pass its address
115
   - if its type is array/matrix/struct/etc, then declare it as a mere pointer,
116
     in order to cope with unknown/parametric array dimensions, 
117
     as it is the case for generics
118
*)
119
let pp_c_decl_output_var fmt id =
120
  if (not !Options.ansi) && Types.is_address_type id.var_type
121
  then pp_c_type                  id.var_id  fmt id.var_type
122
  else pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
123

    
124
(* Declaration of a local/mem variable:
125
   - if it's an array/matrix/etc, its size(s) should be
126
     known in order to statically allocate memory, 
127
     so we print the full type
128
*)
129
let pp_c_decl_local_var fmt id =
130
  pp_c_type id.var_id fmt id.var_type
131

    
132
let pp_c_decl_array_mem self fmt id =
133
  fprintf fmt "%a = (%a) (%s->_reg.%s)"
134
    (pp_c_type (sprintf "(*%s)" id.var_id)) id.var_type
135
    (pp_c_type "(*)") id.var_type
136
    self
137
    id.var_id
138

    
139
(* Declaration of a struct variable:
140
   - if it's an array/matrix/etc, we declare it as a pointer
141
*)
142
let pp_c_decl_struct_var fmt id =
143
  if Types.is_array_type id.var_type
144
  then pp_c_type (sprintf "(*%s)" id.var_id) fmt (Types.array_base_type id.var_type)
145
  else pp_c_type                  id.var_id  fmt id.var_type
146

    
147
(* Access to the value of a variable:
148
   - if it's not a scalar output, then its name is enough
149
   - otherwise, dereference it (it has been declared as a pointer,
150
     despite its scalar Lustre type)
151
   - moreover, dereference memory array variables.
152
*)
153
let pp_c_var_read m fmt id =
154
  if Types.is_address_type id.var_type
155
  then
156
    if is_memory m id
157
    then fprintf fmt "(*%s)" id.var_id
158
    else fprintf fmt "%s" id.var_id
159
  else
160
    if is_output m id
161
    then fprintf fmt "*%s" id.var_id
162
    else fprintf fmt "%s" id.var_id
163

    
164
(* Addressable value of a variable, the one that is passed around in calls:
165
   - if it's not a scalar non-output, then its name is enough
166
   - otherwise, reference it (it must be passed as a pointer,
167
     despite its scalar Lustre type)
168
*)
169
let pp_c_var_write m fmt id =
170
  if Types.is_address_type id.var_type
171
  then
172
    fprintf fmt "%s" id.var_id
173
  else
174
    if is_output m id
175
    then
176
      fprintf fmt "%s" id.var_id
177
    else
178
      fprintf fmt "&%s" id.var_id
179

    
180
let pp_c_decl_instance_var fmt (name, (node, static)) = 
181
  fprintf fmt "%a *%s" pp_machine_memtype_name (node_name node) name
182

    
183
let pp_c_tag fmt t =
184
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
185

    
186
(* Prints a constant value *)
187
let rec pp_c_const fmt c =
188
  match c with
189
    | Const_int i     -> pp_print_int fmt i
190
    | Const_real r    -> pp_print_string fmt r
191
    | Const_float r   -> pp_print_float fmt r
192
    | Const_tag t     -> pp_c_tag fmt t
193
    | Const_array ca  -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " pp_c_const) ca
194
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> pp_c_const fmt c)) fl
195

    
196
(* Prints a value expression [v], with internal function calls only.
197
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
198
   but an offset suffix may be added for array variables
199
*)
200
let rec pp_c_val self pp_var fmt v =
201
  match v with
202
    | Cst c         -> pp_c_const fmt c
203
    | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
204
    | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
205
    | Power (v, n)  -> assert false
206
    | LocalVar v    -> pp_var fmt v
207
    | StateVar v    ->
208
    (* array memory vars are represented by an indirection to a local var with the right type,
209
       in order to avoid casting everywhere. *)
210
      if Types.is_array_type v.var_type
211
      then fprintf fmt "%a" pp_var v
212
      else fprintf fmt "%s->_reg.%a" self pp_var v
213
    | Fun (n, vl)   -> Basic_library.pp_c n (pp_c_val self pp_var) fmt vl
214

    
215
let pp_c_checks self fmt m =
216
  Utils.fprintf_list ~sep:"" 
217
    (fun fmt (loc, check) -> 
218
      fprintf fmt 
219
	"@[<v>%a@,assert (%a);@]@," 
220
	Location.pp_c_loc loc
221
	(pp_c_val self (pp_c_var_read m)) check
222
    ) 
223
    fmt 
224
    m.mstep.step_checks
225

    
226

    
227
(********************************************************************************************)
228
(*                      Prototype Printing functions                                        *)
229
(********************************************************************************************)
230

    
231
let print_alloc_prototype fmt (name, static) =
232
  fprintf fmt "%a * %a (%a)"
233
    pp_machine_memtype_name name
234
    pp_machine_alloc_name name
235
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
236

    
237
let print_reset_prototype self fmt (name, static) =
238
  fprintf fmt "void %a (@[<v>%a%t%a *%s@])"
239
    pp_machine_reset_name name
240
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) static
241
    (Utils.pp_final_char_if_non_empty ",@," static) 
242
    pp_machine_memtype_name name
243
    self
244

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

    
252
let print_step_prototype self fmt (name, inputs, outputs) =
253
  fprintf fmt "void %a (@[<v>@[%a%t@]@,@[%a@]%t@[%a *%s@]@])"
254
    pp_machine_step_name name
255
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_input_var) inputs
256
    (Utils.pp_final_char_if_non_empty ",@ " inputs) 
257
    (Utils.fprintf_list ~sep:",@ " pp_c_decl_output_var) outputs
258
    (Utils.pp_final_char_if_non_empty ",@," outputs) 
259
    pp_machine_memtype_name name
260
    self
261

    
262
let print_import_prototype fmt (s, _, _) =
263
  fprintf fmt "#include \"%s.h\"@," s
264

    
265
(* Local Variables: *)
266
(* compile-command:"make -C ../../.." *)
267
(* End: *)