Project

General

Profile

Revision 89137ae1

View differences:

src/backends/C/c_backend_common.ml
94 94

  
95 95
let rec pp_c_dimension fmt dim =
96 96
  match dim.Dimension.dim_desc with
97
  | Dident id       ->
97
  | Dimension.Dident id       ->
98 98
    fprintf fmt "%s" id
99
  | Dint i          ->
99
  | Dimension.Dint i          ->
100 100
    fprintf fmt "%d" i
101
  | Dbool b         ->
101
  | Dimension.Dbool b         ->
102 102
    fprintf fmt "%B" b
103
  | Dite (i, t, e)  ->
103
  | Dimension.Dite (i, t, e)  ->
104 104
    fprintf fmt "((%a)?%a:%a)"
105 105
       pp_c_dimension i pp_c_dimension t pp_c_dimension e
106
 | Dappl (f, args) ->
106
 | Dimension.Dappl (f, args) ->
107 107
     fprintf fmt "%a" (Basic_library.pp_c f pp_c_dimension) args
108
 | Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
109
 | Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.dim_id)
110
 | Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.dim_id)
108
 | Dimension.Dlink dim' -> fprintf fmt "%a" pp_c_dimension dim'
109
 | Dimension.Dvar       -> fprintf fmt "_%s" (Utils.name_of_dimension dim.Dimension.dim_id)
110
 | Dimension.Dunivar    -> fprintf fmt "'%s" (Utils.name_of_dimension dim.Dimension.dim_id)
111 111

  
112 112
let is_basic_c_type t =
113 113
  match (Types.repr t).Types.tdesc with
......
152 152
let pp_c_tag fmt t =
153 153
 pp_print_string fmt (if t = tag_true then "1" else if t = tag_false then "0" else t)
154 154

  
155

  
155 156
(* Prints a constant value *)
156 157
let rec pp_c_const fmt c =
157 158
  match c with
......
168 169
   but an offset suffix may be added for array variables
169 170
*)
170 171
let rec pp_c_val self pp_var fmt v =
172
  (*Format.eprintf "C_backend_common.pp_c_val %a@." pp_val v;*)
171 173
  match v with
172 174
  | Cst c         -> pp_c_const fmt c
173 175
  | Array vl      -> fprintf fmt "{%a}" (Utils.fprintf_list ~sep:", " (pp_c_val self pp_var)) vl
174 176
  | Access (t, i) -> fprintf fmt "%a[%a]" (pp_c_val self pp_var) t (pp_c_val self pp_var) i
175
  | Power (v, n)  -> assert false
177
  | Power (v, n)  -> (Format.eprintf "internal error: C_backend_common.pp_c_val %a@." pp_val v; assert false)
176 178
  | LocalVar v    -> pp_var fmt v
177 179
  | StateVar v    ->
178 180
    (* array memory vars are represented by an indirection to a local var with the right type,
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) =
src/main_lustre_compiler.ml
268 268

  
269 269
  if !Options.optimization >= 2 then
270 270
    begin
271
      Log.report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
271
      Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
272 272
	(Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
273 273
	machine_code);
274 274
    end;
275 275

  
276
  Log.report ~level:3 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
277
  (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
278
  machine_code);
279

  
280 276
  (* Printing code *)
281 277
  let basename    =  Filename.basename basename in
282 278
  let destname = !Options.dest_dir ^ "/" ^ basename in
src/optimize_machine.ml
53 53
let eliminate_dim elim dim =
54 54
  Dimension.expr_replace_expr (fun v -> try dimension_of_value (IMap.find v elim) with Not_found -> mkdim_ident dim.dim_loc v) dim
55 55

  
56
let unfold_expr_offset m offset expr =
57
  List.fold_left (fun res -> (function Index i -> Access(res, value_of_dimension m i) | Field f -> failwith "not yet implemented")) expr offset
58

  
59
let rec simplify_cst_expr m offset cst =
60
    match offset, cst with
61
    | []          , _
62
        -> Cst cst
63
    | Index i :: q, Const_array cl when Dimension.is_dimension_const i
64
	-> simplify_cst_expr m q (List.nth cl (Dimension.size_const_dimension i))
65
    | Index i :: q, Const_array cl
66
        -> unfold_expr_offset m [Index i] (Array (List.map (simplify_cst_expr m q) cl))
67
    | Field f :: q, Const_struct fl
68
        -> simplify_cst_expr m q (List.assoc f fl)
69
    | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_cst_expr %a@." Printers.pp_const cst; assert false)
70

  
71
let simplify_expr_offset m expr =
72
  let rec simplify offset expr =
73
    match offset, expr with
74
    | Field f ::q , _                -> failwith "not yet implemented"
75
    | _           , Fun (id, vl) when Basic_library.is_internal_fun id
76
                                     -> Fun (id, List.map (simplify offset) vl)
77
    | _           , Fun _
78
    | _           , StateVar _
79
    | _           , LocalVar _       -> unfold_expr_offset m offset expr
80
    | _           , Cst cst          -> simplify_cst_expr m offset cst
81
    | _           , Access (expr, i) -> simplify (Index (dimension_of_value i) :: offset) expr
82
    | []          , _                -> expr
83
    | Index _ :: q, Power (expr, _)  -> simplify q expr
84
    | Index i :: q, Array vl when Dimension.is_dimension_const i
85
                                     -> simplify q (List.nth vl (Dimension.size_const_dimension i))
86
    | Index i :: q, Array vl         -> unfold_expr_offset m [Index i] (Array (List.map (simplify q) vl))
87
    | _ -> (Format.eprintf "internal error: Optimize_machine.simplify_expr_offset %a@." pp_val expr; assert false)
88
    (*Format.eprintf "simplify_expr %a %a = %a@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset pp_val res; res)
89
     with e -> (Format.eprintf "simplify_expr %a %a = <FAIL>@." pp_val expr (Utils.fprintf_list ~sep:"" Printers.pp_offset) offset; raise e*)
90
  in simplify [] expr
91

  
92
let rec simplify_instr_offset m instr =
93
  match instr with
94
  | MLocalAssign (v, expr) -> MLocalAssign (v, simplify_expr_offset m expr)
95
  | MStateAssign (v, expr) -> MStateAssign (v, simplify_expr_offset m expr)
96
  | MReset id              -> instr
97
  | MStep (outputs, id, inputs) -> MStep (outputs, id, List.map (simplify_expr_offset m) inputs)
98
  | MBranch (cond, brl)
99
    -> MBranch(simplify_expr_offset m cond, List.map (fun (l, il) -> l, simplify_instrs_offset m il) brl)
100

  
101
and simplify_instrs_offset m instrs =
102
  List.map (simplify_instr_offset m) instrs
103

  
56 104
let is_scalar_const c =
57 105
  match c with
58 106
  | Const_int _
......
61 109
  | Const_tag _   -> true
62 110
  | _             -> false
63 111

  
64
let basic_unfoldable_expr expr =
65
  match expr with
66
  | Cst c when is_scalar_const c -> true
67
  | LocalVar _
68
  | StateVar _                   -> true
69
  | _                            -> false
112
(* An instruction v = expr may (and will) be unfolded iff:
113
   - either expr is atomic
114
     (no complex expressions, only const, vars and array/struct accesses)
115
   - or v has a fanin <= 1 (used at most once)
116
*)
117
let is_unfoldable_expr fanin expr =
118
  let rec unfold_const offset cst =
119
    match offset, cst with
120
    | _           , Const_int _
121
    | _           , Const_real _
122
    | _           , Const_float _
123
    | _           , Const_tag _     -> true
124
    | Field f :: q, Const_struct fl -> unfold_const q (List.assoc f fl)
125
    | []          , Const_struct _  -> false
126
    | Index i :: q, Const_array cl when Dimension.is_dimension_const i
127
                                    -> unfold_const q (List.nth cl (Dimension.size_const_dimension i))
128
    | _           , Const_array _   -> false
129
    | _                             -> assert false in
130
  let rec unfold offset expr =
131
    match offset, expr with
132
    | _           , Cst cst                      -> unfold_const offset cst
133
    | _           , LocalVar _
134
    | _           , StateVar _                   -> true
135
    | []          , Power _
136
    | []          , Array _                      -> false
137
    | Index i :: q, Power (v, _)                 -> unfold q v
138
    | Index i :: q, Array vl when Dimension.is_dimension_const i
139
                                                 -> unfold q (List.nth vl (Dimension.size_const_dimension i))
140
    | _           , Array _                      -> false
141
    | _           , Access (v, i)                -> unfold (Index (dimension_of_value i) :: offset) v
142
    | _           , Fun (id, vl) when fanin < 2 && Basic_library.is_internal_fun id
143
                                                 -> List.for_all (unfold offset) vl
144
    | _           , Fun _                        -> false
145
    | _                                          -> assert false
146
  in unfold [] expr
70 147

  
71 148
let unfoldable_assign fanin v expr =
72 149
  try
73 150
    let d = Hashtbl.find fanin v.var_id
74
    in basic_unfoldable_expr expr ||
151
    in is_unfoldable_expr d expr
152
  with Not_found -> false
153
(*
154
let unfoldable_assign fanin v expr =
155
  try
156
    let d = Hashtbl.find fanin v.var_id
157
    in is_basic_expr expr ||
75 158
    match expr with
76 159
    | Cst c when d < 2                                           -> true
77 160
    | Fun (id, _) when d < 2 && Basic_library.is_internal_fun id -> true
78 161
    | _                                                          -> false
79 162
  with Not_found -> false
80

  
163
*)
81 164
let merge_elim elim1 elim2 =
82 165
  let merge k e1 e2 =
83 166
    match e1, e2 with
......
142 225
  (*Log.report ~level:1 (fun fmt -> Format.fprintf fmt "machine_unfold %a@." pp_elim elim);*)
143 226
  let elim_consts, mconst = instrs_unfold fanin elim machine.mconst in
144 227
  let elim_vars, instrs = instrs_unfold fanin elim_consts machine.mstep.step_instrs in
228
  let instrs = simplify_instrs_offset machine instrs in
229
  let checks = List.map (fun (loc, check) -> loc, eliminate_expr elim_vars check) machine.mstep.step_checks in
145 230
  let locals = List.filter (fun v -> not (IMap.mem v.var_id elim_vars)) machine.mstep.step_locals in
146 231
  let minstances = List.map (static_call_unfold elim_consts) machine.minstances in
147 232
  let mcalls = List.map (static_call_unfold elim_consts) machine.mcalls
......
151 236
      mstep = { 
152 237
	machine.mstep with 
153 238
	  step_locals = locals;
154
	  step_instrs = instrs
239
	  step_instrs = instrs;
240
	  step_checks = checks
155 241
      };
156 242
      mconst = mconst;
157 243
      minstances = minstances;
......
257 343
  (* Simple cases*)
258 344
  | MStep([v], id, vl) when Basic_library.is_internal_fun id
259 345
      -> instr_cse (subst, instrs) (MLocalAssign (v, Fun (id, vl)))
260
  | MLocalAssign(v, expr) when basic_unfoldable_expr expr
346
  | MLocalAssign(v, expr) when is_unfoldable_expr 2 expr
261 347
      -> (IMap.add v.var_id expr subst, instr :: instrs)
262 348
  | _ when is_assign instr
263 349
      -> subst_instr subst instrs instr
src/printers.ml
332 332
  fprintf fmt "(* by Lustre-C compiler version %s, %a *)@." Version.number pp_date (Unix.gmtime (Unix.time ()));
333 333
  fprintf fmt "(* Feel free to mask some of the definitions by removing them from this file. *)@.@.";
334 334
  List.iter (fprintf fmt "%a@." pp_lusi) prog    
335
  
335

  
336
let pp_offset fmt offset =
337
  match offset with
338
  | Index i -> fprintf fmt "[%a]" Dimension.pp_dimension i
339
  | Field f -> fprintf fmt ".%s" f
340

  
336 341
(* Local Variables: *)
337 342
(* compile-command:"make -C .." *)
338 343
(* End: *)
src/typing.ml
336 336
  (*Format.eprintf "subtyping const %B real %a:%a vs formal %a@." const Printers.pp_expr real_arg Types.print_ty real_type Types.print_ty formal_type;*)
337 337
  try_unify ~sub:sub formal_type real_type loc
338 338

  
339
and type_ident env in_main loc const id =
340
  type_expr env in_main const (expr_of_ident id loc)
341

  
342 339
(* typing an application implies:
343 340
   - checking that const formal parameters match real const (maybe symbolic) arguments
344 341
   - checking type adequation between formal and real arguments
......
452 449
    | Some c -> 
453 450
      check_constant expr.expr_loc const false;	
454 451
      type_subtyping_arg env in_main const c Type_predef.type_bool);
455
    let touts = type_appl env in_main expr.expr_loc const id (expr_list_of_expr args) in
452
    let args_list = expr_list_of_expr args in
453
    let touts = type_appl env in_main expr.expr_loc const id args_list in
454
    args.expr_type <- new_ty (Ttuple (List.map (fun a -> a.expr_type) args_list));
456 455
    expr.expr_type <- touts;
457 456
    touts
458 457
  | Expr_fby (e1,e2)
......
697 696
  | TypeDef _ -> List.fold_left type_top_decl env (consts_of_enum_type decl)
698 697
  | Open _  -> env
699 698

  
699
let get_type_of_call decl =
700
  match decl.top_decl_desc with
701
  | Node nd         ->
702
    let (in_typ, out_typ) = split_arrow nd.node_type in
703
    type_list_of_type in_typ, type_list_of_type out_typ
704
  | ImportedNode nd ->
705
    let (in_typ, out_typ) = split_arrow nd.nodei_type in
706
    type_list_of_type in_typ, type_list_of_type out_typ
707
  | _               -> assert false
708

  
700 709
let type_prog env decls =
701 710
try
702 711
  List.fold_left type_top_decl env decls

Also available in: Unified diff