Project

General

Profile

Revision 53206908 src/backends/C/c_backend_src.ml

View differences:

src/backends/C/c_backend_src.ml
30 30
(*                    Instruction Printing functions                                        *)
31 31
(********************************************************************************************)
32 32

  
33

  
34 33
(* Computes the depth to which multi-dimension array assignments should be expanded.
35 34
   It equals the maximum number of nested static array constructions accessible from root [v].
36 35
*)
37
let rec expansion_depth v =
38
 match v with
39
 | Cst (Const_array cl) -> 1 + List.fold_right (fun c -> max (expansion_depth (Cst c))) cl 0
40
 | Cst _
41
 | LocalVar _
42
 | StateVar _  -> 0
43
 | Fun (_, vl) -> List.fold_right (fun v -> max (expansion_depth v)) vl 0
44
 | Array vl    -> 1 + List.fold_right (fun v -> max (expansion_depth v)) vl 0
45
 | Access (v, i) -> max 0 (expansion_depth v - 1)
46
 | Power (v, n)  -> 0 (*1 + expansion_depth v*)
47

  
48
let rec merge_static_loop_profiles lp1 lp2 =
49
  match lp1, lp2 with
50
  | []      , _        -> lp2
51
  | _       , []       -> lp1
52
  | p1 :: q1, p2 :: q2 -> (p1 || p2) :: merge_static_loop_profiles q1 q2
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
53 55

  
54 56
(* Returns a list of bool values, indicating whether the indices must be static or not *)
55
let rec static_loop_profile v =
56
 match v with
57
 | Cst (Const_array cl) ->
58
   List.fold_right (fun c lp -> merge_static_loop_profiles lp (static_loop_profile (Cst c))) cl []
59
 | 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

  
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
  
67 75
let rec is_const_index v =
68
  match v with
76
  match v.value_desc with
69 77
  | Cst (Const_int _) -> true
70 78
  | Fun (_, vl)       -> List.for_all is_const_index vl
71 79
  | _                 -> false
......
114 122
let pp_suffix fmt loop_vars =
115 123
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
116 124

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

  
133

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

  
170
(* Subsumes C_backend_common.pp_c_val to cope with aggressive substitution
171
   which may yield constant arrays in expressions.
172
   Type is needed to correctly print constant arrays.
173
 *)
174
let pp_c_val self pp_var fmt (t, v) =
175
  pp_value_suffix self t [] pp_var fmt v
135
   pp_value_suffix self ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
136
 | _               , _             ->
137
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
138
   pp_c_val self pp_var_suffix fmt value
139

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

  
177 149
(* type_directed assignment: array vs. statically sized type
178 150
   - [var_type]: type of variable to be assigned
......
180 152
   - [value]: assigned value
181 153
   - [pp_var]: printer for variables
182 154
*)
183
(*
184
let pp_assign_rec pp_var var_type var_name value =
185
  match (Types.repr var_type).Types.tdesc, value with
186
  | Types.Tarray (d, ty'), Array vl     ->
187
    let szl = Utils.enumerate (Dimension.size_const_dimension d) in
188
    fprintf fmt "@[<v 2>{@,%a@]@,}"
189
      (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
190
  | Types.Tarray (d, ty'), Power (v, _) -> 
191
  | Types.Tarray (d, ty'), _            ->
192
  | _                    , _            ->
193
    fprintf fmt "%a = %a;" 
194
      pp_var var_name
195
      (pp_value_suffix self loop_vars pp_var) value
196
*)
197 155
let pp_assign m self pp_var fmt var_type var_name value =
198 156
  let depth = expansion_depth value in
199
(*Format.eprintf "pp_assign %a %a %a %d@." Types.print_ty var_type pp_val var_name pp_val value depth;*)
157
(*eprintf "pp_assign %a %a %d@." Types.print_ty var_type pp_val var_name depth;*)
200 158
  let loop_vars = mk_loop_variables m var_type depth in
201 159
  let reordered_loop_vars = reorder_loop_variables loop_vars in
202
  let rec aux fmt vars =
160
  let rec aux typ fmt vars =
203 161
    match vars with
204 162
    | [] ->
205
      fprintf fmt "%a = %a;" 
206
	(pp_value_suffix self var_type loop_vars pp_var) var_name
207
	(pp_value_suffix self var_type loop_vars pp_var) value
163
       pp_basic_assign (pp_value_suffix self loop_vars pp_var) fmt typ var_name value
208 164
    | (d, LVar i) :: q ->
165
       let typ' = Types.array_element_type typ in
209 166
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
210 167
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
211
	i i i Dimension.pp_dimension d i
212
	aux q
168
	i i i pp_c_dimension d i
169
	(aux typ') q
213 170
    | (d, LInt r) :: q ->
214 171
(*eprintf "pp_aux %a %d@." Dimension.pp_dimension d (!r);*)
215
      let szl = Utils.enumerate (Dimension.size_const_dimension d) in
216
      fprintf fmt "@[<v 2>{@,%a@]@,}"
217
	(Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux fmt q)) szl
172
       let typ' = Types.array_element_type typ in
173
       let szl = Utils.enumerate (Dimension.size_const_dimension d) in
174
       fprintf fmt "@[<v 2>{@,%a@]@,}"
175
	       (Utils.fprintf_list ~sep:"@," (fun fmt i -> r := i; aux typ' fmt q)) szl
218 176
    | _ -> assert false
219 177
  in
220 178
  begin
221 179
    reset_loop_counter ();
222 180
    (*reset_addr_counter ();*)
223
    aux fmt reordered_loop_vars
181
    aux var_type fmt reordered_loop_vars
224 182
  end
225 183

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

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

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

  
226 217
let has_c_prototype funname dependencies =
227 218
  let imported_node_opt = (* We select the last imported node with the name funname.
228 219
			       The order of evaluation of dependencies should be
......
248 239
    | None -> false
249 240
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
250 241

  
251
let pp_instance_call dependencies m self fmt i (inputs: value_t list) (outputs: var_decl list) =
252
  try (* stateful node instance *)
253
    let (n,_) = List.assoc i m.minstances in
254
    let (input_types, _) = Typing.get_type_of_call n in
255
    let inputs = List.combine input_types inputs in
256
    fprintf fmt "%a (%a%t%a%t%s->%s);"
257
      pp_machine_step_name (node_name n)
258
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
259
      (Utils.pp_final_char_if_non_empty ", " inputs) 
260
      (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
261
      (Utils.pp_final_char_if_non_empty ", " outputs)
262
      self
263
      i
264
  with Not_found -> (* stateless node instance *)
265
    let (n,_) = List.assoc i m.mcalls in
266
    let (input_types, output_types) = Typing.get_type_of_call n in
267
    let inputs = List.combine input_types inputs in
268
    if has_c_prototype i dependencies
269
    then (* external C function *)
270
      let outputs = List.map2 (fun t v -> t, LocalVar v) output_types outputs in
271
      fprintf fmt "%a = %s(%a);"
272
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) outputs
273
	i
274
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
275
    else
276
      fprintf fmt "%a (%a%t%a);"
277
	pp_machine_step_name (node_name n)
278
	(Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
279
	(Utils.pp_final_char_if_non_empty ", " inputs) 
280
	(Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
281

  
282
let pp_machine_reset (m: machine_t) self fmt inst =
283
  let (node, static) =
284
    try
285
      List.assoc inst m.minstances
286
    with Not_found -> (Format.eprintf "pp_machine_reset %s %s %s: internal error@," m.mname.node_id self inst; raise Not_found) in
287
  fprintf fmt "%a(%a%t%s->%s);"
288
    pp_machine_reset_name (node_name node)
289
    (Utils.fprintf_list ~sep:", " Dimension.pp_dimension) static
290
    (Utils.pp_final_char_if_non_empty ", " static)
291
    self inst
292

  
293 242
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
294 243
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
295
    (pp_c_val self (pp_c_var_read m)) (Type_predef.type_bool, c)
244
    (pp_c_val self (pp_c_var_read m)) c
296 245
    (Utils.pp_newline_if_non_empty tl)
297 246
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
298 247
    (Utils.pp_newline_if_non_empty el)
......
305 254
  | MLocalAssign (i,v) ->
306 255
    pp_assign
307 256
      m self (pp_c_var_read m) fmt
308
      i.var_type (LocalVar i) v
257
      i.var_type (mk_val (LocalVar i) i.var_type) v
309 258
  | MStateAssign (i,v) ->
310 259
    pp_assign
311 260
      m self (pp_c_var_read m) fmt
312
      i.var_type (StateVar i) v
313
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
314
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
261
      i.var_type (mk_val (StateVar i) i.var_type) v
262
  | MStep ([i0], i, vl) when Basic_library.is_value_internal_fun (mk_val (Fun (i, vl)) i0.var_type)  ->
263
    pp_machine_instr dependencies m self fmt 
264
      (MLocalAssign (i0, mk_val (Fun (i, vl)) i0.var_type))
265
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
266
    fprintf fmt "%a = %s(%a);" 
267
      (pp_c_val self (pp_c_var_read m)) (mk_val (LocalVar i0) i0.var_type)
268
      i
269
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
270
  | MStep (il, i, vl) when Mpfr.is_homomorphic_fun i ->
271
    pp_instance_call m self fmt i vl il
315 272
  | MStep (il, i, vl) ->
316
    pp_instance_call dependencies m self fmt i vl il
317
  | MBranch (_, []) -> (Format.eprintf "internal error: C_backend_src.pp_machine_instr %a@." pp_instr instr; assert false)
318
  | MBranch (g, hl) ->
319
    if let t = fst (List.hd hl) in t = tag_true || t = tag_false
273
    pp_basic_instance_call m self fmt i vl il
274
  | MBranch (g,hl) ->
275
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
320 276
    then (* boolean case, needs special treatment in C because truth value is not unique *)
321
	 (* may disappear if we optimize code by replacing last branch test with default *)
277
      (* may disappear if we optimize code by replacing last branch test with default *)
322 278
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
323 279
      let el = try List.assoc tag_false hl with Not_found -> [] in
324 280
      pp_conditional dependencies m self fmt g tl el
325 281
    else (* enum type case *)
326
      let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in
327 282
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
328
	(pp_c_val self (pp_c_var_read m)) (g_typ, g)
283
	(pp_c_val self (pp_c_var_read m)) g
329 284
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
285
  | MComment s  -> 
286
      fprintf fmt "//%s@ " s
287

  
330 288

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

  
334 294

  
335 295
(********************************************************************************************)
......
379 339
  if not (!Options.ansi && is_generic_node { top_decl_desc = Node m.mname; top_decl_loc = Location.dummy_loc; top_decl_owner = ""; top_decl_itf = false })
380 340
  then
381 341
    (* C99 code *)
382
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
342
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
383 343
      print_stateless_prototype (m.mname.node_id, m.mstep.step_inputs, m.mstep.step_outputs)
384 344
      (* locals *)
385 345
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) m.mstep.step_locals
386 346
      (Utils.pp_final_char_if_non_empty ";@," m.mstep.step_locals)
347
      (* locals initialization *)
348
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
349
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
387 350
      (* check assertions *)
388 351
      (pp_c_checks self) m
389 352
      (* instrs *)
390 353
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
391 354
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
355
      (* locals clear *)
356
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
357
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
392 358
      (fun fmt -> fprintf fmt "return;")
393 359
  else
394 360
    (* C90 code *)
395 361
    let (gen_locals, base_locals) = List.partition (fun v -> Types.is_generic_type v.var_type) m.mstep.step_locals in
396 362
    let gen_calls = List.map (fun e -> let (id, _, _) = call_of_expr e in mk_call_var_decl e.expr_loc id) m.mname.node_gencalls in
397
    fprintf fmt "@[<v 2>%a {@,%a%t@,%a%a%t%t@]@,}@.@."
363
    fprintf fmt "@[<v 2>%a {@,%a%t%a%t@,%a%a%t%a%t%t@]@,}@.@."
398 364
      print_stateless_prototype (m.mname.node_id, (m.mstep.step_inputs@gen_locals@gen_calls), m.mstep.step_outputs)
399 365
      (* locals *)
400 366
      (Utils.fprintf_list ~sep:";@," (pp_c_decl_local_var m)) base_locals
401 367
      (Utils.pp_final_char_if_non_empty ";" base_locals)
368
      (* locals initialization *)
369
      (Utils.fprintf_list ~sep:"@," (pp_initialize m self (pp_c_var_read m))) m.mstep.step_locals
370
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
402 371
      (* check assertions *)
403 372
      (pp_c_checks self) m
404 373
      (* instrs *)
405 374
      (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.mstep.step_instrs
406 375
      (Utils.pp_newline_if_non_empty m.mstep.step_instrs)
376
      (* locals clear *)
377
      (Utils.fprintf_list ~sep:"@," (pp_clear m self (pp_c_var_read m))) m.mstep.step_locals
378
      (Utils.pp_newline_if_non_empty m.mstep.step_locals)
407 379
      (fun fmt -> fprintf fmt "return;")
408 380

  
409 381
let print_reset_code dependencies fmt m self =
......
417 389
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) m.minit
418 390
    (Utils.pp_newline_if_non_empty m.minit)
419 391

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

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

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

  
455 469

  
......
476 490
      let self = mk_self m in
477 491
      (* Reset function *)
478 492
      print_reset_code dependencies fmt m self;
493
      (* Init function *)
494
      print_init_code dependencies fmt m self;
495
      (* Clear function *)
496
      print_clear_code dependencies fmt m self;
479 497
      (* Step function *)
480 498
      print_step_code dependencies fmt m self
481 499
    end
482 500

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

  
484 514
let print_lib_c source_fmt basename prog machines dependencies =
485

  
486
  fprintf source_fmt "#include <assert.h>@.";
487
  if not !Options.static_mem then
488
    begin
489
      fprintf source_fmt "#include <stdlib.h>@.";
490
    end;
515
  print_import_standard source_fmt;
491 516
  print_import_prototype source_fmt (Dep (true, basename, [], true (* assuming it is stateful *)));
492 517
  pp_print_newline source_fmt ();
493 518
  (* Print the svn version number and the supported C standard (C90 or C99) *)

Also available in: Unified diff