Project

General

Profile

Revision 89137ae1 src/backends/C/c_backend_src.ml

View differences:

src/backends/C/c_backend_src.ml
147 147
 | loop_var    :: q, Array vl      ->
148 148
   let var_type = Types.array_element_type var_type in
149 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
150 153
 | _           :: q, Power (v, n)  ->
151 154
   pp_value_suffix self var_type q pp_value fmt v
152 155
 | _               , Fun (n, vl)   ->
......
164 167
 | _               , Cst cst       -> pp_c_const_suffix var_type fmt cst
165 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)
166 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
176

  
167 177
(* type_directed assignment: array vs. statically sized type
168 178
   - [var_type]: type of variable to be assigned
169 179
   - [var_name]: name of variable to be assigned
......
213 223
    aux fmt reordered_loop_vars
214 224
  end
215 225

  
216
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
217
 try (* stateful node instance *)
218
   let (n,_) = List.assoc i m.minstances in
219
   fprintf fmt "%a (%a%t%a%t%s->%s);"
220
     pp_machine_step_name (node_name n)
221
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
222
     (Utils.pp_final_char_if_non_empty ", " inputs) 
223
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
224
     (Utils.pp_final_char_if_non_empty ", " outputs)
225
     self
226
     i
227
 with Not_found -> (* stateless node instance *)
228
   let (n,_) = List.assoc i m.mcalls in
229
   fprintf fmt "%a (%a%t%a);"
230
     pp_machine_step_name (node_name n)
231
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
232
     (Utils.pp_final_char_if_non_empty ", " inputs) 
233
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
234

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

  
246 226
let has_c_prototype funname dependencies =
247 227
  let imported_node_opt = (* We select the last imported node with the name funname.
248 228
			       The order of evaluation of dependencies should be
......
268 248
    | None -> false
269 249
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
270 250

  
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

  
271 293
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
272 294
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
273
    (pp_c_val self (pp_c_var_read m)) c
295
    (pp_c_val self (pp_c_var_read m)) (Type_predef.type_bool, c)
274 296
    (Utils.pp_newline_if_non_empty tl)
275 297
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
276 298
    (Utils.pp_newline_if_non_empty el)
......
290 312
      i.var_type (StateVar i) v
291 313
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
292 314
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
293
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
294
    fprintf fmt "%a = %s(%a);" 
295
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
296
      i
297
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
298 315
  | MStep (il, i, vl) ->
299
    pp_instance_call m self fmt i vl il
300
  | MBranch (g,hl) ->
301
    if hl <> [] && let t = fst (List.hd hl) in t = tag_true || t = tag_false
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
302 320
    then (* boolean case, needs special treatment in C because truth value is not unique *)
303 321
	 (* may disappear if we optimize code by replacing last branch test with default *)
304 322
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
305 323
      let el = try List.assoc tag_false hl with Not_found -> [] in
306 324
      pp_conditional dependencies m self fmt g tl el
307 325
    else (* enum type case *)
326
      let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in
308 327
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
309
	(pp_c_val self (pp_c_var_read m)) g
328
	(pp_c_val self (pp_c_var_read m)) (g_typ, g)
310 329
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
311 330

  
312 331
and pp_machine_branch dependencies m self fmt (t, h) =

Also available in: Unified diff