Project

General

Profile

Statistics
| Branch: | Tag: | Revision:

lustrec / src / main_lustre_compiler.ml @ 5538b7ac

History | View | Annotate | Download (12.4 KB)

1
(* ----------------------------------------------------------------------------
2
 * SchedMCore - A MultiCore Scheduling Framework
3
 * Copyright (C) 2009-2013, ONERA, Toulouse, FRANCE - LIFL, Lille, FRANCE
4
 * Copyright (C) 2012-2013, INPT, Toulouse, FRANCE
5
 *
6
 * This file is part of Prelude
7
 *
8
 * Prelude is free software; you can redistribute it and/or
9
 * modify it under the terms of the GNU Lesser General Public License
10
 * as published by the Free Software Foundation ; either version 2 of
11
 * the License, or (at your option) any later version.
12
 *
13
 * Prelude is distributed in the hope that it will be useful, but
14
 * WITHOUT ANY WARRANTY ; without even the implied warranty of
15
 * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
16
 * Lesser General Public License for more details.
17
 *
18
 * You should have received a copy of the GNU Lesser General Public
19
 * License along with this program ; if not, write to the Free Software
20
 * Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307
21
 * USA
22
 *---------------------------------------------------------------------------- *)
23

    
24
(* This module is used for the lustre to C compiler *)
25

    
26
open Format
27
open Log
28

    
29
let usage = "Usage: lustrec [options] <source-file>"
30

    
31
let extensions = [".ec"; ".lus"; ".lusi"]
32

    
33
let check_stateless_decls decls =
34
  report ~level:1 (fun fmt -> fprintf fmt ".. checking stateless/stateful status@,@?");
35
  try
36
    Stateless.check_prog decls
37
  with (Stateless.Error (loc, err)) as exc ->
38
    Format.eprintf "Stateless status error at loc %a: %a@]@."
39
      Location.pp_loc loc
40
      Stateless.pp_error err;
41
    raise exc
42

    
43
let type_decls env decls =  
44
  report ~level:1 (fun fmt -> fprintf fmt ".. typing@,@?");
45
  let new_env = 
46
    begin
47
      try
48
	Typing.type_prog env decls
49
      with (Types.Error (loc,err)) as exc ->
50
	Format.eprintf "Typing error at loc %a: %a@]@."
51
	  Location.pp_loc loc
52
	  Types.pp_error err;
53
	raise exc
54
    end 
55
  in
56
  if !Options.print_types then
57
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_type decls);
58
  new_env
59
      
60
let clock_decls env decls = 
61
  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");
62
  let new_env =
63
    begin
64
      try
65
	Clock_calculus.clock_prog env decls
66
      with (Clocks.Error (loc,err)) as exc ->
67
	Location.print loc;
68
	eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;
69
	raise exc
70
    end
71
  in
72
  if !Options.print_clocks then
73
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);
74
  new_env
75

    
76
(* Loading Lusi file and filling type tables with parsed
77
   functions/nodes *)
78
let load_lusi own filename =
79
  Location.input_name := filename;
80
  let lexbuf = Lexing.from_channel (open_in filename) in
81
  Location.init lexbuf filename;
82
  (* Parsing *)
83
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
84
  try
85
    Parse.header own Parser_lustre.header Lexer_lustre.token lexbuf
86
  with
87
  | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
88
    Parse.report_error err;
89
    raise exc
90
  | Corelang.Error (loc, err) as exc ->
91
     Format.eprintf "Parsing error at loc %a: %a@]@."
92
       Location.pp_loc loc
93
       Corelang.pp_error err;
94
     raise exc
95

    
96
let check_lusi header =
97
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
98
  let new_cenv = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
99
  header, new_tenv, new_cenv
100
    
101
let rec compile basename extension =
102
  (* Loading the input file *)
103
  let source_name = basename^extension in
104
  Location.input_name := source_name;
105
  let lexbuf = Lexing.from_channel (open_in source_name) in
106
  Location.init lexbuf source_name;
107
  (* Parsing *)
108
  report ~level:1 
109
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
110
  let prog =
111
    try
112
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
113
    with
114
    | (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
115
      Parse.report_error err;
116
      raise exc
117
    | Corelang.Error (loc, err) as exc ->
118
      Format.eprintf "Parsing error at loc %a: %a@]@."
119
	Location.pp_loc loc
120
	Corelang.pp_error err;
121
      raise exc
122
  in
123
  (* Extracting dependencies *)
124
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
125
  let dependencies = 
126
    List.fold_right 
127
      (fun d accu -> match d.Corelang.top_decl_desc with 
128
      | Corelang.Open s -> s::accu 
129
      | _ -> accu) 
130
      prog [] 
131
  in
132
  let type_env, clock_env =
133
    List.fold_left (fun (type_env, clock_env) s -> 
134
      try
135
	let basename = s ^ ".lusi" in 
136
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
137
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
138
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
139
	Env.overwrite type_env lusi_type_env,
140
	Env.overwrite clock_env lusi_clock_env      
141
      with Sys_error msg -> (
142
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
143
	exit 1
144
      )
145
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
146
  in
147
  
148
  (* Unfold consts *)
149
  (*let prog = Corelang.prog_unfold_consts prog in*)
150

    
151
  (* Sorting nodes *)
152
  let prog = SortProg.sort prog in
153
  
154
  (* Checking stateless/stateful status *)
155
  check_stateless_decls prog;
156

    
157
  (* Typing *)
158
  let computed_types_env = type_decls type_env prog in
159
  
160
  (* Clock calculus *)
161
  let computed_clocks_env = clock_decls clock_env prog in
162

    
163
  (* Perform global inlining *)
164
  let prog =
165
    if !Options.global_inline && 
166
      (match !Options.main_node with | "" -> false | _ -> true) then
167
      Inliner.global_inline basename prog type_env clock_env
168
    else
169
      prog
170
  in
171

    
172
  (* Delay calculus *)
173
  (*
174
    if(!Options.delay_calculus)
175
    then
176
    begin
177
    report ~level:1 (fun fmt -> fprintf fmt ".. initialisation analysis@?");
178
    try
179
    Delay_calculus.delay_prog Basic_library.delay_env prog
180
    with (Delay.Error (loc,err)) as exc ->
181
    Location.print loc;
182
    eprintf "%a" Delay.pp_error err;
183
    Utils.track_exception ();
184
    raise exc
185
    end;
186
  *)
187
  (*
188
    eprintf "Causality analysis@.@?";
189
    (* Causality analysis *)
190
    begin
191
    try
192
    Causality.check_causal_prog prog
193
    with (Causality.Cycle v) as exc ->
194
    Causality.pp_error err_formatter v;
195
    raise exc
196
    end;
197
  *)
198

    
199
  (* Checking the existence of a lusi (Lustre Interface file) *)
200
  let lusi_name = basename ^ ".lusi" in
201
  let _ = 
202
    try 
203
      let _ = open_in lusi_name in
204
      let header = load_lusi true lusi_name in
205
      let _, declared_types_env, declared_clocks_env = check_lusi header in
206
      (* checking type compatibility with computed types*)
207
      Typing.check_env_compat header declared_types_env computed_types_env;
208
      Typing.uneval_prog_generics prog;
209
      (* checking clocks compatibility with computed clocks*)
210
      Clock_calculus.check_env_compat header declared_clocks_env computed_clocks_env;
211
      Clock_calculus.uneval_prog_generics prog;
212
      (* checking stateless status compatibility *)
213
      Stateless.check_compat header
214
    with Sys_error _ -> ( 
215
      (* Printing lusi file is necessary *)
216
      report ~level:1 
217
	(fun fmt -> 
218
	  fprintf fmt 
219
	    ".. generating lustre interface file %s@,@?" lusi_name);
220
      let lusi_out = open_out lusi_name in
221
      let lusi_fmt = formatter_of_out_channel lusi_out in
222
      Typing.uneval_prog_generics prog;
223
      Clock_calculus.uneval_prog_generics prog;
224
      Printers.pp_lusi_header lusi_fmt source_name prog
225
    )
226
    | (Types.Error (loc,err)) as exc ->
227
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
228
	Types.pp_error err;
229
      raise exc
230
    | Clocks.Error (loc, err) as exc ->
231
      Format.eprintf "Clock mismatch between computed clock and declared clock in lustre interface file: %a@]@."
232
	Clocks.pp_error err;
233
      raise exc
234
    | Stateless.Error (loc, err) as exc ->
235
      Format.eprintf "Stateless status mismatch between defined status and declared status in lustre interface file: %a@]@."
236
	Stateless.pp_error err;
237
      raise exc
238
  in
239

    
240
  (* Computes and stores generic calls for each node,
241
     only useful for ANSI C90 compliant generic node compilation *)
242
  if !Options.ansi then Causality.NodeDep.compute_generic_calls prog;
243
  (*Hashtbl.iter (fun id td -> match td.Corelang.top_decl_desc with Corelang.Node nd -> Format.eprintf "%s calls %a" id Causality.NodeDep.pp_generic_calls nd | _ -> ()) Corelang.node_table;*)
244

    
245
  (* Normalization phase *)
246
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
247
  let normalized_prog = Normalization.normalize_prog prog in
248
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
249
  (* Checking array accesses *)
250
  if !Options.check then
251
    begin
252
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,@?");
253
      Access.check_prog normalized_prog;
254
    end;
255

    
256
  (* DFS with modular code generation *)
257
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,@?");
258
  let machine_code = Machine_code.translate_prog normalized_prog in
259
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
260
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
261
    machine_code);
262
  
263
  (* Creating destination directory if needed *)
264
  if not (Sys.file_exists !Options.dest_dir) then (
265
    report ~level:1 (fun fmt -> fprintf fmt ".. creating destination directory@,@?");
266
    Unix.mkdir !Options.dest_dir (Unix.stat ".").Unix.st_perm
267
  );
268
  if (Unix.stat !Options.dest_dir).Unix.st_kind <> Unix.S_DIR then (
269
    Format.eprintf "Failure: destination %s is not a directory.@.@." !Options.dest_dir;
270
    exit 1
271
  );
272
  (* Printing code *)
273
  let basename    =  Filename.basename basename in
274
  let destname = !Options.dest_dir ^ "/" ^ basename in
275
  let _ = match !Options.output with
276
      "C" -> 
277
	begin
278
	  let header_file = destname ^ ".h" in (* Could be changed *)
279
	  let source_file = destname ^ ".c" in (* Could be changed *)
280
	  let makefile_file = destname ^ ".makefile" in (* Could be changed *)
281
	  let spec_file_opt = if !Options.c_spec then 
282
	      (
283
		let spec_file = basename ^ "_spec.c" in
284
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@,@?" header_file source_file spec_file);
285
		Some spec_file 
286
	      ) else (
287
		report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@,@?" header_file source_file);
288
		None 
289
	       )
290
	  in 
291
	  let header_out = open_out header_file in
292
	  let header_fmt = formatter_of_out_channel header_out in
293
	  let source_out = open_out source_file in
294
	  let source_fmt = formatter_of_out_channel source_out in
295
	  let makefile_out = open_out makefile_file in
296
	  let makefile_fmt = formatter_of_out_channel makefile_out in
297
	  let spec_fmt_opt = match spec_file_opt with
298
	      None -> None
299
	    | Some f -> Some (formatter_of_out_channel (open_out f))
300
	  in
301
	  report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
302
	  C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code dependencies
303
	end
304
    | "java" ->
305
      begin
306
	failwith "Sorry, but not yet supported !"
307
    (*let source_file = basename ^ ".java" in
308
      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
309
      let source_out = open_out source_file in
310
      let source_fmt = formatter_of_out_channel source_out in
311
      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
312
      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
313
      end
314
    | "horn" ->
315
      begin
316
	let source_file = destname ^ ".smt2" in (* Could be changed *)
317
	let source_out = open_out source_file in
318
	let fmt = formatter_of_out_channel source_out in
319
	Horn_backend.translate fmt basename normalized_prog machine_code
320
      end
321
    | _ -> assert false
322
  in
323
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
324
  (* We stop the process here *)
325
  exit 0
326
  
327
let anonymous filename =
328
  let ok_ext, ext = List.fold_left (fun (ok, ext) ext' -> if not ok && Filename.check_suffix filename ext' then true, ext' else ok, ext) (false, "") extensions in
329
  if ok_ext then
330
    let basename = Filename.chop_suffix filename ext in
331
    compile basename ext
332
  else
333
    raise (Arg.Bad ("Can only compile *.lusi, *.lus or *.ec files"))
334

    
335
let _ =
336
  Corelang.add_internal_funs ();
337
  try
338
    Printexc.record_backtrace true;
339
    Arg.parse Options.options anonymous usage
340
  with
341
  | Parse.Syntax_err _ | Lexer_lustre.Error _ 
342
  | Types.Error (_,_) | Clocks.Error (_,_)
343
  | Corelang.Error _ (*| Task_set.Error _*) 
344
  | Causality.Cycle _ -> exit 1
345
  | exc -> (Utils.track_exception (); raise exc)
346

    
347
(* Local Variables: *)
348
(* compile-command:"make -C .." *)
349
(* End: *)