Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (23.5 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.value_desc with
38
    | Cst cst -> expansion_depth_cst cst
39
    | LocalVar _
40
    | StateVar _  -> 0
41
    | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
42
    | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
43
    | Access (v, i) -> max 0 (expansion_depth v - 1)
44
    | Power (v, n)  -> 0 (*1 + expansion_depth v*)
45
  and expansion_depth_cst c = 
46
    match c with
47
      Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
48
    | _ -> 0
49
  
50
  let rec merge_static_loop_profiles lp1 lp2 =
51
    match lp1, lp2 with
52
    | []      , _        -> lp2
53
    | _       , []       -> lp1
54
    | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
55

    
56
(* Returns a list of bool values, indicating whether the indices must be static or not *)
57
  let rec static_loop_profile v =
58
    match v.value_desc with
59
    | Cst cst  -> static_loop_profile_cst 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
  and static_loop_profile_cst cst =
67
    match cst with
68
      Const_array cl -> List.fold_right 
69
	(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c))
70
	cl 
71
	[]
72
    | _ -> [] 
73
  
74
  
75
let rec is_const_index v =
76
  match v.value_desc with
77
  | Cst (Const_int _) -> true
78
  | Fun (_, vl)       -> List.for_all is_const_index vl
79
  | _                 -> false
80

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

    
108
let reorder_loop_variables loop_vars =
109
  let (int_loops, var_loops) = 
110
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
111
  in
112
  var_loops @ int_loops
113

    
114
(* Prints a one loop variable suffix for arrays *)
115
let pp_loop_var fmt lv =
116
 match snd lv with
117
 | LVar v -> fprintf fmt "[%s]" v
118
 | LInt r -> fprintf fmt "[%d]" !r
119
 | LAcc i -> fprintf fmt "[%a]" pp_c_dimension (dimension_of_value i)
120

    
121
(* Prints a suffix of loop variables for arrays *)
122
let pp_suffix fmt loop_vars =
123
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
124

    
125
(* Prints a [value] indexed by the suffix list [loop_vars] *)
126
let rec pp_value_suffix self loop_vars pp_value fmt value =
127
 match loop_vars, value.value_desc with
128
 | (_, LInt r) :: q, Array vl      ->
129
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
130
 | _           :: q, Power (v, n)  ->
131
   pp_value_suffix self q pp_value fmt v
132
 | _               , Fun (n, vl)   ->
133
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
134
 | _               , Access (v, i) ->
135
   pp_value_suffix self ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
136
 | _               , _             ->
137
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
138
   pp_c_val self pp_var_suffix fmt value
139

    
140
let pp_basic_assign pp_var fmt typ var_name value =
141
  if Types.is_real_type typ && !Options.mpfr
142
  then
143
    Mpfr.pp_inject_assign pp_var fmt var_name value
144
  else
145
    fprintf fmt "%a = %a;" 
146
      pp_var var_name
147
      pp_var value
148

    
149
(* type_directed assignment: array vs. statically sized type
150
   - [var_type]: type of variable to be assigned
151
   - [var_name]: name of variable to be assigned
152
   - [value]: assigned value
153
   - [pp_var]: printer for variables
154
*)
155
let pp_assign m self pp_var fmt var_type var_name value =
156
  let depth = expansion_depth value in
157
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val var_name depth;*)
158
  let loop_vars = mk_loop_variables m var_type depth in
159
  let reordered_loop_vars = reorder_loop_variables loop_vars in
160
  let rec aux typ fmt vars =
161
    match vars with
162
    | [] ->
163
       pp_basic_assign (pp_value_suffix self loop_vars pp_var) fmt typ var_name value
164
    | (d, LVar i) :: q ->
165
       let typ' = Types.array_element_type typ in
166
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
167
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
168
	i i i pp_c_dimension d i
169
	(aux typ') q
170
    | (d, LInt r) :: q ->
171
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
172
       let typ' = Types.array_element_type typ in
173
       let szl = Utils.enumerate (Dimension.size_const_dimension d) in
174
       fprintf fmt "@[<v 2>{@,%a@]@,}"
175
	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
176
    | _ -> assert false
177
  in
178
  begin
179
    reset_loop_counter ();
180
    (*reset_addr_counter ();*)
181
    aux var_type fmt reordered_loop_vars
182
  end
183

    
184
let pp_machine_reset (m: machine_t) self fmt inst =
185
  let (node, static) =
186
    try
187
      List.assoc inst m.minstances
188
    with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in
189
  fprintf fmt "%a(%a%t%s->%s);"
190
    pp_machine_reset_name (node_name node)
191
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
192
    (Utils.pp_final_char_if_non_empty ", " static)
193
    self inst
194

    
195
let pp_machine_init (m: machine_t) self fmt inst =
196
  let (node, static) =
197
    try
198
      List.assoc inst m.minstances
199
    with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in
200
  fprintf fmt "%a(%a%t%s->%s);"
201
    pp_machine_init_name (node_name node)
202
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
203
    (Utils.pp_final_char_if_non_empty ", " static)
204
    self inst
205

    
206
let pp_machine_clear (m: machine_t) self fmt inst =
207
  let (node, static) =
208
    try
209
      List.assoc inst m.minstances
210
    with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in
211
  fprintf fmt "%a(%a%t%s->%s);"
212
    pp_machine_clear_name (node_name node)
213
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
214
    (Utils.pp_final_char_if_non_empty ", " static)
215
    self inst
216

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

    
242
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
243
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
244
    (pp_c_val self (pp_c_var_read m)) c
245
    (Utils.pp_newline_if_non_empty tl)
246
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
247
    (Utils.pp_newline_if_non_empty el)
248
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
249

    
250
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
251
  match instr with 
252
  | MReset i ->
253
    pp_machine_reset m self fmt i
254
  | MLocalAssign (i,v) ->
255
    pp_assign
256
      m self (pp_c_var_read m) fmt
257
      i.var_type (mk_val (LocalVar i) i.var_type) v
258
  | MStateAssign (i,v) ->
259
    pp_assign
260
      m self (pp_c_var_read m) fmt
261
      i.var_type (mk_val (StateVar i) i.var_type) v
262
  | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type)  ->
263
    pp_machine_instr dependencies m self fmt 
264
      (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type))
265
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
266
    fprintf fmt "%a = %s(%a);" 
267
      (pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type)
268
      i
269
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
270
  | MStep (il, i, vl) when Mpfr.is_homomorphic_fun i ->
271
    pp_instance_call m self fmt i vl il
272
  | MStep (il, i, vl) ->
273
    pp_basic_instance_call m self fmt i vl il
274
  | MBranch (g,hl) ->
275
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
276
    then (* boolean case, needs special treatment in C because truth value is not unique *)
277
      (* may disappear if we optimize code by replacing last branch test with default *)
278
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
279
      let el = try List.assoc tag_false hl with Not_found -> [] in
280
      pp_conditional dependencies m self fmt g tl el
281
    else (* enum type case *)
282
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
283
	(pp_c_val self (pp_c_var_read m)) g
284
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
285
  | MComment s  -> 
286
      fprintf fmt "//%s@ " s
287

    
288

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

    
294

    
295
(********************************************************************************************)
296
(*                         C file Printing functions                                        *)
297
(********************************************************************************************)
298

    
299
let print_const_def fmt cdecl =
300
  fprintf fmt "%a = %a;@." 
301
    (pp_c_type cdecl.const_id) cdecl.const_type
302
    pp_c_const cdecl.const_value 
303

    
304

    
305
let print_alloc_instance fmt (i, (m, static)) =
306
  fprintf fmt "_alloc->%s = %a (%a);@,"
307
    i
308
    pp_machine_alloc_name (node_name m)
309
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
310

    
311
let print_alloc_const fmt m =
312
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
313
  fprintf fmt "%a%t"
314
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
315
    (Utils.pp_final_char_if_non_empty ";@," const_locals)
316

    
317
let print_alloc_array fmt vdecl =
318
  let base_type = Types.array_base_type vdecl.var_type in
319
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
320
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
321
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
322
    vdecl.var_id
323
    (pp_c_type "") base_type
324
    Dimension.pp_dimension size_type
325
    (pp_c_type "") base_type
326
    vdecl.var_id
327

    
328
let print_alloc_code fmt m =
329
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
330
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
331
    pp_machine_memtype_name m.mname.node_id
332
    pp_machine_memtype_name m.mname.node_id
333
    pp_machine_memtype_name m.mname.node_id
334
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
335
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
336

    
337
let print_stateless_code dependencies fmt m =
338
  let self = "__ERROR__" in
339
  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 })
340
  then
341
    (* C99 code *)
342
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
343
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
344
      (* locals *)
345
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
346
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
347
      (* locals initialization *)
348
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
349
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
350
      (* check assertions *)
351
      (pp_c_checks self) m
352
      (* instrs *)
353
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
354
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
355
      (* locals clear *)
356
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
357
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
358
      (fun fmt -> fprintf fmt "return;")
359
  else
360
    (* C90 code *)
361
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
362
    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
363
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
364
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
365
      (* locals *)
366
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
367
      (Utils.pp_final_char_if_non_empty ";" base_locals)
368
      (* locals initialization *)
369
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
370
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
371
      (* check assertions *)
372
      (pp_c_checks self) m
373
      (* instrs *)
374
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
375
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
376
      (* locals clear *)
377
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
378
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
379
      (fun fmt -> fprintf fmt "return;")
380

    
381
let print_reset_code dependencies fmt m self =
382
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
383
  fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@."
384
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
385
    (* constant locals decl *)
386
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
387
    (Utils.pp_final_char_if_non_empty ";" const_locals)
388
    (* instrs *)
389
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
390
    (Utils.pp_newline_if_non_empty m.minit)
391

    
392
let print_init_code dependencies fmt m self =
393
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
394
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
395
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
396
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
397
    (* array mems *) 
398
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
399
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
400
    (* memory initialization *)
401
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
402
    (Utils.pp_newline_if_non_empty m.mmemory)
403
    (* sub-machines initialization *)
404
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
405
    (Utils.pp_newline_if_non_empty m.minit)
406

    
407
let print_clear_code dependencies fmt m self =
408
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
409
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
410
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
411
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
412
    (* array mems *)
413
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
414
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
415
    (* memory clear *)
416
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
417
    (Utils.pp_newline_if_non_empty m.mmemory)
418
    (* sub-machines clear*)
419
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
420
    (Utils.pp_newline_if_non_empty m.minit)
421

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

    
469

    
470
(********************************************************************************************)
471
(*                     MAIN C file Printing functions                                       *)
472
(********************************************************************************************)
473

    
474
let print_machine dependencies fmt m =
475
  if fst (get_stateless_status m) then
476
    begin
477
      (* Step function *)
478
      print_stateless_code dependencies fmt m
479
    end
480
  else
481
    begin
482
      (* Alloc function, only if non static mode *)
483
      if (not !Options.static_mem) then  
484
	begin
485
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
486
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
487
	    print_alloc_const m
488
	    print_alloc_code m;
489
	end;
490
      let self = mk_self m in
491
      (* Reset function *)
492
      print_reset_code dependencies fmt m self;
493
      (* Init function *)
494
      print_init_code dependencies fmt m self;
495
      (* Clear function *)
496
      print_clear_code dependencies fmt m self;
497
      (* Step function *)
498
      print_step_code dependencies fmt m self
499
    end
500

    
501
let print_import_standard source_fmt =
502
  begin
503
    fprintf source_fmt "#include <assert.h>@.";
504
    if not !Options.static_mem then
505
      begin
506
	fprintf source_fmt "#include <stdlib.h>@.";
507
      end;
508
    if !Options.mpfr then
509
      begin
510
	fprintf source_fmt "#include <mpfr.h>@.";
511
      end
512
  end
513

    
514
let print_lib_c source_fmt basename prog machines dependencies =
515
  print_import_standard source_fmt;
516
  print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
517
  pp_print_newline source_fmt ();
518
  (* Print the svn version number and the supported C standard (C90 or C99) *)
519
  print_version source_fmt;
520
  (* Print the prototype of imported nodes *)
521
  fprintf source_fmt "/* Import dependencies */@.";
522
  fprintf source_fmt "@[<v>";
523
  List.iter (print_import_prototype source_fmt) dependencies;
524
  fprintf source_fmt "@]@.";
525
  (* Print consts *)
526
  fprintf source_fmt "/* Global constants (definitions) */@.";
527
  fprintf source_fmt "@[<v>";
528
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
529
  fprintf source_fmt "@]@.";
530

    
531
  if not !Options.static_mem then
532
    begin
533
      fprintf source_fmt "/* External allocation function prototypes */@.";
534
      fprintf source_fmt "@[<v>";
535
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
536
      fprintf source_fmt "@]@.";
537
      fprintf source_fmt "/* Node allocation function prototypes */@.";
538
      fprintf source_fmt "@[<v>";
539
      List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
540
      fprintf source_fmt "@]@.";
541
    end;
542

    
543
  (* Print the struct definitions of all machines. *)
544
  fprintf source_fmt "/* Struct definitions */@.";
545
  fprintf source_fmt "@[<v>";
546
  List.iter (print_machine_struct source_fmt) machines;
547
  fprintf source_fmt "@]@.";
548
  pp_print_newline source_fmt ();
549
  (* Print nodes one by one (in the previous order) *)
550
  List.iter (print_machine dependencies source_fmt) machines;
551
 end
552

    
553
(* Local Variables: *)
554
(* compile-command:"make -C ../../.." *)
555
(* End: *)