heptagon/main/compiler.ml
2010-06-15 10:49:03 +02:00

345 lines
10 KiB
OCaml

(**************************************************************************)
(* *)
(* Heptagon *)
(* *)
(* Author : Marc Pouzet *)
(* Organization : Demons, LRI, University of Paris-Sud, Orsay *)
(* *)
(**************************************************************************)
(* $Id$ *)
open Location
open Misc
open Global
let lexical_error err loc =
Printf.eprintf "%aIllegal character.\n" output_location loc;
raise Error
let syntax_error loc =
Printf.eprintf "%aSyntax error.\n" output_location loc;
raise Error
let language_error lang =
Printf.eprintf "Unknown language: %s.\n" lang
let parse parsing_fun lexing_fun lexbuf =
try
parsing_fun lexing_fun lexbuf
with
| Lexer.Lexical_error(err, pos1, pos2) ->
lexical_error err (Loc(pos1, pos2))
| Parsing.Parse_error ->
let pos1 = Lexing.lexeme_start lexbuf
and pos2 = Lexing.lexeme_end lexbuf in
let l = Loc(pos1,pos2) in
syntax_error l
let comment s = Printf.printf "** %s done **\n" s; flush stdout
let build_path suf =
match !target_path with
| None -> suf
| Some path -> Filename.concat path suf
let clean_dir dir =
if Sys.file_exists dir && Sys.is_directory dir
then begin
let rm_file_in_dir fn = Sys.remove (Filename.concat dir fn) in
Array.iter rm_file_in_dir (Sys.readdir dir);
end else Unix.mkdir dir 0o740;
dir
(** Generation of a dataflow target *)
let dataflow_target filename p target_languages =
let rec one_target = function
(* | "z3z" :: others ->
let dirname = build_path (filename ^ "_z3z") in
let dir = clean_dir dirname in
let p = Dynamic_system.program p in
if !verbose then
comment "Translation into dynamic system (Z/3Z equations)";
Sigali.Printer.print dir p;
one_target others *)
| ("vhdl_df" | "vhdl") :: others ->
let dirname = build_path (filename ^ "_vhdl") in
let dir = clean_dir dirname in
let vhdl = Mls2vhdl.translate (Filename.basename filename) p in
Vhdl.print dir vhdl;
one_target others
| unknown_lg :: others -> unknown_lg :: one_target others
| [] -> [] in
one_target target_languages
(** Generation of a sequential target *)
let sequential_target filename o target_languages =
let rec one_target = function
| "c-old" :: others ->
let dirname = build_path (filename ^ "_c-old") in
let dir = clean_dir dirname in
C_old.print o dir;
one_target others
| "java" :: others ->
let dirname = build_path filename in
let dir = clean_dir dirname in
Java.print dir o;
one_target others
| "c" :: others ->
let dirname = build_path (filename ^ "_c") in
let dir = clean_dir dirname in
let c_ast = Cgen.translate filename o in
C.output dir c_ast;
one_target others
| "caml" :: others -> Caml.print filename o; one_target others
| unknown_lg :: others -> unknown_lg :: one_target others
| [] -> [] in
one_target target_languages
(** Whole translation. *)
let targets filename df obc target_languages =
let target_languages = dataflow_target filename df target_languages in
let target_languages = sequential_target filename obc target_languages in
match target_languages with
| [] -> ()
| target :: _ -> language_error target
let parse_implementation lexbuf =
parse Parser.program Lexer.token lexbuf
let parse_interface lexbuf =
parse Parser.interface Lexer.token lexbuf
let interface modname filename =
(* input and output files *)
let source_name = filename ^ ".epi"
and obj_interf_name = filename ^ ".epci" in
let ic = open_in source_name
and itc = open_out_bin obj_interf_name in
let close_all_files () =
close_in ic;
close_out itc in
try
Location.initialize source_name ic;
Modules.initialize modname;
Initial.initialize ();
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let l = parse_interface lexbuf in
(* Convert the parse tree to Heptagon AST *)
let l = Scoping.translate_interface l in
Interface.Type.main l;
Modules.write itc;
if !print_types then Interface.Printer.print stdout;
close_all_files ()
with
| x -> close_all_files (); raise x
let do_pass f d p pp enabled =
if enabled
then
let r = f p in
if !verbose
then begin
comment d;
pp r;
end;
r
else p
let do_silent_pass f d p enabled =
if enabled
then begin
let r = f p in
if !verbose then comment d; r
end
else p
let compile modname filename =
(* input and output files *)
let source_name = filename ^ ".ept"
and obj_interf_name = filename ^ ".epci"
and mls_name = filename ^ ".mls"
and mls_norm_name = filename ^ "_norm.mls"
and obc_name = filename ^ ".obc"
and ml_name = filename ^ ".ml" in
let ic = open_in source_name
and itc = open_out_bin obj_interf_name
and mlsc = open_out mls_name
and mlsnc = open_out mls_norm_name
and obc = open_out obc_name
and mlc = open_out ml_name in
let close_all_files () =
close_in ic;
close_out itc;
close_out mlsc;
close_out obc;
close_out mlc in
try
Location.initialize source_name ic;
Modules.initialize modname;
Initial.initialize ();
let pp = Printer.print stdout in
(* Parsing of the file *)
let lexbuf = Lexing.from_channel ic in
let p = parse_implementation lexbuf in
(* Convert the parse tree to Heptagon AST *)
let p = Scoping.translate_program p in
if !verbose
then begin
comment "Parsing";
pp p
end;
(* Misc.reset_symbol (); *)
(* Typing *)
let p = do_pass Typing.program "Typing" p pp true in
(* Linear typing *)
let p = do_pass Linear_typing.program "Linear Typing" p pp (not !no_mem_alloc) in
if !print_types then Interface.Printer.print stdout;
Modules.write itc;
(* Causality check *)
let p =
do_silent_pass Causality.program "Causality check" p true in
(* Initialization check *)
let p =
do_silent_pass Initialization.program "Initialization check" p !init in
(* Mark nodes to be inlined *)
(* let to_inline = List.map Misc.mk_longname !nodes_to_inline in
let p = Inline.mark_calls_to to_inline p in
let p = match !node_to_flatten with
| None -> p
| Some nn -> Inline.flatten nn p in
if !verbose then comment "Inlining pre-pass";*)
(* Inline marked nodes *)
(* let p = do_pass Inline.program "Inlining" p pp true in *)
(* Automata memory sharing *)
let p = do_pass Automata_mem.program "Automata memory sharing" p pp (not !no_mem_alloc) in
(* Completion of partial definitions *)
let p = do_pass Completion.program "Completion" p pp true in
(* Automata *)
let p = do_pass Automata.program "Automata" p pp true in
(* Present *)
let p = do_pass Present.program "Present" p pp true in
(* Shared variables (last) *)
let p = do_pass Last.program "Last" p pp true in
(* Reset *)
let reset_prog = if !use_new_reset_encoding then Reset_new.program else Reset.program in
let p = do_pass reset_prog "Reset" p pp true in
(* Every *)
let p = do_pass Every.program "Every" p pp true in
(* Merge and translate the heptagon program into the *)
(* clocked data-flow language mini-ls *)
let pp = Minils.Printer.print stdout in
let p = Merge.program p in
if !verbose then comment "Translation into clocked equations";
Minils.Printer.print mlsc p;
(* Annotation of expressions with their clock *)
let p = Clocking.program p in
(* Mls2dot.program "" p; *)
(** Start of data-flow optimizations *)
(* Normalization to maximize opportunities *)
let p = do_pass Normalize.program "Normalization" p pp true in
(* Back-end causality check. Only useful to check that *)
(* we did not make any mistake during code generation *)
let p =
do_silent_pass Dfcausality.program "Post-pass causality check" p true in
(* Check that the dataflow code is well initialized *)
(*
let p =
do_silent_pass Init.program "Post-pass initialization check" p true in
*)
let sigali = List.mem "z3z" !target_languages in
(* Boolean translation of enumerated values *)
(* let p =
do_pass
Boolean.program "Boolean transformation" p pp (!boolean or sigali) in
*)
(* Normalization to maximize opportunities *)
let p = do_pass Normalize.program "Normalization" p pp true in
(* Mls2dot.program "normalized_" p; *)
let p =
do_pass Deadcode.program "Deadcode removal" p pp !deadcode in
(* Automata minimization *)
let p = do_pass Tommls.program "Automata minimization" p pp !tomato in
(* Common sub-expression elimination *)
let p =
do_pass Cmse.program "Common sub-expression elimination" p pp !cse in
(* Removing intermediate equations *)
let p =
do_pass Intermediate.program "Intermediate-equations removal"
p pp !intermediate in
Mls2dot.program "optimized_" p;
(* Splitting *)
let p = do_pass Splitting.program "Splitting" p pp (not !no_mem_alloc) in
(* Scheduling *)
let scheduler = if !use_interf_scheduler then Schedule_interf.program else Schedule.program in
let p = do_pass scheduler "Scheduling" p pp true in
(* Memory allocation *)
Interference.world.Interference.node_is_scheduled <- true;
let p = do_pass Memalloc.program
"Interference graph building and Memory Allocation" p pp (not !no_mem_alloc) in
(* Parametrized functions instantiation *)
let p = do_pass Callgraph.program
"Parametrized functions instantiation" p pp true in
Minils.Printer.print mlsnc p;
(* Producing Object-based code *)
let o = Translate.program p in
if !verbose then comment "Translation into Object-based code";
Obc.Printer.print obc o;
let pp = Obc.Printer.print stdout in
if !verbose then pp o;
(* Translation into dataflow and sequential languages *)
targets filename p o !target_languages;
close_all_files ();
with x -> close_all_files (); raise x