Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (16.8 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
open C_backend_common
17

    
18
module type MODIFIERS_SRC =
19
sig
20
end
21

    
22
module EmptyMod =
23
struct
24
end
25

    
26
module Main = functor (Mod: MODIFIERS_SRC) -> 
27
struct
28

    
29
(********************************************************************************************)
30
(*                    Instruction Printing functions                                        *)
31
(********************************************************************************************)
32

    
33
(* Computes the depth to which multi-dimension array assignments should be expanded.
34
   It equals the maximum number of nested static array constructions accessible from root [v].
35
*)
36
let rec expansion_depth v =
37
 match v with
38
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
39
 | Cst _
40
 | LocalVar _
41
 | StateVar _  -> 0
42
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
43
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
44
 | Access (v, i) -> max 0 (expansion_depth v - 1)
45
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
46

    
47
type loop_index = LVar of ident | LInt of int ref
48

    
49
(* Computes the list of nested loop variables together with their dimension bounds.
50
   - LInt r stands for loop expansion (no loop variable, but int loop index)
51
   - LVar v stands for loop variable v
52
*)
53
let rec mk_loop_variables m ty depth =
54
 match (Types.repr ty).Types.tdesc, depth with
55
 | Types.Tarray (d, ty'), 0       ->
56
   let v = mk_loop_var m () in
57
   (d, LVar v) :: mk_loop_variables m ty' 0
58
 | Types.Tarray (d, ty'), _       ->
59
   let r = ref (-1) in
60
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
61
 | _                    , 0       -> []
62
 | _                              -> assert false
63

    
64
let reorder_loop_variables loop_vars =
65
  let (int_loops, var_loops) = 
66
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
67
  in
68
  var_loops @ int_loops
69
    
70
(* Prints a one loop variable suffix for arrays *)
71
let pp_loop_var fmt lv =
72
 match snd lv with
73
 | LVar v -> fprintf fmt "[%s]" v
74
 | LInt r -> fprintf fmt "[%d]" !r
75

    
76
(* Prints a suffix of loop variables for arrays *)
77
let pp_suffix fmt loop_vars =
78
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
79

    
80
(* Prints a [value] indexed by the suffix list [loop_vars] *)
81
let rec pp_value_suffix self loop_vars pp_value fmt value =
82
 match loop_vars, value with
83
 | (_, LInt r) :: q, Array vl     ->
84
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
85
 | _           :: q, Power (v, n) ->
86
   pp_value_suffix self loop_vars pp_value fmt v
87
 | _               , Fun (n, vl)  ->
88
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
89
 | _               , _            ->
90
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
91
   pp_c_val self pp_var_suffix fmt value
92

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

    
127
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
128
 try (* stateful node instance *)
129
   let (n,_) = List.assoc i m.minstances in
130
   fprintf fmt "%a (%a%t%a%t%s->%s);"
131
     pp_machine_step_name (node_name n)
132
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
133
     (Utils.pp_final_char_if_non_empty ", " inputs) 
134
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
135
     (Utils.pp_final_char_if_non_empty ", " outputs)
136
     self
137
     i
138
 with Not_found -> (* stateless node instance *)
139
   let (n,_) = List.assoc i m.mcalls in
140
   fprintf fmt "%a (%a%t%a);"
141
     pp_machine_step_name (node_name n)
142
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
143
     (Utils.pp_final_char_if_non_empty ", " inputs) 
144
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
145

    
146
let pp_machine_reset (m: machine_t) self fmt inst =
147
  let (node, static) =
148
    try
149
      List.assoc inst m.minstances
150
    with Not_found -> (Format.eprintf "pp_machine_reset %s %s %s: internal error@," m.mname.node_id self inst; raise Not_found) in
151
  fprintf fmt "%a(%a%t%s->%s);"
152
    pp_machine_reset_name (node_name node)
153
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
154
    (Utils.pp_final_char_if_non_empty ", " static)
155
    self inst
156

    
157
let has_c_prototype funname dependencies =
158
  let imported_node_opt = (* We select the last imported node with the name funname.
159
			       The order of evaluation of dependencies should be
160
			       compatible with overloading. (Not checked yet) *) 
161
      List.fold_left
162
	(fun res (_, _, decls) -> 
163
	  match res with
164
	  | Some _ -> res
165
	  | None -> 
166
	    let matched = fun t -> match t.top_decl_desc with 
167
	      | ImportedNode nd -> nd.nodei_id = funname 
168
	      | _ -> false
169
	    in
170
	    if List.exists matched decls then (
171
	      match (List.find matched decls).top_decl_desc with
172
	      | ImportedNode nd -> Some nd
173
	      | _ -> assert false
174
	    )
175
	    else
176
	      None
177
	) None dependencies in
178
    match imported_node_opt with
179
    | None -> false
180
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
181

    
182
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
183
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
184
    (pp_c_val self (pp_c_var_read m)) c
185
    (Utils.pp_newline_if_non_empty tl)
186
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
187
    (Utils.pp_newline_if_non_empty el)
188
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
189

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

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

    
226

    
227
(********************************************************************************************)
228
(*                         C file Printing functions                                        *)
229
(********************************************************************************************)
230

    
231
let print_const_def fmt cdecl =
232
  fprintf fmt "%a = %a;@." 
233
    (pp_c_type cdecl.const_id) cdecl.const_type
234
    pp_c_const cdecl.const_value 
235

    
236

    
237
let print_alloc_instance fmt (i, (m, static)) =
238
  fprintf fmt "_alloc->%s = %a (%a);@,"
239
    i
240
    pp_machine_alloc_name (node_name m)
241
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
242

    
243
let print_alloc_array fmt vdecl =
244
  let base_type = Types.array_base_type vdecl.var_type in
245
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
246
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
247
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
248
    vdecl.var_id
249
    (pp_c_type "") base_type
250
    Dimension.pp_dimension size_type
251
    (pp_c_type "") base_type
252
    vdecl.var_id
253

    
254
let print_alloc_code fmt m =
255
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
256
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
257
    pp_machine_memtype_name m.mname.node_id
258
    pp_machine_memtype_name m.mname.node_id
259
    pp_machine_memtype_name m.mname.node_id
260
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
261
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
262

    
263
let print_stateless_code dependencies fmt m =
264
  let self = "__ERROR__" in
265
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
266
  then
267
    (* C99 code *)
268
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
269
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
270
      (* locals *)
271
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
272
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
273
      (* check assertions *)
274
      (pp_c_checks self) m
275
      (* instrs *)
276
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
277
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
278
      (fun fmt -> fprintf fmt "return;")
279
  else
280
    (* C90 code *)
281
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
282
    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
283
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
284
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
285
      (* locals *)
286
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
287
      (Utils.pp_final_char_if_non_empty ";" base_locals)
288
      (* check assertions *)
289
      (pp_c_checks self) m
290
      (* instrs *)
291
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
292
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
293
      (fun fmt -> fprintf fmt "return;")
294

    
295
let print_reset_code dependencies fmt m self =
296
  fprintf fmt "@[<v 2>%a {@,%a%treturn;@]@,}@.@."
297
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
298
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
299
    (Utils.pp_newline_if_non_empty m.minit)
300

    
301
let print_step_code dependencies fmt m self =
302
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
303
  then
304
    (* C99 code *)
305
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
306
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
307
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
308
      (* locals *)
309
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) m.mstep.step_locals
310
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
311
      (* array mems *)
312
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
313
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
314
      (* check assertions *)
315
      (pp_c_checks self) m
316
      (* instrs *)
317
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
318
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
319
      (fun fmt -> fprintf fmt "return;")
320
  else
321
    (* C90 code *)
322
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
323
    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
324
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
325
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
326
      (* locals *)
327
      (Utils.fprintf_list ~sep:";@," pp_c_decl_local_var) base_locals
328
      (Utils.pp_final_char_if_non_empty ";" base_locals)
329
      (* check assertions *)
330
      (pp_c_checks self) m
331
      (* instrs *)
332
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
333
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
334
      (fun fmt -> fprintf fmt "return;")
335

    
336

    
337
(********************************************************************************************)
338
(*                     MAIN C file Printing functions                                       *)
339
(********************************************************************************************)
340

    
341
let print_machine dependencies fmt m =
342
  if fst (get_stateless_status m) then
343
    begin
344
      (* Step function *)
345
      print_stateless_code dependencies fmt m
346
    end
347
  else
348
    begin
349
      (* Alloc function, only if non static mode *)
350
      if (not !Options.static_mem) then  
351
	begin
352
	  fprintf fmt "@[<v 2>%a {@,%a@]@,}@.@."
353
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
354
	    print_alloc_code m;
355
	end;
356
      let self = mk_self m in
357
      (* Reset function *)
358
      print_reset_code dependencies fmt m self;
359
      (* Step function *)
360
      print_step_code dependencies fmt m self
361
    end
362

    
363

    
364
let print_lib_c source_fmt basename prog machines dependencies =
365

    
366
  fprintf source_fmt "#include <assert.h>@.";
367
  if not !Options.static_mem then
368
    begin
369
      fprintf source_fmt "#include <stdlib.h>@.";
370
    end;
371
  print_import_prototype source_fmt (true, basename, []);
372
  pp_print_newline source_fmt ();
373
  (* Print the svn version number and the supported C standard (C90 or C99) *)
374
  print_version source_fmt;
375
  (* Print the prototype of imported nodes *)
376
  fprintf source_fmt "/* Import dependencies */@.";
377
  fprintf source_fmt "@[<v>";
378
  List.iter (print_import_prototype source_fmt) dependencies;
379
  fprintf source_fmt "@]@.";
380
  (* Print consts *)
381
  fprintf source_fmt "/* Global constants (definitions) */@.";
382
  fprintf source_fmt "@[<v>";
383
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
384
  fprintf source_fmt "@]@.";
385
  if not !Options.static_mem then
386
    begin
387
      fprintf source_fmt "/* External allocation function prototypes */@.";
388
      fprintf source_fmt "@[<v>";
389
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
390
      fprintf source_fmt "@]@.";
391
      fprintf source_fmt "/* Node allocation function prototypes */@.";
392
      fprintf source_fmt "@[<v>";
393
      List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
394
      fprintf source_fmt "@]@.";
395
    end;
396
  (* Print the struct definitions of all machines. *)
397
  fprintf source_fmt "/* Struct definitions */@.";
398
  fprintf source_fmt "@[<v>";
399
  List.iter (print_machine_struct source_fmt) machines;
400
  fprintf source_fmt "@]@.";
401
  pp_print_newline source_fmt ();
402
  (* Print nodes one by one (in the previous order) *)
403
  List.iter (print_machine dependencies source_fmt) machines;
404
 end
405

    
406
(* Local Variables: *)
407
(* compile-command:"make -C ../../.." *)
408
(* End: *)