Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

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

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

    
48
let rec merge_static_loop_profiles lp1 lp2 =
49
  match lp1, lp2 with
50
  | []      , _        -> lp2
51
  | _       , []       -> lp1
52
  | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
53

    
54
(* Returns a list of bool values, indicating whether the indices must be static or not *)
55
let rec static_loop_profile v =
56
 match v with
57
 | Cst (Const_array cl) ->
58
   List.fold_right (fun c lp -> merge_static_loop_profiles lp (static_loop_profile (Cst c))) cl []
59
 | Cst _
60
 | LocalVar _
61
 | StateVar _  -> []
62
 | Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
63
 | Array vl    -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
64
 | Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
65
 | Power (v, n)  -> false :: static_loop_profile v
66

    
67
let rec is_const_index v =
68
  match v with
69
  | Cst (Const_int _) -> true
70
  | Fun (_, vl)       -> List.for_all is_const_index vl
71
  | _                 -> false
72

    
73
type loop_index = LVar of ident | LInt of int ref | LAcc of value_t
74
(*
75
let rec value_offsets v offsets =
76
 match v, offsets with
77
 | _                        , []          -> v
78
 | Power (v, n)             , _ :: q      -> value_offsets v q
79
 | Array vl                 , LInt r :: q -> value_offsets (List.nth vl !r) q
80
 | Cst (Const_array cl)     , LInt r :: q -> value_offsets (Cst (List.nth cl !r)) q
81
 | Fun (f, vl)              , _           -> Fun (f, List.map (fun v -> value_offsets v offsets) vl)
82
 | _                        , LInt r :: q -> value_offsets (Access (v, Cst (Const_int !r))) q
83
 | _                        , LVar i :: q -> value_offsets (Access (v, LocalVar i)) q
84
*)
85
(* Computes the list of nested loop variables together with their dimension bounds.
86
   - LInt r stands for loop expansion (no loop variable, but int loop index)
87
   - LVar v stands for loop variable v
88
*)
89
let rec mk_loop_variables m ty depth =
90
 match (Types.repr ty).Types.tdesc, depth with
91
 | Types.Tarray (d, ty'), 0       ->
92
   let v = mk_loop_var m () in
93
   (d, LVar v) :: mk_loop_variables m ty' 0
94
 | Types.Tarray (d, ty'), _       ->
95
   let r = ref (-1) in
96
   (d, LInt r) :: mk_loop_variables m ty' (depth - 1)
97
 | _                    , 0       -> []
98
 | _                              -> assert false
99

    
100
let reorder_loop_variables loop_vars =
101
  let (int_loops, var_loops) = 
102
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
103
  in
104
  var_loops @ int_loops
105

    
106
(* Prints a one loop variable suffix for arrays *)
107
let pp_loop_var fmt lv =
108
 match snd lv with
109
 | LVar v -> fprintf fmt "[%s]" v
110
 | LInt r -> fprintf fmt "[%d]" !r
111
 | LAcc i -> fprintf fmt "[%a]" pp_c_dimension (dimension_of_value i)
112

    
113
(* Prints a suffix of loop variables for arrays *)
114
let pp_suffix fmt loop_vars =
115
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
116

    
117
(* Prints a value expression [v], with internal function calls only.
118
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
119
   but an offset suffix may be added for array variables
120
*)
121
(* Prints a constant value before a suffix (needs casting) *)
122
let rec pp_c_const_suffix var_type fmt c =
123
  match c with
124
    | Const_int i     -> pp_print_int fmt i
125
    | Const_real r    -> pp_print_string fmt r
126
    | Const_float r   -> pp_print_float fmt r
127
    | Const_tag t     -> pp_c_tag fmt t
128
    | Const_array ca  -> let var_type = Types.array_element_type var_type in
129
                         fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
130
    | Const_struct fl -> fprintf fmt "{%a }" (Utils.fprintf_list ~sep:", " (fun fmt (f, c) -> (pp_c_const_suffix (Types.struct_field_type var_type f)) fmt c)) fl
131
    | Const_string _ -> assert false (* string occurs in annotations not in C *)
132

    
133

    
134
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
135
let rec pp_value_suffix self var_type loop_vars pp_value fmt value =
136
(*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
137
 match loop_vars, value with
138
 | (x, LAcc i) :: q, _ when is_const_index i ->
139
   let r = ref (Dimension.size_const_dimension (Machine_code.dimension_of_value i)) in
140
   pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
141
 | (_, LInt r) :: q, Cst (Const_array cl) ->
142
   let var_type = Types.array_element_type var_type in
143
   pp_value_suffix self var_type q pp_value fmt (Cst (List.nth cl !r))
144
 | (_, LInt r) :: q, Array vl      ->
145
   let var_type = Types.array_element_type var_type in
146
   pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
147
 | loop_var    :: q, Array vl      ->
148
   let var_type = Types.array_element_type var_type in
149
   Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type q pp_value)) vl pp_suffix [loop_var]
150
 | []              , Array vl      ->
151
   let var_type = Types.array_element_type var_type in
152
   Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
153
 | _           :: q, Power (v, n)  ->
154
   pp_value_suffix self var_type q pp_value fmt v
155
 | _               , Fun (n, vl)   ->
156
   Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
157
 | _               , Access (v, i) ->
158
   let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
159
   pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
160
 | _               , LocalVar v    -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
161
 | _               , StateVar v    ->
162
    (* array memory vars are represented by an indirection to a local var with the right type,
163
       in order to avoid casting everywhere. *)
164
   if Types.is_array_type v.var_type
165
   then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
166
   else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
167
 | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst
168
 | _               , _             -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars; assert false)
169

    
170
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
171
   which may yield constant arrays in expressions.
172
   Type is needed to correctly print constant arrays.
173
 *)
174
let pp_c_val self pp_var fmt (t, v) =
175
  pp_value_suffix self t [] pp_var fmt v
176

    
177
(* type_directed assignment: array vs. statically sized type
178
   - [var_type]: type of variable to be assigned
179
   - [var_name]: name of variable to be assigned
180
   - [value]: assigned value
181
   - [pp_var]: printer for variables
182
*)
183
(*
184
let pp_assign_rec pp_var var_type var_name value =
185
  match (Types.repr var_type).Types.tdesc, value with
186
  | Types.Tarray (d, ty'), Array vl     ->
187
    let szl = Utils.enumerate (Dimension.size_const_dimension d) in
188
    fprintf fmt "@[<v 2>{@,%a@]@,}"
189
      (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
190
  | Types.Tarray (d, ty'), Power (v, _) -> 
191
  | Types.Tarray (d, ty'), _            ->
192
  | _                    , _            ->
193
    fprintf fmt "%a = %a;" 
194
      pp_var var_name
195
      (pp_value_suffix self loop_vars pp_var) value
196
*)
197
let pp_assign m self pp_var fmt var_type var_name value =
198
  let depth = expansion_depth value in
199
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
200
  let loop_vars = mk_loop_variables m var_type depth in
201
  let reordered_loop_vars = reorder_loop_variables loop_vars in
202
  let rec aux fmt vars =
203
    match vars with
204
    | [] ->
205
      fprintf fmt "%a = %a;" 
206
	(pp_value_suffix self var_type loop_vars pp_var) var_name
207
	(pp_value_suffix self var_type loop_vars pp_var) value
208
    | (d, LVar i) :: q ->
209
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
210
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
211
	i i i Dimension.pp_dimension d i
212
	aux q
213
    | (d, LInt r) :: q ->
214
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
215
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
216
      fprintf fmt "@[<v 2>{@,%a@]@,}"
217
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
218
    | _ -> assert false
219
  in
220
  begin
221
    reset_loop_counter ();
222
    (*reset_addr_counter ();*)
223
    aux fmt reordered_loop_vars
224
  end
225

    
226
let has_c_prototype funname dependencies =
227
  let imported_node_opt = (* We select the last imported node with the name funname.
228
			       The order of evaluation of dependencies should be
229
			       compatible with overloading. (Not checked yet) *) 
230
      List.fold_left
231
	(fun res (Dep (_, _, decls, _)) -> 
232
	  match res with
233
	  | Some _ -> res
234
	  | None -> 
235
	    let matched = fun t -> match t.top_decl_desc with 
236
	      | ImportedNode nd -> nd.nodei_id = funname 
237
	      | _ -> false
238
	    in
239
	    if List.exists matched decls then (
240
	      match (List.find matched decls).top_decl_desc with
241
	      | ImportedNode nd -> Some nd
242
	      | _ -> assert false
243
	    )
244
	    else
245
	      None
246
	) None dependencies in
247
    match imported_node_opt with
248
    | None -> false
249
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
250

    
251
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) =
252
  try (* stateful node instance *)
253
    let (n,_) = List.assoc i m.minstances in
254
    let (input_types, _) = Typing.get_type_of_call n in
255
    let inputs = List.combine input_types inputs in
256
    fprintf fmt "%a (%a%t%a%t%s->%s);"
257
      pp_machine_step_name (node_name n)
258
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
259
      (Utils.pp_final_char_if_non_empty ", " inputs) 
260
      (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
261
      (Utils.pp_final_char_if_non_empty ", " outputs)
262
      self
263
      i
264
  with Not_found -> (* stateless node instance *)
265
    let (n,_) = List.assoc i m.mcalls in
266
    let (input_types, output_types) = Typing.get_type_of_call n in
267
    let inputs = List.combine input_types inputs in
268
    if has_c_prototype i dependencies
269
    then (* external C function *)
270
      let outputs = List.map2 (fun t v -> t, LocalVar v) output_types outputs in
271
      fprintf fmt "%a = %s(%a);"
272
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs
273
	i
274
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
275
    else
276
      fprintf fmt "%a (%a%t%a);"
277
	pp_machine_step_name (node_name n)
278
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
279
	(Utils.pp_final_char_if_non_empty ", " inputs) 
280
	(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
281

    
282
let pp_machine_reset (m: machine_t) self fmt inst =
283
  let (node, static) =
284
    try
285
      List.assoc inst m.minstances
286
    with Not_found -> (Format.eprintf "pp_machine_reset %s %s %s: internal error@," m.mname.node_id self inst; raise Not_found) in
287
  fprintf fmt "%a(%a%t%s->%s);"
288
    pp_machine_reset_name (node_name node)
289
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
290
    (Utils.pp_final_char_if_non_empty ", " static)
291
    self inst
292

    
293
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
294
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
295
    (pp_c_val self (pp_c_var_read m)) (Type_predef.type_bool, c)
296
    (Utils.pp_newline_if_non_empty tl)
297
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
298
    (Utils.pp_newline_if_non_empty el)
299
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
300

    
301
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
302
  match instr with 
303
  | MReset i ->
304
    pp_machine_reset m self fmt i
305
  | MLocalAssign (i,v) ->
306
    pp_assign
307
      m self (pp_c_var_read m) fmt
308
      i.var_type (LocalVar i) v
309
  | MStateAssign (i,v) ->
310
    pp_assign
311
      m self (pp_c_var_read m) fmt
312
      i.var_type (StateVar i) v
313
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
314
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
315
  | MStep (il, i, vl) ->
316
    pp_instance_call dependencies m self fmt i vl il
317
  | MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false)
318
  | MBranch (g, hl) ->
319
    if let t = fst (List.hd hl) in t = tag_true || t = tag_false
320
    then (* boolean case, needs special treatment in C because truth value is not unique *)
321
	 (* may disappear if we optimize code by replacing last branch test with default *)
322
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
323
      let el = try List.assoc tag_false hl with Not_found -> [] in
324
      pp_conditional dependencies m self fmt g tl el
325
    else (* enum type case *)
326
      let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in
327
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
328
	(pp_c_val self (pp_c_var_read m)) (g_typ, g)
329
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
330

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

    
334

    
335
(********************************************************************************************)
336
(*                         C file Printing functions                                        *)
337
(********************************************************************************************)
338

    
339
let print_const_def fmt cdecl =
340
  fprintf fmt "%a = %a;@." 
341
    (pp_c_type cdecl.const_id) cdecl.const_type
342
    pp_c_const cdecl.const_value 
343

    
344

    
345
let print_alloc_instance fmt (i, (m, static)) =
346
  fprintf fmt "_alloc->%s = %a (%a);@,"
347
    i
348
    pp_machine_alloc_name (node_name m)
349
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
350

    
351
let print_alloc_const fmt m =
352
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
353
  fprintf fmt "%a%t"
354
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
355
    (Utils.pp_final_char_if_non_empty ";@," const_locals)
356

    
357
let print_alloc_array fmt vdecl =
358
  let base_type = Types.array_base_type vdecl.var_type in
359
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
360
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
361
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
362
    vdecl.var_id
363
    (pp_c_type "") base_type
364
    Dimension.pp_dimension size_type
365
    (pp_c_type "") base_type
366
    vdecl.var_id
367

    
368
let print_alloc_code fmt m =
369
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
370
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
371
    pp_machine_memtype_name m.mname.node_id
372
    pp_machine_memtype_name m.mname.node_id
373
    pp_machine_memtype_name m.mname.node_id
374
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
375
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
376

    
377
let print_stateless_code dependencies fmt m =
378
  let self = "__ERROR__" in
379
  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 })
380
  then
381
    (* C99 code *)
382
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
383
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
384
      (* locals *)
385
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
386
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
387
      (* check assertions *)
388
      (pp_c_checks self) m
389
      (* instrs *)
390
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
391
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
392
      (fun fmt -> fprintf fmt "return;")
393
  else
394
    (* C90 code *)
395
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
396
    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
397
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
398
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
399
      (* locals *)
400
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
401
      (Utils.pp_final_char_if_non_empty ";" base_locals)
402
      (* check assertions *)
403
      (pp_c_checks self) m
404
      (* instrs *)
405
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
406
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
407
      (fun fmt -> fprintf fmt "return;")
408

    
409
let print_reset_code dependencies fmt m self =
410
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
411
  fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@."
412
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
413
    (* constant locals decl *)
414
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
415
    (Utils.pp_final_char_if_non_empty ";" const_locals)
416
    (* instrs *)
417
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
418
    (Utils.pp_newline_if_non_empty m.minit)
419

    
420
let print_step_code dependencies fmt m self =
421
  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 })
422
  then
423
    (* C99 code *)
424
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
425
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%t@]@,}@.@."
426
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
427
      (* locals *)
428
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
429
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
430
      (* array mems *)
431
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
432
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
433
      (* check assertions *)
434
      (pp_c_checks self) m
435
      (* instrs *)
436
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
437
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
438
      (fun fmt -> fprintf fmt "return;")
439
  else
440
    (* C90 code *)
441
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
442
    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
443
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
444
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
445
      (* locals *)
446
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
447
      (Utils.pp_final_char_if_non_empty ";" base_locals)
448
      (* check assertions *)
449
      (pp_c_checks self) m
450
      (* instrs *)
451
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
452
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
453
      (fun fmt -> fprintf fmt "return;")
454

    
455

    
456
(********************************************************************************************)
457
(*                     MAIN C file Printing functions                                       *)
458
(********************************************************************************************)
459

    
460
let print_machine dependencies fmt m =
461
  if fst (get_stateless_status m) then
462
    begin
463
      (* Step function *)
464
      print_stateless_code dependencies fmt m
465
    end
466
  else
467
    begin
468
      (* Alloc function, only if non static mode *)
469
      if (not !Options.static_mem) then  
470
	begin
471
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
472
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
473
	    print_alloc_const m
474
	    print_alloc_code m;
475
	end;
476
      let self = mk_self m in
477
      (* Reset function *)
478
      print_reset_code dependencies fmt m self;
479
      (* Step function *)
480
      print_step_code dependencies fmt m self
481
    end
482

    
483

    
484
let print_lib_c source_fmt basename prog machines dependencies =
485

    
486
  fprintf source_fmt "#include <assert.h>@.";
487
  if not !Options.static_mem then
488
    begin
489
      fprintf source_fmt "#include <stdlib.h>@.";
490
    end;
491
  print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
492
  pp_print_newline source_fmt ();
493
  (* Print the svn version number and the supported C standard (C90 or C99) *)
494
  print_version source_fmt;
495
  (* Print the prototype of imported nodes *)
496
  fprintf source_fmt "/* Import dependencies */@.";
497
  fprintf source_fmt "@[<v>";
498
  List.iter (print_import_prototype source_fmt) dependencies;
499
  fprintf source_fmt "@]@.";
500
  (* Print consts *)
501
  fprintf source_fmt "/* Global constants (definitions) */@.";
502
  fprintf source_fmt "@[<v>";
503
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
504
  fprintf source_fmt "@]@.";
505

    
506
  if not !Options.static_mem then
507
    begin
508
      fprintf source_fmt "/* External allocation function prototypes */@.";
509
      fprintf source_fmt "@[<v>";
510
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
511
      fprintf source_fmt "@]@.";
512
      fprintf source_fmt "/* Node allocation function prototypes */@.";
513
      fprintf source_fmt "@[<v>";
514
      List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
515
      fprintf source_fmt "@]@.";
516
    end;
517

    
518
  (* Print the struct definitions of all machines. *)
519
  fprintf source_fmt "/* Struct definitions */@.";
520
  fprintf source_fmt "@[<v>";
521
  List.iter (print_machine_struct source_fmt) machines;
522
  fprintf source_fmt "@]@.";
523
  pp_print_newline source_fmt ();
524
  (* Print nodes one by one (in the previous order) *)
525
  List.iter (print_machine dependencies source_fmt) machines;
526
 end
527

    
528
(* Local Variables: *)
529
(* compile-command:"make -C ../../.." *)
530
(* End: *)