Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_src.ml @ 3b2bd83d

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

    
140

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

    
177
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
178
   which may yield constant arrays in expressions.
179
   Type is needed to correctly print constant arrays.
180
 *)
181
let pp_c_val self pp_var fmt v =
182
  pp_value_suffix self v.value_type [] pp_var fmt v
183

    
184
let pp_basic_assign pp_var fmt typ var_name value =
185
  if Types.is_real_type typ && !Options.mpfr
186
  then
187
    Mpfr.pp_inject_assign pp_var fmt var_name value
188
  else
189
    fprintf fmt "%a = %a;" 
190
      pp_var var_name
191
      pp_var value
192

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

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

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

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

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

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

    
367

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

    
373

    
374
(********************************************************************************************)
375
(*                         C file Printing functions                                        *)
376
(********************************************************************************************)
377

    
378
let print_const_def fmt cdecl =
379
  if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type)
380
  then
381
    fprintf fmt "%a;@." 
382
      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 
383
  else
384
    fprintf fmt "%a = %a;@." 
385
      (pp_c_type cdecl.const_id) cdecl.const_type
386
      pp_c_const cdecl.const_value 
387

    
388

    
389
let print_alloc_instance fmt (i, (m, static)) =
390
  fprintf fmt "_alloc->%s = %a (%a);@,"
391
    i
392
    pp_machine_alloc_name (node_name m)
393
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
394

    
395
let print_alloc_const fmt m =
396
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
397
  fprintf fmt "%a%t"
398
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
399
    (Utils.pp_final_char_if_non_empty ";@," const_locals)
400

    
401
let print_alloc_array fmt vdecl =
402
  let base_type = Types.array_base_type vdecl.var_type in
403
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
404
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
405
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
406
    vdecl.var_id
407
    (pp_c_type "") base_type
408
    Dimension.pp_dimension size_type
409
    (pp_c_type "") base_type
410
    vdecl.var_id
411

    
412
let print_alloc_code fmt m =
413
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
414
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
415
    pp_machine_memtype_name m.mname.node_id
416
    pp_machine_memtype_name m.mname.node_id
417
    pp_machine_memtype_name m.mname.node_id
418
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
419
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
420

    
421
let print_stateless_init_code dependencies fmt m self =
422
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
423
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
424
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
425
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
426
    (* array mems *) 
427
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
428
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
429
    (* memory initialization *)
430
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
431
    (Utils.pp_newline_if_non_empty m.mmemory)
432
    (* sub-machines initialization *)
433
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
434
    (Utils.pp_newline_if_non_empty m.minit)
435

    
436
let print_stateless_clear_code dependencies fmt m self =
437
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
438
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
439
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
440
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
441
    (* array mems *)
442
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
443
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
444
    (* memory clear *)
445
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
446
    (Utils.pp_newline_if_non_empty m.mmemory)
447
    (* sub-machines clear*)
448
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
449
    (Utils.pp_newline_if_non_empty m.minit)
450

    
451
let print_stateless_code dependencies fmt m =
452
  let self = "__ERROR__" in
453
  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 })
454
  then
455
    (* C99 code *)
456
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
457
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
458
      (* locals *)
459
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
460
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
461
      (* locals initialization *)
462
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
463
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
464
      (* check assertions *)
465
      (pp_c_checks self) m
466
      (* instrs *)
467
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
468
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
469
      (* locals clear *)
470
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
471
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
472
      (fun fmt -> fprintf fmt "return;")
473
  else
474
    (* C90 code *)
475
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
476
    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
477
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
478
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
479
      (* locals *)
480
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
481
      (Utils.pp_final_char_if_non_empty ";" base_locals)
482
      (* locals initialization *)
483
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
484
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
485
      (* check assertions *)
486
      (pp_c_checks self) m
487
      (* instrs *)
488
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
489
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
490
      (* locals clear *)
491
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
492
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
493
      (fun fmt -> fprintf fmt "return;")
494

    
495
let print_reset_code dependencies fmt m self =
496
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
497
  fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@."
498
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
499
    (* constant locals decl *)
500
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
501
    (Utils.pp_final_char_if_non_empty ";" const_locals)
502
    (* instrs *)
503
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
504
    (Utils.pp_newline_if_non_empty m.minit)
505

    
506
let print_init_code dependencies fmt m self =
507
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
508
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
509
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
510
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
511
    (* array mems *) 
512
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
513
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
514
    (* memory initialization *)
515
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
516
    (Utils.pp_newline_if_non_empty m.mmemory)
517
    (* sub-machines initialization *)
518
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
519
    (Utils.pp_newline_if_non_empty m.minit)
520

    
521
let print_clear_code dependencies fmt m self =
522
  let minit = List.map (function MReset i -> i | _ -> assert false) m.minit in
523
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
524
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
525
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
526
    (* array mems *)
527
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
528
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
529
    (* memory clear *)
530
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
531
    (Utils.pp_newline_if_non_empty m.mmemory)
532
    (* sub-machines clear*)
533
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
534
    (Utils.pp_newline_if_non_empty m.minit)
535

    
536
let print_step_code dependencies fmt m self =
537
  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 })
538
  then
539
    (* C99 code *)
540
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
541
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
542
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
543
      (* locals *)
544
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
545
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
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
      (* locals initialization *)
550
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
551
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
552
      (* check assertions *)
553
      (pp_c_checks self) m
554
      (* instrs *)
555
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
556
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
557
      (* locals clear *)
558
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
559
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
560
      (fun fmt -> fprintf fmt "return;")
561
  else
562
    (* C90 code *)
563
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
564
    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
565
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
566
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
567
      (* locals *)
568
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
569
      (Utils.pp_final_char_if_non_empty ";" base_locals)
570
      (* locals initialization *)
571
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
572
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
573
      (* check assertions *)
574
      (pp_c_checks self) m
575
      (* instrs *)
576
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
577
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
578
      (* locals clear *)
579
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
580
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
581
      (fun fmt -> fprintf fmt "return;")
582

    
583

    
584
(********************************************************************************************)
585
(*                     MAIN C file Printing functions                                       *)
586
(********************************************************************************************)
587

    
588
let print_global_init_code fmt basename prog dependencies =
589
  let baseNAME = file_to_module_name basename in
590
  let constants = List.map const_of_top (get_consts prog) in
591
  fprintf fmt "@[<v 2>%a {@,static _Bool init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
592
    print_global_init_prototype baseNAME
593
    (* constants *) 
594
    (Utils.fprintf_list ~sep:"@," (pp_const_initialize (pp_c_var_read Machine_code.empty_machine))) constants
595
    (Utils.pp_final_char_if_non_empty "@," dependencies)
596
    (* dependencies initialization *)
597
    (Utils.fprintf_list ~sep:"@," print_import_init) dependencies
598

    
599
let print_global_clear_code  fmt basename prog dependencies =
600
  let baseNAME = file_to_module_name basename in
601
  let constants = List.map const_of_top (get_consts prog) in
602
  fprintf fmt "@[<v 2>%a {@,static _Bool clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
603
    print_global_clear_prototype baseNAME
604
    (* constants *) 
605
    (Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read Machine_code.empty_machine))) constants
606
    (Utils.pp_final_char_if_non_empty "@," dependencies)
607
    (* dependencies initialization *)
608
    (Utils.fprintf_list ~sep:"@," print_import_clear) dependencies
609

    
610
let print_machine dependencies fmt m =
611
  if fst (get_stateless_status m) then
612
    begin
613
      (* Step function *)
614
      print_stateless_code dependencies fmt m
615
    end
616
  else
617
    begin
618
      (* Alloc function, only if non static mode *)
619
      if (not !Options.static_mem) then  
620
	begin
621
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
622
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
623
	    print_alloc_const m
624
	    print_alloc_code m;
625
	end;
626
      let self = mk_self m in
627
      (* Reset function *)
628
      print_reset_code dependencies fmt m self;
629
      (* Step function *)
630
      print_step_code dependencies fmt m self;
631
      
632
      if !Options.mpfr then
633
	begin
634
          (* Init function *)
635
	  print_init_code dependencies fmt m self;
636
          (* Clear function *)
637
	  print_clear_code dependencies fmt m self;
638
	end
639
    end
640

    
641
let print_import_standard source_fmt =
642
  begin
643
    fprintf source_fmt "#include <assert.h>@.";
644
    if not !Options.static_mem then
645
      begin
646
	fprintf source_fmt "#include <stdlib.h>@.";
647
      end;
648
    if !Options.mpfr then
649
      begin
650
	fprintf source_fmt "#include <mpfr.h>@.";
651
      end
652
  end
653

    
654
let print_lib_c source_fmt basename prog machines dependencies =
655
  print_import_standard source_fmt;
656
  print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
657
  pp_print_newline source_fmt ();
658
  (* Print the svn version number and the supported C standard (C90 or C99) *)
659
  print_version source_fmt;
660
  (* Print the prototype of imported nodes *)
661
  fprintf source_fmt "/* Import dependencies */@.";
662
  fprintf source_fmt "@[<v>";
663
  List.iter (print_import_prototype source_fmt) dependencies;
664
  fprintf source_fmt "@]@.";
665
  (* Print consts *)
666
  fprintf source_fmt "/* Global constants (definitions) */@.";
667
  fprintf source_fmt "@[<v>";
668
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
669
  fprintf source_fmt "@]@.";
670
  if !Options.mpfr then
671
    begin
672
      fprintf source_fmt "/* Global constants initialization */@.";
673
      print_global_init_code source_fmt basename prog dependencies;
674
      fprintf source_fmt "/* Global constants clearing */@.";
675
      print_global_clear_code source_fmt basename prog dependencies;
676
    end;
677
  if not !Options.static_mem then
678
    begin
679
      fprintf source_fmt "/* External allocation function prototypes */@.";
680
      fprintf source_fmt "@[<v>";
681
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
682
      fprintf source_fmt "@]@.";
683
      fprintf source_fmt "/* Node allocation function prototypes */@.";
684
      fprintf source_fmt "@[<v>";
685
      List.iter (fun m -> fprintf source_fmt "%a;@." print_alloc_prototype (m.mname.node_id, m.mstatic)) machines;
686
      fprintf source_fmt "@]@.";
687
    end;
688

    
689
  (* Print the struct definitions of all machines. *)
690
  fprintf source_fmt "/* Struct definitions */@.";
691
  fprintf source_fmt "@[<v>";
692
  List.iter (print_machine_struct source_fmt) machines;
693
  fprintf source_fmt "@]@.";
694
  pp_print_newline source_fmt ();
695
  (* Print nodes one by one (in the previous order) *)
696
  List.iter (print_machine dependencies source_fmt) machines;
697
 end
698

    
699
(* Local Variables: *)
700
(* compile-command:"make -C ../../.." *)
701
(* End: *)