Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_src.ml @ 0d54d8a8

History | View | Annotate | Download (32.6 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 Lustre_types
14
open Machine_code_types
15
open Corelang
16
open Machine_code_common
17
open C_backend_common
18

    
19
module type MODIFIERS_SRC =
20
sig
21
end
22

    
23
module EmptyMod =
24
struct
25
end
26

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

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

    
34

    
35
(* Computes the depth to which multi-dimension array assignments should be expanded.
36
   It equals the maximum number of nested static array constructions accessible from root [v].
37
*)
38
  let rec expansion_depth v =
39
    match v.value_desc with
40
    | Cst cst -> expansion_depth_cst 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
  and expansion_depth_cst c = 
48
    match c with
49
      Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
50
    | _ -> 0
51
  
52
  let rec merge_static_loop_profiles lp1 lp2 =
53
    match lp1, lp2 with
54
    | []      , _        -> lp2
55
    | _       , []       -> lp1
56
    | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
57

    
58
(* Returns a list of bool values, indicating whether the indices must be static or not *)
59
  let rec static_loop_profile v =
60
    match v.value_desc with
61
    | Cst cst  -> static_loop_profile_cst cst
62
    | LocalVar _
63
    | StateVar _  -> []
64
    | Fun (_, vl) -> List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
65
    | Array vl    -> true :: List.fold_right (fun v lp -> merge_static_loop_profiles lp (static_loop_profile v)) vl []
66
    | Access (v, i) -> (match (static_loop_profile v) with [] -> [] | _ :: q -> q)
67
    | Power (v, n)  -> false :: static_loop_profile v
68
  and static_loop_profile_cst cst =
69
    match cst with
70
      Const_array cl -> List.fold_right 
71
	(fun c lp -> merge_static_loop_profiles lp (static_loop_profile_cst c))
72
	cl 
73
	[]
74
    | _ -> [] 
75
  
76
  
77
let rec is_const_index v =
78
  match v.value_desc with
79
  | Cst (Const_int _) -> true
80
  | Fun (_, vl)       -> List.for_all is_const_index vl
81
  | _                 -> false
82

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

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

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

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

    
127
(* Prints a value expression [v], with internal function calls only.
128
   [pp_var] is a printer for variables (typically [pp_c_var_read]),
129
   but an offset suffix may be added for array variables
130
*)
131
(* Prints a constant value before a suffix (needs casting) *)
132
let rec pp_c_const_suffix var_type fmt c =
133
  match c with
134
    | Const_int i          -> pp_print_int fmt i
135
    | Const_real (_, _, s) -> pp_print_string fmt s
136
    | Const_tag t          -> pp_c_tag fmt t
137
    | Const_array ca       -> let var_type = Types.array_element_type var_type in
138
                              fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_c_const_suffix var_type)) ca
139
    | 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
140
    | Const_string _
141
      | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
142

    
143

    
144
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
145
let rec pp_value_suffix self var_type loop_vars pp_value fmt value =
146
  (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
147
  (
148
    match loop_vars, value.value_desc with
149
    | (x, LAcc i) :: q, _ when is_const_index i ->
150
       let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in
151
       pp_value_suffix self var_type ((x, LInt r)::q) pp_value fmt value
152
    | (_, LInt r) :: q, Cst (Const_array cl) ->
153
       let var_type = Types.array_element_type var_type in
154
       pp_value_suffix self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
155
    | (_, LInt r) :: q, Array vl      ->
156
       let var_type = Types.array_element_type var_type in
157
       pp_value_suffix self var_type q pp_value fmt (List.nth vl !r)
158
    | loop_var    :: q, Array vl      ->
159
       let var_type = Types.array_element_type var_type in
160
       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]
161
    | []              , Array vl      ->
162
       let var_type = Types.array_element_type var_type in
163
       Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix self var_type [] pp_value)) vl
164
    | _           :: q, Power (v, n)  ->
165
       pp_value_suffix self var_type q pp_value fmt v
166
    | _               , Fun (n, vl)   ->
167
       pp_basic_lib_fun (Types.is_int_type value.value_type) n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
168
    | _               , Access (v, i) ->
169
       let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
170
       pp_value_suffix self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
171
    | _               , LocalVar v    -> Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
172
    | _               , StateVar v    ->
173
       (* array memory vars are represented by an indirection to a local var with the right type,
174
	  in order to avoid casting everywhere. *)
175
       if Types.is_array_type v.var_type
176
       then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
177
       else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
178
    | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst
179
    | _               , _             -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type pp_val value pp_suffix loop_vars; assert false)
180
  )
181
   
182
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
183
   which may yield constant arrays in expressions.
184
   Type is needed to correctly print constant arrays.
185
 *)
186
let pp_c_val self pp_var fmt v =
187
  pp_value_suffix self v.value_type [] pp_var fmt v
188

    
189
let pp_basic_assign pp_var fmt typ var_name value =
190
  if Types.is_real_type typ && !Options.mpfr
191
  then
192
    Mpfr.pp_inject_assign pp_var fmt var_name value
193
  else
194
    fprintf fmt "%a = %a;" 
195
      pp_var var_name
196
      pp_var value
197

    
198
(* type_directed assignment: array vs. statically sized type
199
   - [var_type]: type of variable to be assigned
200
   - [var_name]: name of variable to be assigned
201
   - [value]: assigned value
202
   - [pp_var]: printer for variables
203
*)
204
let pp_assign m self pp_var fmt var_type var_name value =
205
  let depth = expansion_depth value in
206
  (*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
207
  let loop_vars = mk_loop_variables m var_type depth in
208
  let reordered_loop_vars = reorder_loop_variables loop_vars in
209
  let rec aux typ fmt vars =
210
    match vars with
211
    | [] ->
212
       pp_basic_assign (pp_value_suffix self var_type loop_vars pp_var) fmt typ var_name value
213
    | (d, LVar i) :: q ->
214
       let typ' = Types.array_element_type typ in
215
      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
216
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
217
	i i i pp_c_dimension d i
218
	(aux typ') q
219
    | (d, LInt r) :: q ->
220
       (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
221
       let typ' = Types.array_element_type typ in
222
       let szl = Utils.enumerate (Dimension.size_const_dimension d) in
223
       fprintf fmt "@[<v 2>{@,%a@]@,}"
224
	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
225
    | _ -> assert false
226
  in
227
  begin
228
    reset_loop_counter ();
229
    (*reset_addr_counter ();*)
230
    aux var_type fmt reordered_loop_vars;
231
    (*Format.eprintf "end pp_assign@.";*)
232
  end
233

    
234
let pp_machine_reset (m: machine_t) self fmt inst =
235
  let (node, static) =
236
    try
237
      List.assoc inst m.minstances
238
    with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in
239
  fprintf fmt "%a(%a%t%s->%s);"
240
    pp_machine_reset_name (node_name node)
241
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
242
    (Utils.pp_final_char_if_non_empty ", " static)
243
    self inst
244

    
245
let pp_machine_init (m: machine_t) self fmt inst =
246
  let (node, static) =
247
    try
248
      List.assoc inst m.minstances
249
    with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in
250
  fprintf fmt "%a(%a%t%s->%s);"
251
    pp_machine_init_name (node_name node)
252
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
253
    (Utils.pp_final_char_if_non_empty ", " static)
254
    self inst
255

    
256
let pp_machine_clear (m: machine_t) self fmt inst =
257
  let (node, static) =
258
    try
259
      List.assoc inst m.minstances
260
    with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in
261
  fprintf fmt "%a(%a%t%s->%s);"
262
    pp_machine_clear_name (node_name node)
263
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
264
    (Utils.pp_final_char_if_non_empty ", " static)
265
    self inst
266

    
267
let has_c_prototype funname dependencies =
268
  let imported_node_opt = (* We select the last imported node with the name funname.
269
			       The order of evaluation of dependencies should be
270
			       compatible with overloading. (Not checked yet) *) 
271
      List.fold_left
272
	(fun res (Dep (_, _, decls, _)) -> 
273
	  match res with
274
	  | Some _ -> res
275
	  | None -> 
276
	    let matched = fun t -> match t.top_decl_desc with 
277
	      | ImportedNode nd -> nd.nodei_id = funname 
278
	      | _ -> false
279
	    in
280
	    if List.exists matched decls then (
281
	      match (List.find matched decls).top_decl_desc with
282
	      | ImportedNode nd -> Some nd
283
	      | _ -> assert false
284
	    )
285
	    else
286
	      None
287
	) None dependencies in
288
    match imported_node_opt with
289
    | None -> false
290
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
291
(*
292
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) =
293
  try (* stateful node instance *)
294
    let (n,_) = List.assoc i m.minstances in
295
    let (input_types, _) = Typing.get_type_of_call n in
296
    let inputs = List.combine input_types inputs in
297
    fprintf fmt "%a (%a%t%a%t%s->%s);"
298
      pp_machine_step_name (node_name n)
299
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
300
      (Utils.pp_final_char_if_non_empty ", " inputs) 
301
      (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
302
      (Utils.pp_final_char_if_non_empty ", " outputs)
303
      self
304
      i
305
  with Not_found -> (* stateless node instance *)
306
    let (n,_) = List.assoc i m.mcalls in
307
    let (input_types, output_types) = Typing.get_type_of_call n in
308
    let inputs = List.combine input_types inputs in
309
    if has_c_prototype i dependencies
310
    then (* external C function *)
311
      let outputs = List.map2 (fun t v -> t, LocalVar v) output_types outputs in
312
      fprintf fmt "%a = %s(%a);"
313
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs
314
	i
315
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
316
    else
317
      fprintf fmt "%a (%a%t%a);"
318
	pp_machine_step_name (node_name n)
319
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
320
	(Utils.pp_final_char_if_non_empty ", " inputs) 
321
	(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
322
*)
323
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
324
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
325
    (pp_c_val self (pp_c_var_read m)) c
326
    (Utils.pp_newline_if_non_empty tl)
327
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
328
    (Utils.pp_newline_if_non_empty el)
329
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
330

    
331
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
332
  match get_instr_desc instr with 
333
  | MNoReset _ -> ()
334
  | MReset i ->
335
    pp_machine_reset m self fmt i
336
  | MLocalAssign (i,v) ->
337
    pp_assign
338
      m self (pp_c_var_read m) fmt
339
      i.var_type (mk_val (LocalVar i) i.var_type) v
340
  | MStateAssign (i,v) ->
341
    pp_assign
342
      m self (pp_c_var_read m) fmt
343
      i.var_type (mk_val (StateVar i) i.var_type) v
344
  | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type)  ->
345
    pp_machine_instr dependencies m self fmt 
346
      (update_instr_desc instr (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)))
347
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
348
    fprintf fmt "%a = %s(%a);" 
349
      (pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type)
350
      i
351
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
352
  | MStep (il, i, vl) when Mpfr.is_homomorphic_fun i ->
353
    pp_instance_call m self fmt i vl il
354
  | MStep (il, i, vl) ->
355
    pp_basic_instance_call m self fmt i vl il
356
  | MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false)
357
  | MBranch (g, hl) ->
358
    if let t = fst (List.hd hl) in t = tag_true || t = tag_false
359
    then (* boolean case, needs special treatment in C because truth value is not unique *)
360
	 (* may disappear if we optimize code by replacing last branch test with default *)
361
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
362
      let el = try List.assoc tag_false hl with Not_found -> [] in
363
      pp_conditional dependencies m self fmt g tl el
364
    else (* enum type case *)
365
      (*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*)
366
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
367
	(pp_c_val self (pp_c_var_read m)) g
368
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
369
  | MComment s  -> 
370
      fprintf fmt "/*%s*/@ " s
371

    
372

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

    
378

    
379
(********************************************************************************************)
380
(*                         C file Printing functions                                        *)
381
(********************************************************************************************)
382

    
383
let print_const_def fmt cdecl =
384
  if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type)
385
  then
386
    fprintf fmt "%a;@." 
387
      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 
388
  else
389
    fprintf fmt "%a = %a;@." 
390
      (pp_c_type cdecl.const_id) cdecl.const_type
391
      pp_c_const cdecl.const_value 
392

    
393

    
394
let print_alloc_instance fmt (i, (m, static)) =
395
  fprintf fmt "_alloc->%s = %a (%a);@,"
396
    i
397
    pp_machine_alloc_name (node_name m)
398
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
399

    
400
let print_dealloc_instance fmt (i, (m, _)) =
401
  fprintf fmt "%a (_alloc->%s);@,"
402
    pp_machine_dealloc_name (node_name m)
403
    i
404

    
405
let print_alloc_const fmt m =
406
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
407
  fprintf fmt "%a%t"
408
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
409
    (Utils.pp_final_char_if_non_empty ";@," const_locals)
410

    
411
let print_alloc_array fmt vdecl =
412
  let base_type = Types.array_base_type vdecl.var_type in
413
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
414
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
415
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
416
    vdecl.var_id
417
    (pp_c_type "") base_type
418
    Dimension.pp_dimension size_type
419
    (pp_c_type "") base_type
420
    vdecl.var_id
421

    
422
let print_dealloc_array fmt vdecl =
423
  fprintf fmt "free (_alloc->_reg.%s);@,"
424
    vdecl.var_id
425

    
426
let print_alloc_code fmt m =
427
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
428
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
429
    pp_machine_memtype_name m.mname.node_id
430
    pp_machine_memtype_name m.mname.node_id
431
    pp_machine_memtype_name m.mname.node_id
432
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
433
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
434

    
435
let print_dealloc_code fmt m =
436
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
437
  fprintf fmt "%a%afree (_alloc);@,return;"
438
    (Utils.fprintf_list ~sep:"" print_dealloc_array) array_mem
439
    (Utils.fprintf_list ~sep:"" print_dealloc_instance) m.minstances
440

    
441
let print_stateless_init_code dependencies fmt m self =
442
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
443
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
444
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
445
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
446
    (* array mems *) 
447
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
448
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
449
    (* memory initialization *)
450
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
451
    (Utils.pp_newline_if_non_empty m.mmemory)
452
    (* sub-machines initialization *)
453
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
454
    (Utils.pp_newline_if_non_empty m.minit)
455

    
456
let print_stateless_clear_code dependencies fmt m self =
457
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
458
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
459
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
460
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
461
    (* array mems *)
462
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
463
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
464
    (* memory clear *)
465
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
466
    (Utils.pp_newline_if_non_empty m.mmemory)
467
    (* sub-machines clear*)
468
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
469
    (Utils.pp_newline_if_non_empty m.minit)
470

    
471
let print_stateless_code dependencies fmt m =
472
  let self = "__ERROR__" in
473
  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 })
474
  then
475
    (* C99 code *)
476
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
477
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
478
      (* locals *)
479
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
480
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
481
      (* locals initialization *)
482
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
483
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
484
      (* check assertions *)
485
      (pp_c_checks self) m
486
      (* instrs *)
487
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
488
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
489
      (* locals clear *)
490
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
491
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
492
      (fun fmt -> fprintf fmt "return;")
493
  else
494
    (* C90 code *)
495
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
496
    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
497
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
498
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
499
      (* locals *)
500
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
501
      (Utils.pp_final_char_if_non_empty ";" base_locals)
502
      (* locals initialization *)
503
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
504
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
505
      (* check assertions *)
506
      (pp_c_checks self) m
507
      (* instrs *)
508
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
509
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
510
      (* locals clear *)
511
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
512
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
513
      (fun fmt -> fprintf fmt "return;")
514

    
515
let print_reset_code dependencies fmt m self =
516
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
517
  fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@."
518
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
519
    (* constant locals decl *)
520
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
521
    (Utils.pp_final_char_if_non_empty ";" const_locals)
522
    (* instrs *)
523
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
524
    (Utils.pp_newline_if_non_empty m.minit)
525

    
526
let print_init_code dependencies fmt m self =
527
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
528
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
529
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
530
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
531
    (* array mems *) 
532
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
533
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
534
    (* memory initialization *)
535
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
536
    (Utils.pp_newline_if_non_empty m.mmemory)
537
    (* sub-machines initialization *)
538
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
539
    (Utils.pp_newline_if_non_empty m.minit)
540

    
541
let print_clear_code dependencies fmt m self =
542
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
543
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
544
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
545
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
546
    (* array mems *)
547
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
548
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
549
    (* memory clear *)
550
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
551
    (Utils.pp_newline_if_non_empty m.mmemory)
552
    (* sub-machines clear*)
553
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
554
    (Utils.pp_newline_if_non_empty m.minit)
555

    
556
let print_step_code dependencies fmt m self =
557
  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 })
558
  then
559
    (* C99 code *)
560
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
561
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
562
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
563
      (* locals *)
564
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
565
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
566
      (* array mems *)
567
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
568
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
569
      (* locals initialization *)
570
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
571
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
572
      (* check assertions *)
573
      (pp_c_checks self) m
574
      (* instrs *)
575
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
576
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
577
      (* locals clear *)
578
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
579
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
580
      (fun fmt -> fprintf fmt "return;")
581
  else
582
    (* C90 code *)
583
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
584
    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
585
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
586
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
587
      (* locals *)
588
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
589
      (Utils.pp_final_char_if_non_empty ";" base_locals)
590
      (* locals initialization *)
591
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
592
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
593
      (* check assertions *)
594
      (pp_c_checks self) m
595
      (* instrs *)
596
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
597
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
598
      (* locals clear *)
599
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
600
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
601
      (fun fmt -> fprintf fmt "return;")
602

    
603

    
604
(********************************************************************************************)
605
(*                     MAIN C file Printing functions                                       *)
606
(********************************************************************************************)
607

    
608
let print_global_init_code fmt basename prog dependencies =
609
  let baseNAME = file_to_module_name basename in
610
  let constants = List.map const_of_top (get_consts prog) in
611
  fprintf fmt "@[<v 2>%a {@,static %s init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
612
    print_global_init_prototype baseNAME
613
    (pp_c_basic_type_desc Type_predef.type_bool)
614
    (* constants *) 
615
    (Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read empty_machine))) constants
616
    (Utils.pp_final_char_if_non_empty "@," dependencies)
617
    (* dependencies initialization *)
618
    (Utils.fprintf_list ~sep:"@," print_import_init) dependencies
619

    
620
let print_global_clear_code  fmt basename prog dependencies =
621
  let baseNAME = file_to_module_name basename in
622
  let constants = List.map const_of_top (get_consts prog) in
623
  fprintf fmt "@[<v 2>%a {@,static %s clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
624
    print_global_clear_prototype baseNAME
625
    (pp_c_basic_type_desc Type_predef.type_bool)
626
    (* constants *) 
627
    (Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read empty_machine))) constants
628
    (Utils.pp_final_char_if_non_empty "@," dependencies)
629
    (* dependencies initialization *)
630
    (Utils.fprintf_list ~sep:"@," print_import_clear) dependencies
631

    
632
let print_machine dependencies fmt m =
633
  if fst (get_stateless_status m) then
634
    begin
635
      (* Step function *)
636
      print_stateless_code dependencies fmt m
637
    end
638
  else
639
    begin
640
      (* Alloc functions, only if non static mode *)
641
      if (not !Options.static_mem) then  
642
	begin
643
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
644
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
645
	    print_alloc_const m
646
	    print_alloc_code m;
647

    
648
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
649
	    print_dealloc_prototype m.mname.node_id
650
	    print_alloc_const m
651
	    print_dealloc_code m;
652
	end;
653
      let self = mk_self m in
654
      (* Reset function *)
655
      print_reset_code dependencies fmt m self;
656
      (* Step function *)
657
      print_step_code dependencies fmt m self;
658
      
659
      if !Options.mpfr then
660
	begin
661
          (* Init function *)
662
	  print_init_code dependencies fmt m self;
663
          (* Clear function *)
664
	  print_clear_code dependencies fmt m self;
665
	end
666
    end
667

    
668
let print_import_standard source_fmt =
669
  begin
670
    fprintf source_fmt "#include <assert.h>@.";
671
    if Machine_types.has_machine_type () then
672
      begin
673
	fprintf source_fmt "#include <stdint.h>@."
674
      end;
675
    if not !Options.static_mem then
676
      begin
677
	fprintf source_fmt "#include <stdlib.h>@.";
678
      end;
679
    if !Options.mpfr then
680
      begin
681
	fprintf source_fmt "#include <mpfr.h>@.";
682
      end
683
  end
684

    
685
let print_lib_c source_fmt basename prog machines dependencies =
686
  print_import_standard source_fmt;
687
  print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
688
  pp_print_newline source_fmt ();
689
  (* Print the svn version number and the supported C standard (C90 or C99) *)
690
  print_version source_fmt;
691
  (* Print the prototype of imported nodes *)
692
  fprintf source_fmt "/* Import dependencies */@.";
693
  fprintf source_fmt "@[<v>";
694
  List.iter (print_import_prototype source_fmt) dependencies;
695
  fprintf source_fmt "@]@.";
696
  (* Print consts *)
697
  fprintf source_fmt "/* Global constants (definitions) */@.";
698
  fprintf source_fmt "@[<v>";
699
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
700
  fprintf source_fmt "@]@.";
701
  if !Options.mpfr then
702
    begin
703
      fprintf source_fmt "/* Global constants initialization */@.";
704
      print_global_init_code source_fmt basename prog dependencies;
705
      fprintf source_fmt "/* Global constants clearing */@.";
706
      print_global_clear_code source_fmt basename prog dependencies;
707
    end;
708
  if not !Options.static_mem then
709
    begin
710
      fprintf source_fmt "/* External allocation function prototypes */@.";
711
      fprintf source_fmt "@[<v>";
712
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
713
      fprintf source_fmt "@]@.";
714
      fprintf source_fmt "/* Node allocation function prototypes */@.";
715
      fprintf source_fmt "@[<v>";
716
      List.iter
717
	(fun m -> fprintf source_fmt "%a;@.@.%a;@.@."
718
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
719
	  print_dealloc_prototype m.mname.node_id
720
	)
721
	machines;
722
      fprintf source_fmt "@]@.";
723
    end;
724

    
725
  (* Print the struct definitions of all machines. *)
726
  fprintf source_fmt "/* Struct definitions */@.";
727
  fprintf source_fmt "@[<v>";
728
  List.iter (print_machine_struct source_fmt) machines;
729
  fprintf source_fmt "@]@.";
730
  pp_print_newline source_fmt ();
731
  (* Print nodes one by one (in the previous order) *)
732
  List.iter (print_machine dependencies source_fmt) machines;
733
 end
734

    
735
(* Local Variables: *)
736
(* compile-command:"make -C ../../.." *)
737
(* End: *)