Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / backends / C / c_backend_src.ml @ 521e2a6b

History | View | Annotate | Download (32.3 KB)

1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
11

    
12
open Format
13
open LustreSpec
14
open Corelang
15
open Machine_code
16
open C_backend_common
17

    
18
module type MODIFIERS_SRC =
19
sig
20
end
21

    
22
module EmptyMod =
23
struct
24
end
25

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

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

    
33

    
34
(* Computes the depth to which multi-dimension array assignments should be expanded.
35
   It equals the maximum number of nested static array constructions accessible from root [v].
36
*)
37
  let rec expansion_depth v =
38
    match v.value_desc with
39
    | Cst cst -> expansion_depth_cst cst
40
    | LocalVar _
41
    | StateVar _  -> 0
42
    | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
43
    | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
44
    | Access (v, i) -> max 0 (expansion_depth v - 1)
45
    | Power (v, n)  -> 0 (*1 + expansion_depth v*)
46
  and expansion_depth_cst c = 
47
    match c with
48
      Const_array cl -> 1 + List.fold_right (fun c -> max (expansion_depth_cst c)) cl 0
49
    | _ -> 0
50
  
51
  let rec merge_static_loop_profiles lp1 lp2 =
52
    match lp1, lp2 with
53
    | []      , _        -> lp2
54
    | _       , []       -> lp1
55
    | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
56

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

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

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

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

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

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

    
141

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

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

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

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

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

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

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

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

    
370

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

    
376

    
377
(********************************************************************************************)
378
(*                         C file Printing functions                                        *)
379
(********************************************************************************************)
380

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

    
391

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

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

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

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

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

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

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

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

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

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

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

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

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

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

    
601

    
602
(********************************************************************************************)
603
(*                     MAIN C file Printing functions                                       *)
604
(********************************************************************************************)
605

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

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

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

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

    
666
let print_import_standard source_fmt =
667
  begin
668
    fprintf source_fmt "#include <assert.h>@.";
669
    if not !Options.static_mem then
670
      begin
671
	fprintf source_fmt "#include <stdlib.h>@.";
672
      end;
673
    if !Options.mpfr then
674
      begin
675
	fprintf source_fmt "#include <mpfr.h>@.";
676
      end
677
  end
678

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

    
719
  (* Print the struct definitions of all machines. *)
720
  fprintf source_fmt "/* Struct definitions */@.";
721
  fprintf source_fmt "@[<v>";
722
  List.iter (print_machine_struct source_fmt) machines;
723
  fprintf source_fmt "@]@.";
724
  pp_print_newline source_fmt ();
725
  (* Print nodes one by one (in the previous order) *)
726
  List.iter (print_machine dependencies source_fmt) machines;
727
 end
728

    
729
(* Local Variables: *)
730
(* compile-command:"make -C ../../.." *)
731
(* End: *)