Project

General

Profile

Revision a1daa793 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

  
33 34
(* Computes the depth to which multi-dimension array assignments should be expanded.
34 35
   It equals the maximum number of nested static array constructions accessible from root [v].
35 36
*)
......
101 102
    List.partition (function (d, LInt _) -> true | _ -> false) loop_vars 
102 103
  in
103 104
  var_loops @ int_loops
104
    
105

  
105 106
(* Prints a one loop variable suffix for arrays *)
106 107
let pp_loop_var fmt lv =
107 108
 match snd lv with
108 109
 | LVar v -> fprintf fmt "[%s]" v
109 110
 | LInt r -> fprintf fmt "[%d]" !r
110
 | LAcc i -> fprintf fmt "[%a]" pp_val i
111
 | LAcc i -> fprintf fmt "[%a]" pp_c_dimension (dimension_of_value i)
111 112

  
112 113
(* Prints a suffix of loop variables for arrays *)
113 114
let pp_suffix fmt loop_vars =
114 115
 Utils.fprintf_list ~sep:"" pp_loop_var fmt loop_vars
115 116

  
116
(* Prints a [value] indexed by the suffix list [loop_vars] *)
117
let rec pp_value_suffix self loop_vars pp_value fmt value =
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;*)
118 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))
119 144
 | (_, LInt r) :: q, Array vl      ->
120
   pp_value_suffix self q pp_value fmt (List.nth vl !r)
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
121 153
 | _           :: q, Power (v, n)  ->
122
   pp_value_suffix self q pp_value fmt v
154
   pp_value_suffix self var_type q pp_value fmt v
123 155
 | _               , Fun (n, vl)   ->
124
   Basic_library.pp_c n (pp_value_suffix self loop_vars pp_value) fmt vl
156
   Basic_library.pp_c n (pp_value_suffix self var_type loop_vars pp_value) fmt vl
125 157
 | _               , Access (v, i) ->
126
   pp_value_suffix self ((Dimension.mkdim_var (), LAcc i) :: loop_vars) pp_value fmt v
127
 | _               , _             ->
128
   let pp_var_suffix fmt v = fprintf fmt "%a%a" pp_value v pp_suffix loop_vars in
129
   pp_c_val self pp_var_suffix fmt value
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
130 176

  
131 177
(* type_directed assignment: array vs. statically sized type
132 178
   - [var_type]: type of variable to be assigned
......
157 203
    match vars with
158 204
    | [] ->
159 205
      fprintf fmt "%a = %a;" 
160
	(pp_value_suffix self loop_vars pp_var) var_name
161
	(pp_value_suffix self loop_vars pp_var) value
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
162 208
    | (d, LVar i) :: q ->
163 209
(*eprintf "pp_aux %a %s@." Dimension.pp_dimension d i;*)
164 210
      fprintf fmt "@[<v 2>{@,int %s;@,for(%s=0;%s<%a;%s++)@,%a @]@,}"
......
177 223
    aux fmt reordered_loop_vars
178 224
  end
179 225

  
180
let pp_instance_call m self fmt i (inputs: value_t list) (outputs: var_decl list) =
181
 try (* stateful node instance *)
182
   let (n,_) = List.assoc i m.minstances in
183
   fprintf fmt "%a (%a%t%a%t%s->%s);"
184
     pp_machine_step_name (node_name n)
185
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
186
     (Utils.pp_final_char_if_non_empty ", " inputs) 
187
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs
188
     (Utils.pp_final_char_if_non_empty ", " outputs)
189
     self
190
     i
191
 with Not_found -> (* stateless node instance *)
192
   let (n,_) = List.assoc i m.mcalls in
193
   fprintf fmt "%a (%a%t%a);"
194
     pp_machine_step_name (node_name n)
195
     (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) inputs
196
     (Utils.pp_final_char_if_non_empty ", " inputs) 
197
     (Utils.fprintf_list ~sep:", " (pp_c_var_write m)) outputs 
198

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

  
210 226
let has_c_prototype funname dependencies =
211 227
  let imported_node_opt = (* We select the last imported node with the name funname.
212 228
			       The order of evaluation of dependencies should be
......
232 248
    | None -> false
233 249
    | Some nd -> (match nd.nodei_prototype with Some "C" -> true | _ -> false)
234 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

  
235 293
let rec pp_conditional dependencies (m: machine_t) self fmt c tl el =
236 294
  fprintf fmt "@[<v 2>if (%a) {%t%a@]@,@[<v 2>} else {%t%a@]@,}"
237
    (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)
238 296
    (Utils.pp_newline_if_non_empty tl)
239 297
    (Utils.fprintf_list ~sep:"@," (pp_machine_instr dependencies m self)) tl
240 298
    (Utils.pp_newline_if_non_empty el)
......
254 312
      i.var_type (StateVar i) v
255 313
  | MStep ([i0], i, vl) when Basic_library.is_internal_fun i  ->
256 314
    pp_machine_instr dependencies m self fmt (MLocalAssign (i0, Fun (i, vl)))
257
  | MStep ([i0], i, vl) when has_c_prototype i dependencies -> 
258
    fprintf fmt "%a = %s(%a);" 
259
      (pp_c_val self (pp_c_var_read m)) (LocalVar i0) 
260
      i
261
      (Utils.fprintf_list ~sep:", " (pp_c_val self (pp_c_var_read m))) vl
262 315
  | MStep (il, i, vl) ->
263
    pp_instance_call m self fmt i vl il
264
  | MBranch (g,hl) ->
265
    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
266 320
    then (* boolean case, needs special treatment in C because truth value is not unique *)
267 321
	 (* may disappear if we optimize code by replacing last branch test with default *)
268 322
      let tl = try List.assoc tag_true  hl with Not_found -> [] in
269 323
      let el = try List.assoc tag_false hl with Not_found -> [] in
270 324
      pp_conditional dependencies m self fmt g tl el
271 325
    else (* enum type case *)
326
      let g_typ = Typing.type_const Location.dummy_loc (Const_tag (fst (List.hd hl))) in
272 327
      fprintf fmt "@[<v 2>switch(%a) {@,%a@,}@]"
273
	(pp_c_val self (pp_c_var_read m)) g
328
	(pp_c_val self (pp_c_var_read m)) (g_typ, g)
274 329
	(Utils.fprintf_list ~sep:"@," (pp_machine_branch dependencies m self)) hl
275 330

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

Also available in: Unified diff