Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

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

History | View | Annotate | Download (32.8 KB)

1 a2d97a3e ploc
(********************************************************************)
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 cd670fe1 ploc
open Format
13 8446bf03 ploc
open Lustre_types
14
open Machine_code_types
15 cd670fe1 ploc
open Corelang
16 2863281f ploc
open Machine_code_common
17 cd670fe1 ploc
open C_backend_common
18
19 cefc3744 ploc
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 cd670fe1 ploc
(********************************************************************************************)
31
(*                    Instruction Printing functions                                        *)
32
(********************************************************************************************)
33
34 85da3a4b ploc
35 cd670fe1 ploc
(* 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 04a63d25 xthirioux
  let rec expansion_depth v =
39
    match v.value_desc with
40
    | Cst cst -> expansion_depth_cst cst
41 c35de73b ploc
    | Var _ -> 0
42 04a63d25 xthirioux
    | 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 cd670fe1 ploc
57 080a6d0b xthirioux
(* Returns a list of bool values, indicating whether the indices must be static or not *)
58 04a63d25 xthirioux
  let rec static_loop_profile v =
59
    match v.value_desc with
60
    | Cst cst  -> static_loop_profile_cst cst
61 c35de73b ploc
    | Var _  -> []
62 04a63d25 xthirioux
    | 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 080a6d0b xthirioux
let rec is_const_index v =
76 04a63d25 xthirioux
  match v.value_desc with
77 080a6d0b xthirioux
  | 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 c35de73b ploc
 | _                        , LVar i :: q -> value_offsets (Access (v, Var i)) q
92 080a6d0b xthirioux
*)
93 cd670fe1 ploc
(* 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 2d179f5b xthirioux
114 cd670fe1 ploc
(* Prints a one loop variable suffix for arrays *)
115 c35de73b ploc
let pp_loop_var m fmt lv =
116 cd670fe1 ploc
 match snd lv with
117
 | LVar v -> fprintf fmt "[%s]" v
118
 | LInt r -> fprintf fmt "[%d]" !r
119 c35de73b ploc
 | LAcc i -> fprintf fmt "[%a]" (pp_val m) i
120 cd670fe1 ploc
121
(* Prints a suffix of loop variables for arrays *)
122 c35de73b ploc
let pp_suffix m fmt loop_vars =
123
 Utils.fprintf_list ~sep:"" (pp_loop_var m) fmt loop_vars
124 2d179f5b xthirioux
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 04a63d25 xthirioux
    | 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 0d54d8a8 ploc
    | Const_string _
139
      | Const_modeid _ -> assert false (* string occurs in annotations not in C *)
140 2d179f5b xthirioux
141 cd670fe1 ploc
142 2d179f5b xthirioux
(* Prints a [value] of type [var_type] indexed by the suffix list [loop_vars] *)
143 c35de73b ploc
let rec pp_value_suffix m self var_type loop_vars pp_value fmt value =
144 521e2a6b ploc
  (*Format.eprintf "pp_value_suffix: %a %a %a@." Types.print_ty var_type Machine_code.pp_val value pp_suffix loop_vars;*)
145 c35de73b ploc
  let pp_suffix = pp_suffix m in
146 521e2a6b ploc
  (
147
    match loop_vars, value.value_desc with
148
    | (x, LAcc i) :: q, _ when is_const_index i ->
149 2863281f ploc
       let r = ref (Dimension.size_const_dimension (dimension_of_value i)) in
150 c35de73b ploc
       pp_value_suffix m self var_type ((x, LInt r)::q) pp_value fmt value
151 521e2a6b ploc
    | (_, LInt r) :: q, Cst (Const_array cl) ->
152
       let var_type = Types.array_element_type var_type in
153 c35de73b ploc
       pp_value_suffix m self var_type q pp_value fmt (mk_val (Cst (List.nth cl !r)) Type_predef.type_int)
154 521e2a6b ploc
    | (_, LInt r) :: q, Array vl      ->
155
       let var_type = Types.array_element_type var_type in
156 c35de73b ploc
       pp_value_suffix m self var_type q pp_value fmt (List.nth vl !r)
157 521e2a6b ploc
    | loop_var    :: q, Array vl      ->
158
       let var_type = Types.array_element_type var_type in
159 c35de73b ploc
       Format.fprintf fmt "(%a[]){%a }%a" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix m self var_type q pp_value)) vl pp_suffix [loop_var]
160 521e2a6b ploc
    | []              , Array vl      ->
161
       let var_type = Types.array_element_type var_type in
162 c35de73b ploc
       Format.fprintf fmt "(%a[]){%a }" (pp_c_type "") var_type (Utils.fprintf_list ~sep:", " (pp_value_suffix m self var_type [] pp_value)) vl
163 521e2a6b ploc
    | _           :: q, Power (v, n)  ->
164 c35de73b ploc
       pp_value_suffix m self var_type q pp_value fmt v
165 521e2a6b ploc
    | _               , Fun (n, vl)   ->
166 c35de73b ploc
       pp_basic_lib_fun (Types.is_int_type value.value_type) n (pp_value_suffix m self var_type loop_vars pp_value) fmt vl
167 521e2a6b ploc
    | _               , Access (v, i) ->
168
       let var_type = Type_predef.type_array (Dimension.mkdim_var ()) var_type in
169 c35de73b ploc
       pp_value_suffix m self var_type ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
170
    | _               , Var v    ->
171
       if is_memory m v then (
172
         (* array memory vars are represented by an indirection to a local var with the right type,
173
	    in order to avoid casting everywhere. *)
174
         if Types.is_array_type v.var_type
175
         then Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
176
         else Format.fprintf fmt "%s->_reg.%a%a" self pp_value v pp_suffix loop_vars
177
       )
178
       else (
179
         Format.fprintf fmt "%a%a" pp_value v pp_suffix loop_vars
180
       )
181 521e2a6b ploc
    | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst
182 c35de73b ploc
    | _               , _             -> (Format.eprintf "internal error: C_backend_src.pp_value_suffix %a %a %a@." Types.print_ty var_type (pp_val m) value pp_suffix loop_vars; assert false)
183 521e2a6b ploc
  )
184
   
185 d7b73fed xthirioux
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
186
   which may yield constant arrays in expressions.
187
   Type is needed to correctly print constant arrays.
188
 *)
189 c35de73b ploc
let pp_c_val m self pp_var fmt v =
190
  pp_value_suffix m self v.value_type [] pp_var fmt v
191 04a63d25 xthirioux
192
let pp_basic_assign pp_var fmt typ var_name value =
193
  if Types.is_real_type typ && !Options.mpfr
194
  then
195
    Mpfr.pp_inject_assign pp_var fmt var_name value
196
  else
197
    fprintf fmt "%a = %a;" 
198
      pp_var var_name
199
      pp_var value
200 d7b73fed xthirioux
201 cd670fe1 ploc
(* type_directed assignment: array vs. statically sized type
202
   - [var_type]: type of variable to be assigned
203
   - [var_name]: name of variable to be assigned
204
   - [value]: assigned value
205
   - [pp_var]: printer for variables
206
*)
207
let pp_assign m self pp_var fmt var_type var_name value =
208
  let depth = expansion_depth value in
209 04a63d25 xthirioux
  (*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
210 cd670fe1 ploc
  let loop_vars = mk_loop_variables m var_type depth in
211
  let reordered_loop_vars = reorder_loop_variables loop_vars in
212 04a63d25 xthirioux
  let rec aux typ fmt vars =
213 cd670fe1 ploc
    match vars with
214
    | [] ->
215 c35de73b ploc
       pp_basic_assign (pp_value_suffix m self var_type loop_vars pp_var) fmt typ var_name value
216 cd670fe1 ploc
    | (d, LVar i) :: q ->
217 04a63d25 xthirioux
       let typ' = Types.array_element_type typ in
218
      (*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
219 cd670fe1 ploc
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
220 04a63d25 xthirioux
	i i i pp_c_dimension d i
221
	(aux typ') q
222 cd670fe1 ploc
    | (d, LInt r) :: q ->
223 04a63d25 xthirioux
       (*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
224
       let typ' = Types.array_element_type typ in
225
       let szl = Utils.enumerate (Dimension.size_const_dimension d) in
226
       fprintf fmt "@[<v 2>{@,%a@]@,}"
227
	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
228 080a6d0b xthirioux
    | _ -> assert false
229 cd670fe1 ploc
  in
230
  begin
231
    reset_loop_counter ();
232
    (*reset_addr_counter ();*)
233 04a63d25 xthirioux
    aux var_type fmt reordered_loop_vars;
234
    (*Format.eprintf "end pp_assign@.";*)
235 cd670fe1 ploc
  end
236
237 04a63d25 xthirioux
let pp_machine_reset (m: machine_t) self fmt inst =
238
  let (node, static) =
239
    try
240
      List.assoc inst m.minstances
241
    with Not_found -> (Format.eprintf "internal error: pp_machine_reset %s %s %s:@." m.mname.node_id self inst; raise Not_found) in
242
  fprintf fmt "%a(%a%t%s->%s);"
243
    pp_machine_reset_name (node_name node)
244
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
245
    (Utils.pp_final_char_if_non_empty ", " static)
246
    self inst
247
248
let pp_machine_init (m: machine_t) self fmt inst =
249
  let (node, static) =
250
    try
251
      List.assoc inst m.minstances
252
    with Not_found -> (Format.eprintf "internal error: pp_machine_init %s %s %s@." m.mname.node_id self inst; raise Not_found) in
253
  fprintf fmt "%a(%a%t%s->%s);"
254
    pp_machine_init_name (node_name node)
255
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
256
    (Utils.pp_final_char_if_non_empty ", " static)
257
    self inst
258
259
let pp_machine_clear (m: machine_t) self fmt inst =
260
  let (node, static) =
261
    try
262
      List.assoc inst m.minstances
263
    with Not_found -> (Format.eprintf "internal error: pp_machine_clear %s %s %s@." m.mname.node_id self inst; raise Not_found) in
264
  fprintf fmt "%a(%a%t%s->%s);"
265
    pp_machine_clear_name (node_name node)
266
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
267
    (Utils.pp_final_char_if_non_empty ", " static)
268
    self inst
269
270 cd670fe1 ploc
let has_c_prototype funname dependencies =
271
  let imported_node_opt = (* We select the last imported node with the name funname.
272
			       The order of evaluation of dependencies should be
273
			       compatible with overloading. (Not checked yet) *) 
274 5fccce23 ploc
    List.fold_left
275
      (fun res dep -> 
276
	match res with
277
	| Some _ -> res
278
	| None ->
279
           let decls = dep.content in
280
	   let matched = fun t -> match t.top_decl_desc with 
281
	                          | ImportedNode nd -> nd.nodei_id = funname 
282
	                          | _ -> false
283
	   in
284
	   if List.exists matched decls then (
285
	     match (List.find matched decls).top_decl_desc with
286
	     | ImportedNode nd -> Some nd
287
	     | _ -> assert false
288
	   )
289
	   else
290
	     None
291
      ) None dependencies in
292
  match imported_node_opt with
293
  | None -> false
294
  | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
295 04a63d25 xthirioux
(*
296 d7b73fed xthirioux
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) =
297
  try (* stateful node instance *)
298
    let (n,_) = List.assoc i m.minstances in
299
    let (input_types, _) = Typing.get_type_of_call n in
300
    let inputs = List.combine input_types inputs in
301
    fprintf fmt "%a (%a%t%a%t%s->%s);"
302
      pp_machine_step_name (node_name n)
303
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
304
      (Utils.pp_final_char_if_non_empty ", " inputs) 
305
      (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
306
      (Utils.pp_final_char_if_non_empty ", " outputs)
307
      self
308
      i
309
  with Not_found -> (* stateless node instance *)
310
    let (n,_) = List.assoc i m.mcalls in
311
    let (input_types, output_types) = Typing.get_type_of_call n in
312
    let inputs = List.combine input_types inputs in
313
    if has_c_prototype i dependencies
314
    then (* external C function *)
315 c35de73b ploc
      let outputs = List.map2 (fun t v -> t, Var v) output_types outputs in
316 d7b73fed xthirioux
      fprintf fmt "%a = %s(%a);"
317
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs
318
	i
319
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
320
    else
321
      fprintf fmt "%a (%a%t%a);"
322
	pp_machine_step_name (node_name n)
323
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
324
	(Utils.pp_final_char_if_non_empty ", " inputs) 
325
	(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
326 04a63d25 xthirioux
*)
327 cd670fe1 ploc
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
328
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
329 c35de73b ploc
    (pp_c_val m self (pp_c_var_read m)) c
330 cd670fe1 ploc
    (Utils.pp_newline_if_non_empty tl)
331
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
332
    (Utils.pp_newline_if_non_empty el)
333
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) el
334
335
and pp_machine_instr dependencies (m: machine_t) self fmt instr =
336 3ca27bc7 ploc
  match get_instr_desc instr with 
337 45f0f48d xthirioux
  | MNoReset _ -> ()
338 cd670fe1 ploc
  | MReset i ->
339
    pp_machine_reset m self fmt i
340
  | MLocalAssign (i,v) ->
341
    pp_assign
342
      m self (pp_c_var_read m) fmt
343 c35de73b ploc
      i.var_type (mk_val (Var i) i.var_type) v
344 cd670fe1 ploc
  | MStateAssign (i,v) ->
345
    pp_assign
346
      m self (pp_c_var_read m) fmt
347 c35de73b ploc
      i.var_type (mk_val (Var i) i.var_type) v
348 04a63d25 xthirioux
  | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type)  ->
349
    pp_machine_instr dependencies m self fmt 
350 3ca27bc7 ploc
      (update_instr_desc instr (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type)))
351 d948c0bd ploc
  | MStep (il, i, vl) when !Options.mpfr && Mpfr.is_homomorphic_fun i ->
352
     pp_instance_call m self fmt i vl il
353 04a63d25 xthirioux
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
354
    fprintf fmt "%a = %s(%a);" 
355 c35de73b ploc
      (pp_c_val m self (pp_c_var_read m)) (mk_val (Var i0) i0.var_type)
356 04a63d25 xthirioux
      i
357 c35de73b ploc
      (Utils.fprintf_list ~sep:", " (pp_c_val m self (pp_c_var_read m))) vl
358 cd670fe1 ploc
  | MStep (il, i, vl) ->
359 04a63d25 xthirioux
    pp_basic_instance_call m self fmt i vl il
360 c35de73b ploc
  | MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." (pp_instr m) instr; assert false)
361 d7b73fed xthirioux
  | MBranch (g, hl) ->
362
    if let t = fst (List.hd hl) in t = tag_true || t = tag_false
363 cd670fe1 ploc
    then (* boolean case, needs special treatment in C because truth value is not unique *)
364
	 (* may disappear if we optimize code by replacing last branch test with default *)
365
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
366
      let el = try List.assoc tag_false hl with Not_found -> [] in
367
      pp_conditional dependencies m self fmt g tl el
368
    else (* enum type case *)
369 04a63d25 xthirioux
      (*let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in*)
370 cd670fe1 ploc
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
371 c35de73b ploc
	(pp_c_val m self (pp_c_var_read m)) g
372 cd670fe1 ploc
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
373 04a63d25 xthirioux
  | MComment s  -> 
374 45f0f48d xthirioux
      fprintf fmt "/*%s*/@ " s
375 04a63d25 xthirioux
376 cd670fe1 ploc
377
and pp_machine_branch dependencies m self fmt (t, h) =
378 04a63d25 xthirioux
  fprintf fmt "@[<v 2>case %a:@,%a@,break;@]"
379
    pp_c_tag t
380
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) h
381 cd670fe1 ploc
382
383
(********************************************************************************************)
384
(*                         C file Printing functions                                        *)
385
(********************************************************************************************)
386
387
let print_const_def fmt cdecl =
388 04a63d25 xthirioux
  if !Options.mpfr && Types.is_real_type (Types.array_base_type cdecl.const_type)
389
  then
390
    fprintf fmt "%a;@." 
391
      (pp_c_type cdecl.const_id) (Types.dynamic_type cdecl.const_type) 
392
  else
393
    fprintf fmt "%a = %a;@." 
394
      (pp_c_type cdecl.const_id) cdecl.const_type
395
      pp_c_const cdecl.const_value 
396 cd670fe1 ploc
397
398
let print_alloc_instance fmt (i, (m, static)) =
399
  fprintf fmt "_alloc->%s = %a (%a);@,"
400
    i
401
    pp_machine_alloc_name (node_name m)
402
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
403
404 80f93e0a xavier.thirioux
let print_dealloc_instance fmt (i, (m, _)) =
405
  fprintf fmt "%a (_alloc->%s);@,"
406
    pp_machine_dealloc_name (node_name m)
407
    i
408
409 ec433d69 xthirioux
let print_alloc_const fmt m =
410
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
411
  fprintf fmt "%a%t"
412
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
413
    (Utils.pp_final_char_if_non_empty ";@," const_locals)
414
415 cd670fe1 ploc
let print_alloc_array fmt vdecl =
416
  let base_type = Types.array_base_type vdecl.var_type in
417
  let size_types = Types.array_type_multi_dimension vdecl.var_type in
418
  let size_type = Dimension.multi_dimension_product vdecl.var_loc size_types in
419
  fprintf fmt "_alloc->_reg.%s = (%a*) malloc((%a)*sizeof(%a));@,assert(_alloc->%s);@,"
420
    vdecl.var_id
421
    (pp_c_type "") base_type
422
    Dimension.pp_dimension size_type
423
    (pp_c_type "") base_type
424
    vdecl.var_id
425
426 80f93e0a xavier.thirioux
let print_dealloc_array fmt vdecl =
427
  fprintf fmt "free (_alloc->_reg.%s);@,"
428
    vdecl.var_id
429
430 cd670fe1 ploc
let print_alloc_code fmt m =
431
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
432
  fprintf fmt "%a *_alloc;@,_alloc = (%a *) malloc(sizeof(%a));@,assert(_alloc);@,%a%areturn _alloc;"
433
    pp_machine_memtype_name m.mname.node_id
434
    pp_machine_memtype_name m.mname.node_id
435
    pp_machine_memtype_name m.mname.node_id
436
    (Utils.fprintf_list ~sep:"" print_alloc_array) array_mem
437
    (Utils.fprintf_list ~sep:"" print_alloc_instance) m.minstances
438
439 80f93e0a xavier.thirioux
let print_dealloc_code fmt m =
440
  let array_mem = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
441
  fprintf fmt "%a%afree (_alloc);@,return;"
442
    (Utils.fprintf_list ~sep:"" print_dealloc_array) array_mem
443
    (Utils.fprintf_list ~sep:"" print_dealloc_instance) m.minstances
444
445 04a63d25 xthirioux
let print_stateless_init_code dependencies fmt m self =
446 3ca27bc7 ploc
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
447 04a63d25 xthirioux
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
448
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
449
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
450
    (* array mems *) 
451
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
452
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
453
    (* memory initialization *)
454
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
455
    (Utils.pp_newline_if_non_empty m.mmemory)
456
    (* sub-machines initialization *)
457
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
458
    (Utils.pp_newline_if_non_empty m.minit)
459
460
let print_stateless_clear_code dependencies fmt m self =
461 3ca27bc7 ploc
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
462 04a63d25 xthirioux
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
463
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
464
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
465
    (* array mems *)
466
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
467
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
468
    (* memory clear *)
469
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
470
    (Utils.pp_newline_if_non_empty m.mmemory)
471
    (* sub-machines clear*)
472
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
473
    (Utils.pp_newline_if_non_empty m.minit)
474
475 cd670fe1 ploc
let print_stateless_code dependencies fmt m =
476
  let self = "__ERROR__" in
477 ef34b4ae xthirioux
  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 })
478 cd670fe1 ploc
  then
479
    (* C99 code *)
480 04a63d25 xthirioux
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
481 cd670fe1 ploc
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
482
      (* locals *)
483 ec433d69 xthirioux
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
484 cd670fe1 ploc
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
485 04a63d25 xthirioux
      (* locals initialization *)
486
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
487
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
488 cd670fe1 ploc
      (* check assertions *)
489
      (pp_c_checks self) m
490
      (* instrs *)
491
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
492
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
493 04a63d25 xthirioux
      (* locals clear *)
494
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
495
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
496 cd670fe1 ploc
      (fun fmt -> fprintf fmt "return;")
497
  else
498
    (* C90 code *)
499
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
500
    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
501 04a63d25 xthirioux
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
502 cd670fe1 ploc
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
503
      (* locals *)
504 ec433d69 xthirioux
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
505 cd670fe1 ploc
      (Utils.pp_final_char_if_non_empty ";" base_locals)
506 04a63d25 xthirioux
      (* locals initialization *)
507
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
508
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
509 cd670fe1 ploc
      (* check assertions *)
510
      (pp_c_checks self) m
511
      (* instrs *)
512
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
513
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
514 04a63d25 xthirioux
      (* locals clear *)
515
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
516
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
517 cd670fe1 ploc
      (fun fmt -> fprintf fmt "return;")
518
519
let print_reset_code dependencies fmt m self =
520 ec433d69 xthirioux
  let const_locals = List.filter (fun vdecl -> vdecl.var_dec_const) m.mstep.step_locals in
521
  fprintf fmt "@[<v 2>%a {@,%a%t@,%a%treturn;@]@,}@.@."
522 cd670fe1 ploc
    (print_reset_prototype self) (m.mname.node_id, m.mstatic)
523 ec433d69 xthirioux
    (* constant locals decl *)
524
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) const_locals
525
    (Utils.pp_final_char_if_non_empty ";" const_locals)
526
    (* instrs *)
527 cd670fe1 ploc
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
528
    (Utils.pp_newline_if_non_empty m.minit)
529
530 04a63d25 xthirioux
let print_init_code dependencies fmt m self =
531 3ca27bc7 ploc
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
532 04a63d25 xthirioux
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
533
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
534
    (print_init_prototype self) (m.mname.node_id, m.mstatic)
535
    (* array mems *) 
536
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
537
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
538
    (* memory initialization *)
539
    (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mmemory
540
    (Utils.pp_newline_if_non_empty m.mmemory)
541
    (* sub-machines initialization *)
542
    (Utils.fprintf_list ~sep:"@," (pp_machine_init m self)) minit
543
    (Utils.pp_newline_if_non_empty m.minit)
544
545
let print_clear_code dependencies fmt m self =
546 3ca27bc7 ploc
  let minit = List.map (fun i -> match get_instr_desc i with MReset i -> i | _ -> assert false) m.minit in
547 04a63d25 xthirioux
  let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
548
  fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%treturn;@]@,}@.@."
549
    (print_clear_prototype self) (m.mname.node_id, m.mstatic)
550
    (* array mems *)
551
    (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
552
    (Utils.pp_final_char_if_non_empty ";@," array_mems)
553
    (* memory clear *)
554
    (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mmemory
555
    (Utils.pp_newline_if_non_empty m.mmemory)
556
    (* sub-machines clear*)
557
    (Utils.fprintf_list ~sep:"@," (pp_machine_clear m self)) minit
558
    (Utils.pp_newline_if_non_empty m.minit)
559
560 cd670fe1 ploc
let print_step_code dependencies fmt m self =
561 ef34b4ae xthirioux
  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 })
562 cd670fe1 ploc
  then
563
    (* C99 code *)
564
    let array_mems = List.filter (fun v -> Types.is_array_type v.var_type) m.mmemory in
565 04a63d25 xthirioux
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
566 cd670fe1 ploc
      (print_step_prototype self) (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
567
      (* locals *)
568 ec433d69 xthirioux
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
569 cd670fe1 ploc
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
570
      (* array mems *)
571
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_array_mem self)) array_mems
572
      (Utils.pp_final_char_if_non_empty ";@," array_mems)
573 04a63d25 xthirioux
      (* locals initialization *)
574
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
575
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
576 cd670fe1 ploc
      (* check assertions *)
577
      (pp_c_checks self) m
578
      (* instrs *)
579
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
580
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
581 04a63d25 xthirioux
      (* locals clear *)
582
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
583
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
584 cd670fe1 ploc
      (fun fmt -> fprintf fmt "return;")
585
  else
586
    (* C90 code *)
587
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
588
    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
589 04a63d25 xthirioux
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
590 cd670fe1 ploc
      (print_step_prototype self) (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
591
      (* locals *)
592 ec433d69 xthirioux
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
593 cd670fe1 ploc
      (Utils.pp_final_char_if_non_empty ";" base_locals)
594 04a63d25 xthirioux
      (* locals initialization *)
595
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
596
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
597 cd670fe1 ploc
      (* check assertions *)
598
      (pp_c_checks self) m
599
      (* instrs *)
600
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
601
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
602 04a63d25 xthirioux
      (* locals clear *)
603
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
604
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
605 cd670fe1 ploc
      (fun fmt -> fprintf fmt "return;")
606
607
608
(********************************************************************************************)
609
(*                     MAIN C file Printing functions                                       *)
610
(********************************************************************************************)
611
612 04a63d25 xthirioux
let print_global_init_code fmt basename prog dependencies =
613
  let baseNAME = file_to_module_name basename in
614
  let constants = List.map const_of_top (get_consts prog) in
615 52c5ba00 David Doose
  fprintf fmt "@[<v 2>%a {@,static %s init = 0;@,@[<v 2>if (!init) { @,init = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
616 04a63d25 xthirioux
    print_global_init_prototype baseNAME
617 66359a5e ploc
    (pp_c_basic_type_desc Type_predef.type_bool)
618 04a63d25 xthirioux
    (* constants *) 
619 c35de73b ploc
    (Utils.fprintf_list ~sep:"@," (pp_const_initialize empty_machine (pp_c_var_read empty_machine))) constants
620 04a63d25 xthirioux
    (Utils.pp_final_char_if_non_empty "@," dependencies)
621
    (* dependencies initialization *)
622
    (Utils.fprintf_list ~sep:"@," print_import_init) dependencies
623
624
let print_global_clear_code  fmt basename prog dependencies =
625
  let baseNAME = file_to_module_name basename in
626
  let constants = List.map const_of_top (get_consts prog) in
627 52c5ba00 David Doose
  fprintf fmt "@[<v 2>%a {@,static %s clear = 0;@,@[<v 2>if (!clear) { @,clear = 1;@,%a%t%a@]@,}@,return;@]@,}@.@."
628 04a63d25 xthirioux
    print_global_clear_prototype baseNAME
629 66359a5e ploc
    (pp_c_basic_type_desc Type_predef.type_bool)
630 04a63d25 xthirioux
    (* constants *) 
631 2863281f ploc
    (Utils.fprintf_list ~sep:"@," (pp_const_clear (pp_c_var_read empty_machine))) constants
632 04a63d25 xthirioux
    (Utils.pp_final_char_if_non_empty "@," dependencies)
633
    (* dependencies initialization *)
634
    (Utils.fprintf_list ~sep:"@," print_import_clear) dependencies
635
636 cd670fe1 ploc
let print_machine dependencies fmt m =
637
  if fst (get_stateless_status m) then
638
    begin
639
      (* Step function *)
640
      print_stateless_code dependencies fmt m
641
    end
642
  else
643
    begin
644 80f93e0a xavier.thirioux
      (* Alloc functions, only if non static mode *)
645 cd670fe1 ploc
      if (not !Options.static_mem) then  
646 ef34b4ae xthirioux
	begin
647 ec433d69 xthirioux
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
648 cd670fe1 ploc
	    print_alloc_prototype (m.mname.node_id, m.mstatic)
649 ec433d69 xthirioux
	    print_alloc_const m
650 cd670fe1 ploc
	    print_alloc_code m;
651 80f93e0a xavier.thirioux
652
	  fprintf fmt "@[<v 2>%a {@,%a%a@]@,}@.@."
653
	    print_dealloc_prototype m.mname.node_id
654
	    print_alloc_const m
655
	    print_dealloc_code m;
656 ef34b4ae xthirioux
	end;
657 cd670fe1 ploc
      let self = mk_self m in
658
      (* Reset function *)
659
      print_reset_code dependencies fmt m self;
660
      (* Step function *)
661 04a63d25 xthirioux
      print_step_code dependencies fmt m self;
662
      
663
      if !Options.mpfr then
664
	begin
665
          (* Init function *)
666
	  print_init_code dependencies fmt m self;
667
          (* Clear function *)
668
	  print_clear_code dependencies fmt m self;
669
	end
670 cd670fe1 ploc
    end
671
672 04a63d25 xthirioux
let print_import_standard source_fmt =
673
  begin
674
    fprintf source_fmt "#include <assert.h>@.";
675 66359a5e ploc
    if Machine_types.has_machine_type () then
676
      begin
677
	fprintf source_fmt "#include <stdint.h>@."
678
      end;
679 04a63d25 xthirioux
    if not !Options.static_mem then
680
      begin
681
	fprintf source_fmt "#include <stdlib.h>@.";
682
      end;
683
    if !Options.mpfr then
684
      begin
685
	fprintf source_fmt "#include <mpfr.h>@.";
686
      end
687
  end
688 cd670fe1 ploc
689 d4107cf2 ploc
let print_lib_c source_fmt basename prog machines dependencies =
690 04a63d25 xthirioux
  print_import_standard source_fmt;
691 5fccce23 ploc
  print_import_prototype source_fmt {local=true; name=basename; content=[]; is_stateful=true} (* assuming it is stateful *);
692 ef34b4ae xthirioux
  pp_print_newline source_fmt ();
693 cd670fe1 ploc
  (* Print the svn version number and the supported C standard (C90 or C99) *)
694
  print_version source_fmt;
695
  (* Print the prototype of imported nodes *)
696 ef34b4ae xthirioux
  fprintf source_fmt "/* Import dependencies */@.";
697 cd670fe1 ploc
  fprintf source_fmt "@[<v>";
698
  List.iter (print_import_prototype source_fmt) dependencies;
699
  fprintf source_fmt "@]@.";
700
  (* Print consts *)
701
  fprintf source_fmt "/* Global constants (definitions) */@.";
702 ef34b4ae xthirioux
  fprintf source_fmt "@[<v>";
703
  List.iter (fun c -> print_const_def source_fmt (const_of_top c)) (get_consts prog);
704
  fprintf source_fmt "@]@.";
705 04a63d25 xthirioux
  if !Options.mpfr then
706
    begin
707
      fprintf source_fmt "/* Global constants initialization */@.";
708
      print_global_init_code source_fmt basename prog dependencies;
709
      fprintf source_fmt "/* Global constants clearing */@.";
710
      print_global_clear_code source_fmt basename prog dependencies;
711
    end;
712 ef34b4ae xthirioux
  if not !Options.static_mem then
713
    begin
714
      fprintf source_fmt "/* External allocation function prototypes */@.";
715
      fprintf source_fmt "@[<v>";
716
      List.iter (print_extern_alloc_prototypes source_fmt) dependencies;
717
      fprintf source_fmt "@]@.";
718
      fprintf source_fmt "/* Node allocation function prototypes */@.";
719
      fprintf source_fmt "@[<v>";
720 80f93e0a xavier.thirioux
      List.iter
721
	(fun m -> fprintf source_fmt "%a;@.@.%a;@.@."
722
	  print_alloc_prototype (m.mname.node_id, m.mstatic)
723
	  print_dealloc_prototype m.mname.node_id
724
	)
725
	machines;
726 ef34b4ae xthirioux
      fprintf source_fmt "@]@.";
727
    end;
728 ec433d69 xthirioux
729 ef34b4ae xthirioux
  (* Print the struct definitions of all machines. *)
730
  fprintf source_fmt "/* Struct definitions */@.";
731
  fprintf source_fmt "@[<v>";
732
  List.iter (print_machine_struct source_fmt) machines;
733
  fprintf source_fmt "@]@.";
734 cd670fe1 ploc
  pp_print_newline source_fmt ();
735
  (* Print nodes one by one (in the previous order) *)
736
  List.iter (print_machine dependencies source_fmt) machines;
737 d4107cf2 ploc
 end
738 cd670fe1 ploc
739
(* Local Variables: *)
740
(* compile-command:"make -C ../../.." *)
741
(* End: *)