Project

General

Profile

Revision 59294251 src/main_lustre_compiler.ml

View differences:

src/main_lustre_compiler.ml
99 99
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
100 100
  header, new_tenv, new_cenv
101 101

  
102
let load_n_check_lusi source_name lusi_name prog computed_types_env computed_clocks_env= 
103
  try 
104
    let _ = open_in lusi_name in
105
    let header = load_lusi true lusi_name in
106
    let _, declared_types_env, declared_clocks_env = check_lusi header in
107
    
108
      (* checking type compatibility with computed types*)
109
    Typing.check_env_compat header declared_types_env computed_types_env;
110
    Typing.uneval_prog_generics prog;
111
    
112
      (* checking clocks compatibility with computed clocks*)
113
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
114
      Clock_calculus.uneval_prog_generics prog;
115

  
116
      (* checking stateless status compatibility *)
117
      Stateless.check_compat header
118
    with Sys_error _ -> ( 
119
      (* Printing lusi file is necessary *)
120
      report ~level:1 
121
	(fun fmt -> 
122
	  fprintf fmt 
123
	    ".. generating lustre interface file %s@," lusi_name);
124
      let lusi_out = open_out lusi_name in
125
      let lusi_fmt = formatter_of_out_channel lusi_out in
126
      Typing.uneval_prog_generics prog;
127
      Clock_calculus.uneval_prog_generics prog;
128
      Printers.pp_lusi_header lusi_fmt source_name prog
129
    )
130
    | (Types.Error (loc,err)) as exc ->
131
      eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@."
132
	Types.pp_error err;
133
      raise exc
134
    | Clocks.Error (loc, err) as exc ->
135
      eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@."
136
	Clocks.pp_error err;
137
      raise exc
138
    | Stateless.Error (loc, err) as exc ->
139
      eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@."
140
	Stateless.pp_error err;
141
      raise exc
102 142
    
103 143
let rec compile basename extension =
144

  
104 145
  (* Loading the input file *)
105 146
  let source_name = basename^extension in
106 147
  Location.input_name := source_name;
107 148
  let lexbuf = Lexing.from_channel (open_in source_name) in
108 149
  Location.init lexbuf source_name;
150

  
109 151
  (* Parsing *)
110 152
  report ~level:1 
111 153
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@," source_name);
......
122 164
	Location.pp_loc loc;
123 165
      raise exc
124 166
  in
167

  
125 168
  (* Extracting dependencies *)
126 169
  report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>.. extracting dependencies@,");
127 170
  let dependencies = 
......
136 179
      try
137 180
	let basename = (if local then s else Version.prefix ^ "/include/lustrec/" ^ s ) ^ ".lusi" in 
138 181
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 0>Library %s@," basename);
139
	  let comp_dep, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
182
	let comp_dep, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
140 183
	report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
141 184
	
142
	  (s, local, comp_dep)::compilation_dep,
143
	  Env.overwrite type_env lusi_type_env,
144
	  Env.overwrite clock_env lusi_clock_env      
185
	(s, local, comp_dep)::compilation_dep,
186
	Env.overwrite type_env lusi_type_env,
187
	Env.overwrite clock_env lusi_clock_env      
145 188
      with Sys_error msg -> (
146 189
	eprintf "Failure: impossible to load library %s.@.%s@." s msg;
147 190
	exit 1
......
149 192
    )  ([], Basic_library.type_env, Basic_library.clock_env) dependencies
150 193
  in
151 194
  report ~level:1 (fun fmt -> fprintf fmt "@]@ ");
152

  
153
  (* Unfold consts *)
154
  (*let prog = Corelang.prog_unfold_consts prog in*)
155

  
195
  
156 196
  (* Sorting nodes *)
157 197
  let prog = SortProg.sort prog in
158 198
  
......
201 241
    end;
202 242
  *)
203 243

  
244
  (* Compatibility with Lusi *)
204 245
  (* Checking the existence of a lusi (Lustre Interface file) *)
205 246
  let lusi_name = basename ^ ".lusi" in
206
  let _ = 
207
    try 
208
      let _ = open_in lusi_name in
209
      let header = load_lusi true lusi_name in
210
      let _, declared_types_env, declared_clocks_env = check_lusi header in
211

  
212
      (* checking type compatibility with computed types*)
213
      Typing.check_env_compat header declared_types_env computed_types_env;
214
      Typing.uneval_prog_generics prog;
215

  
216
      (* checking clocks compatibility with computed clocks*)
217
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
218
      Clock_calculus.uneval_prog_generics prog;
219

  
220
      (* checking stateless status compatibility *)
221
      Stateless.check_compat header
222
    with Sys_error _ -> ( 
223
      (* Printing lusi file is necessary *)
224
      report ~level:1 
225
	(fun fmt -> 
226
	  fprintf fmt 
227
	    ".. generating lustre interface file %s@," lusi_name);
228
      let lusi_out = open_out lusi_name in
229
      let lusi_fmt = formatter_of_out_channel lusi_out in
230
      Typing.uneval_prog_generics prog;
231
      Clock_calculus.uneval_prog_generics prog;
232
      Printers.pp_lusi_header lusi_fmt source_name prog
233
    )
234
    | (Types.Error (loc,err)) as exc ->
235
      eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@."
236
	Types.pp_error err;
237
      raise exc
238
    | Clocks.Error (loc, err) as exc ->
239
      eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@."
240
	Clocks.pp_error err;
241
      raise exc
242
    | Stateless.Error (loc, err) as exc ->
243
      eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@."
244
	Stateless.pp_error err;
245
      raise exc
246
  in
247
  load_n_check_lusi source_name lusi_name prog computed_types_env computed_clocks_env;
247 248

  
248 249
  (* Computes and stores generic calls for each node,
249 250
     only useful for ANSI C90 compliant generic node compilation *)
......
252 253

  
253 254
  (* Normalization phase *)
254 255
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,");
255
  let normalized_prog = Normalization.normalize_prog prog in
256
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog normalized_prog);
256
  let prog = Normalization.normalize_prog prog in
257
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@," Printers.pp_prog prog);
258

  
257 259
  (* Checking array accesses *)
258 260
  if !Options.check then
259 261
    begin
260 262
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,");
261
      Access.check_prog normalized_prog;
263
      Access.check_prog prog;
262 264
    end;
263 265

  
266
  (* Computation of node equation scheduling. It also break dependency cycles. *)
267
  let prog, node_schs = Scheduling.schedule_prog prog in
268

  
269
 (* Optimization of prog: 
270
    - Unfold consts 
271
    - eliminate trivial expressions
272
 *)
273
  let prog = 
274
    if !Options.optimization >= 2 then 
275
      Optimize_prog.prog_unfold_consts prog 
276
    else
277
      prog
278
  in
279

  
264 280
  (* DFS with modular code generation *)
265 281
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,");
266
  let machine_code = Machine_code.translate_prog normalized_prog in
282
  let machine_code = Machine_code.translate_prog prog node_schs in
267 283
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,"
268 284
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
269 285
    machine_code);
286

  
287
  (* Optimize machine code *)
288
  let machine_code = 
289
    if !Options.optimization >= 2 then
290
      Optimize_machine.optimize_machines machine_code
291
    else
292
      machine_code
293
  in
270 294
  
271 295
  (* Creating destination directory if needed *)
272 296
  if not (Sys.file_exists !Options.dest_dir) then (
......
307 331
	    | Some f -> Some (formatter_of_out_channel (open_out f))
308 332
	  in
309 333
	  report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,");
310
	  C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code dependencies
334
	  C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename prog machine_code dependencies
311 335
	end
312 336
    | "java" ->
313 337
      begin
......
324 348
	let source_file = destname ^ ".smt2" in (* Could be changed *)
325 349
	let source_out = open_out source_file in
326 350
	let fmt = formatter_of_out_channel source_out in
327
	Horn_backend.translate fmt basename normalized_prog machine_code
351
	Horn_backend.translate fmt basename prog machine_code
328 352
      end
353
    | "lustre" -> assert false (*
354
      begin
355
	let source_file = destname ^ ".lustrec.lus" in (* Could be changed *)
356
	let source_out = open_out source_file in
357
	let fmt = formatter_of_out_channel source_out in
358
(*	Lustre_backend.translate fmt basename normalized_prog machine_code *)
359
	()
360
      end*)
361

  
329 362
    | _ -> assert false
330 363
  in
331 364
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");

Also available in: Unified diff