Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (15.5 KB)

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

    
7
module type MODIFIERS_SRC =
8
sig
9
end
10

    
11
module EmptyMod =
12
struct
13
end
14

    
15
module Main = functor (Mod: MODIFIERS_SRC) -> 
16
struct
17

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

    
22
(* Computes the depth to which multi-dimension array assignments should be expanded.
23
   It equals the maximum number of nested static array constructions accessible from root [v].
24
*)
25
let rec expansion_depth v =
26
 match v with
27
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
28
 | Cst _
29
 | LocalVar _
30
 | StateVar _  -> 0
31
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
32
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
33
 | Access (v, i) -> max 0 (expansion_depth v - 1)
34
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
35

    
36
type loop_index = LVar of ident | LInt of int ref
37

    
38
(* Computes the list of nested loop variables together with their dimension bounds.
39
   - LInt r stands for loop expansion (no loop variable, but int loop index)
40
   - LVar v stands for loop variable v
41
*)
42
let rec mk_loop_variables m ty depth =
43
 match (Types.repr ty).Types.tdesc, depth with
44
 | Types.Tarray (d, ty'), 0       ->
45
   let v = mk_loop_var m () in
46
   (d, LVar v) :: mk_loop_variables m ty' 0
47
 | Types.Tarray (d, ty'), _       ->
48
   let r = ref (-1) in
49
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
50
 | _                    , 0       -> []
51
 | _                              -> assert false
52

    
53
let reorder_loop_variables loop_vars =
54
  let (int_loops, var_loops) = 
55
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
56
  in
57
  var_loops @ int_loops
58
    
59
(* Prints a one loop variable suffix for arrays *)
60
let pp_loop_var fmt lv =
61
 match snd lv with
62
 | LVar v -> fprintf fmt "[%s]" v
63
 | LInt r -> fprintf fmt "[%d]" !r
64

    
65
(* Prints a suffix of loop variables for arrays *)
66
let pp_suffix fmt loop_vars =
67
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
68

    
69
(* Prints a [value] indexed by the suffix list [loop_vars] *)
70
let rec pp_value_suffix self loop_vars pp_value fmt value =
71
 match loop_vars, value with
72
 | (_, LInt r) :: q, Array vl     ->
73
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
74
 | _           :: q, Power (v, n) ->
75
   pp_value_suffix self loop_vars pp_value fmt v
76
 | _               , Fun (n, vl)  ->
77
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
78
 | _               , _            ->
79
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
80
   pp_c_val self pp_var_suffix fmt value
81

    
82
(* type_directed assignment: array vs. statically sized type
83
   - [var_type]: type of variable to be assigned
84
   - [var_name]: name of variable to be assigned
85
   - [value]: assigned value
86
   - [pp_var]: printer for variables
87
*)
88
let pp_assign m self pp_var fmt var_type var_name value =
89
  let depth = expansion_depth value in
90
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val value depth;*)
91
  let loop_vars = mk_loop_variables m var_type depth in
92
  let reordered_loop_vars = reorder_loop_variables loop_vars in
93
  let rec aux fmt vars =
94
    match vars with
95
    | [] ->
96
      fprintf fmt "%a = %a;" 
97
	(pp_value_suffix self loop_vars pp_var) var_name
98
	(pp_value_suffix self loop_vars pp_var) value
99
    | (d, LVar i) :: q ->
100
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
101
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
102
	i i i Dimension.pp_dimension d i
103
	aux q
104
    | (d, LInt r) :: q ->
105
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
106
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
107
      fprintf fmt "@[<v 2>{@,%a@]@,}"
108
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
109
  in
110
  begin
111
    reset_loop_counter ();
112
    (*reset_addr_counter ();*)
113
    aux fmt reordered_loop_vars
114
  end
115

    
116
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
117
 try (* stateful node instance *)
118
   let (n,_) = List.assoc i m.minstances in
119
   fprintf fmt "%a (%a%t%a%t%s->%s);"
120
     pp_machine_step_name (node_name n)
121
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
122
     (Utils.pp_final_char_if_non_empty ", " inputs) 
123
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
124
     (Utils.pp_final_char_if_non_empty ", " outputs)
125
     self
126
     i
127
 with Not_found -> (* stateless node instance *)
128
   let (n,_) = List.assoc i m.mcalls in
129
   fprintf fmt "%a (%a%t%a);"
130
     pp_machine_step_name (node_name n)
131
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
132
     (Utils.pp_final_char_if_non_empty ", " inputs) 
133
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
134

    
135
let pp_machine_reset (m: machine_t) self fmt inst =
136
  let (node, static) = List.assoc inst m.minstances in
137
  fprintf fmt "%a(%a%t%s->%s);"
138
    pp_machine_reset_name (node_name node)
139
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
140
    (Utils.pp_final_char_if_non_empty ", " static)
141
    self inst
142

    
143
let has_c_prototype funname dependencies =
144
  let imported_node_opt = (* We select the last imported node with the name funname.
145
			       The order of evaluation of dependencies should be
146
			       compatible with overloading. (Not checked yet) *) 
147
      List.fold_left
148
	(fun res (_, _, decls) -> 
149
	  match res with
150
	  | Some _ -> res
151
	  | None -> 
152
	    let matched = fun t -> match t.top_decl_desc with 
153
	      | ImportedNode nd -> nd.nodei_id = funname 
154
	      | _ -> false
155
	    in
156
	    if List.exists matched decls then (
157
	      match (List.find matched decls).top_decl_desc with
158
	      | ImportedNode nd -> Some nd
159
	      | _ -> assert false
160
	    )
161
	    else
162
	      None
163
	) None dependencies in
164
    match imported_node_opt with
165
    | None -> false
166
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
167

    
168
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
169
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
170
    (pp_c_val self (pp_c_var_read m)) c
171
    (Utils.pp_newline_if_non_empty tl)
172
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
173
    (Utils.pp_newline_if_non_empty el)
174
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
175

    
176
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
177
  match instr with 
178
  | MReset i ->
179
    pp_machine_reset m self fmt i
180
  | MLocalAssign (i,v) ->
181
    pp_assign
182
      m self (pp_c_var_read m) fmt
183
      i.var_type (LocalVar i) v
184
  | MStateAssign (i,v) ->
185
    pp_assign
186
      m self (pp_c_var_read m) fmt
187
      i.var_type (StateVar i) v
188
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
189
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
190
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
191
    fprintf fmt "%a = %s(%a);" 
192
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
193
      i
194
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
195
  | MStep (il, i, vl) ->
196
    pp_instance_call m self fmt i vl il
197
  | MBranch (g,hl) ->
198
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
199
    then (* boolean case, needs special treatment in C because truth value is not unique *)
200
	 (* may disappear if we optimize code by replacing last branch test with default *)
201
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
202
      let el = try List.assoc tag_false hl with Not_found -> [] in
203
      pp_conditional dependencies m self fmt g tl el
204
    else (* enum type case *)
205
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
206
	(pp_c_val self (pp_c_var_read m)) g
207
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
208

    
209
and pp_machine_branch dependencies m self fmt (t, h) =
210
  fprintf fmt "@[<v 2>case %a:@,%a@,break;@]" pp_c_tag t (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
211

    
212

    
213
(********************************************************************************************)
214
(*                         C file Printing functions                                        *)
215
(********************************************************************************************)
216

    
217
let print_const_def fmt cdecl =
218
  fprintf fmt "%a = %a;@." 
219
    (pp_c_type cdecl.const_id) cdecl.const_type
220
    pp_c_const cdecl.const_value 
221

    
222

    
223
let print_alloc_instance fmt (i, (m, static)) =
224
  fprintf fmt "_alloc->%s = %a (%a);@,"
225
    i
226
    pp_machine_alloc_name (node_name m)
227
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
228

    
229
let print_alloc_array fmt vdecl =
230
  let base_type = Types.array_base_type vdecl.var_type in
231
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
232
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
233
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
234
    vdecl.var_id
235
    (pp_c_type "") base_type
236
    Dimension.pp_dimension size_type
237
    (pp_c_type "") base_type
238
    vdecl.var_id
239

    
240
let print_alloc_code fmt m =
241
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
242
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
243
    pp_machine_memtype_name m.mname.node_id
244
    pp_machine_memtype_name m.mname.node_id
245
    pp_machine_memtype_name m.mname.node_id
246
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
247
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
248

    
249
let print_stateless_code dependencies fmt m =
250
  let self = "__ERROR__" in
251
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
252
  then
253
    (* C99 code *)
254
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
255
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
256
      (* locals *)
257
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
258
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
259
      (* check assertions *)
260
      (pp_c_checks self) m
261
      (* instrs *)
262
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
263
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
264
      (fun fmt -> fprintf fmt "return;")
265
  else
266
    (* C90 code *)
267
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
268
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
269
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
270
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
271
      (* locals *)
272
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
273
      (Utils.pp_final_char_if_non_empty ";" base_locals)
274
      (* check assertions *)
275
      (pp_c_checks self) m
276
      (* instrs *)
277
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
278
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
279
      (fun fmt -> fprintf fmt "return;")
280

    
281
let print_reset_code dependencies fmt m self =
282
  fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
283
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
284
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
285
    (Utils.pp_newline_if_non_empty m.minit)
286

    
287
let print_step_code dependencies fmt m self =
288
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc })
289
  then
290
    (* C99 code *)
291
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
292
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
293
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
294
      (* locals *)
295
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
296
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
297
      (* array mems *)
298
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
299
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
300
      (* check assertions *)
301
      (pp_c_checks self) m
302
      (* instrs *)
303
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
304
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
305
      (fun fmt -> fprintf fmt "return;")
306
  else
307
    (* C90 code *)
308
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
309
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
310
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
311
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
312
      (* locals *)
313
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
314
      (Utils.pp_final_char_if_non_empty ";" base_locals)
315
      (* check assertions *)
316
      (pp_c_checks self) m
317
      (* instrs *)
318
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
319
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
320
      (fun fmt -> fprintf fmt "return;")
321

    
322

    
323
(********************************************************************************************)
324
(*                     MAIN C file Printing functions                                       *)
325
(********************************************************************************************)
326

    
327
let print_machine dependencies fmt m =
328
  if fst (get_stateless_status m) then
329
    begin
330
      (* Step function *)
331
      print_stateless_code dependencies fmt m
332
    end
333
  else
334
    begin
335
      (* Alloc function, only if non static mode *)
336
      if (not !Options.static_mem) then  
337
	(
338
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
339
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
340
	    print_alloc_code m;
341
	);
342
      let self = mk_self m in
343
      (* Reset function *)
344
      print_reset_code dependencies fmt m self;
345
      (* Step function *)
346
      print_step_code dependencies fmt m self
347
    end
348

    
349

    
350

    
351

    
352
let print_c source_fmt basename prog machines dependencies =
353

    
354
  (* If a main node is identified, generate a main function for it *)
355
  let main_include, main_print =
356
    match !Options.main_node with
357
      | "" -> (fun _ -> ()), (fun _ -> ())
358
      | main_node -> (
359
	match Machine_code.get_machine_opt main_node machines with
360
	| None -> (
361
	  eprintf "Unable to find a main node named %s@.@?" main_node; 
362
	  (fun _ -> ()), (fun _ -> ())
363
	)
364
	| Some m -> 
365
	  C_backend_main.print_main_header, C_backend_main.print_main_fun machines m
366
      )
367
  in
368
  main_include source_fmt;
369
  fprintf source_fmt "#include <stdlib.h>@.#include <assert.h>@.#include \"%s\"@.@." (basename^".h");
370
  (* Print the svn version number and the supported C standard (C90 or C99) *)
371
  print_version source_fmt;
372
  (* Print the prototype of imported nodes *)
373
  fprintf source_fmt "/* Imported nodes declarations */@.";
374
  fprintf source_fmt "@[<v>";
375
  List.iter (print_import_prototype source_fmt) dependencies;
376
  fprintf source_fmt "@]@.";
377
  (* Print consts *)
378
  fprintf source_fmt "/* Global constants (definitions) */@.";
379
  List.iter (fun c -> print_const_def source_fmt c) (get_consts prog);
380
  pp_print_newline source_fmt ();
381
  (* Print nodes one by one (in the previous order) *)
382
  List.iter (print_machine dependencies source_fmt) machines;
383
  main_print source_fmt
384
end
385

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