Project

General

Profile

Revision 7ecfca04 src/main_lustre_mutator.ml

View differences:

src/main_lustre_mutator.ml
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 mutator *)
1
(********************************************************************)
2
(*                                                                  *)
3
(*  The LustreC compiler toolset   /  The LustreC Development Team  *)
4
(*  Copyright 2012 -    --   ONERA - CNRS - INPT                    *)
5
(*                                                                  *)
6
(*  LustreC is free software, distributed WITHOUT ANY WARRANTY      *)
7
(*  under the terms of the GNU Lesser General Public License        *)
8
(*  version 2.1.                                                    *)
9
(*                                                                  *)
10
(********************************************************************)
25 11

  
26 12
open Format
27 13
open Log
28
open Load
29

  
30
let usage = "Usage: lustrem [options] <source-file>"
31

  
32
let extensions = [".ec";".lus"]
33

  
34
      
35
let clock_decls env decls = 
36
  report ~level:1 (fun fmt -> fprintf fmt ".. clock calculus@,@?");
37
  let new_env =
38
    begin
39
      try
40
	Clock_calculus.clock_prog env decls
41
      with (Clocks.Error (loc,err)) as exc ->
42
	Location.print loc;
43
	eprintf "Clock calculus error at loc %a: %a@]@." Location.pp_loc loc Clocks.pp_error err;
44
	raise exc
45
    end
46
  in
47
  if !Options.print_clocks then
48
    report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Corelang.pp_prog_clock decls);
49
  new_env
50
  
51
    
52
let rec mutate basename extension =
53
  (* Loading the input file *)
54
  let source_name = basename^extension in
55
  Location.input_name := source_name;
56
  let lexbuf = Lexing.from_channel (open_in source_name) in
57
  Location.init lexbuf source_name;
58

  
59
  (* Parsing *)
60
  report ~level:1 
61
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
62
  let prog =
63
    try
64
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
65
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
66
      Parse.report_error err;
67
      raise exc
68
  in
14

  
15
open Utils
16
open LustreSpec
17
open Compiler_common
18
 
19
exception StopPhase1 of program
20

  
21
let usage = "Usage: lustrem [options] \x1b[4msource file\x1b[0m"
22

  
23
let extensions = [".ec"; ".lus"; ".lusi"]
24

  
25

  
26

  
27
(* From prog to prog *)
28
let stage1 prog dirname basename =
29
  (* Removing automata *) 
30
  let prog = expand_automata prog in
31

  
32
  Log.report ~level:4 (fun fmt -> fprintf fmt ".. after automata expansion:@.@[<v 2>@ %a@]@," Printers.pp_prog prog);
33

  
34
  (* Importing source *)
35
  let _ = Modules.load_program ISet.empty prog in
69 36

  
70 37
  (* Extracting dependencies *)
71
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
72
  let dependencies = 
73
    List.fold_right 
74
      (fun d accu -> match d.Corelang.top_decl_desc with 
75
      | Corelang.Open s -> s::accu 
76
      | _ -> accu) 
77
      prog [] 
78
  in
79
  let type_env, clock_env =
80
    List.fold_left (fun (type_env, clock_env) s -> 
81
      try
82
	let basename = s ^ ".lusi" in 
83
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
84
	let _, lusi_type_env, lusi_clock_env = check_lusi (load_lusi false basename) in 
85
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
86
	Env.overwrite type_env lusi_type_env,
87
	Env.overwrite clock_env lusi_clock_env      
88
      with Sys_error msg -> (
89
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
90
	exit 1
91
      )
92
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
93
  in
94
  
38
  let dependencies, type_env, clock_env = import_dependencies prog in
39

  
95 40
  (* Sorting nodes *)
96 41
  let prog = SortProg.sort prog in
97
  
42

  
43
  (* Perform inlining before any analysis *)
44
  let orig, prog =
45
    if !Options.global_inline && !Options.main_node <> "" then
46
      (if !Options.witnesses then prog else []),
47
      Inliner.global_inline basename prog type_env clock_env
48
    else (* if !Option.has_local_inline *)
49
      [],
50
      Inliner.local_inline basename prog type_env clock_env
51
  in
52

  
53
  (* Checking stateless/stateful status *)
54
  if Scopes.Plugin.is_active () then
55
    force_stateful_decls prog
56
  else
57
    check_stateless_decls prog;
58

  
98 59
  (* Typing *)
99 60
  let computed_types_env = type_decls type_env prog in
100
  
61

  
101 62
  (* Clock calculus *)
102 63
  let computed_clocks_env = clock_decls clock_env prog in
103 64

  
......
119 80
    let mutant_filename = 
120 81
      match !Options.dest_dir with
121 82
      | "" -> (* Mutants are generated in source directory *)
122
	basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
83
	basename^ ".mutant.n" ^ (string_of_int !cpt) ^ ".lus" 
123 84
      | dir ->  (* Mutants are generated in targer directory *)
124
	dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
85
	dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ ".lus"
125 86
    in
126 87
    let mutant_out = (
127 88
      try 
......
135 96
    Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant    
136 97
  )
137 98
    mutants;
99
  exit 0
100
  
101
let mutate dirname basename extension =
102
  (* Loading the input file *)
103
  let source_name = dirname ^ "/" ^ basename ^ extension in
138 104

  
139
  (*
140

  
141

  
142
  (* Normalization phase *)
143
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
144
  let normalized_prog = Normalization.normalize_prog prog in
145
  Typing.uneval_prog_generics normalized_prog;
146
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
147
  (* Checking array accesses *)
148
  if !Options.check then
149
    begin
150
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,@?");
151
      Access.check_prog normalized_prog;
152
    end;
153

  
154
  (* DFS with modular code generation *)
155
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,@?");
156
  let machine_code = Machine_code.translate_prog normalized_prog in
157
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
158
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
159
    machine_code);
160

  
161
  (* Checking the existence of a lusi (Lustre Interface file) *)
162
  let lusi_name = basename ^ ".lusi" in
163
  let _ = 
164
    try 
165
      let _ = open_in lusi_name in
166
      let _, declared_types_env, declared_clocks_env = load_lusi lusi_name in
167
      (* checking type compatibilty with computed types*)
168
      Typing.check_env_compat declared_types_env computed_types_env;
169
      (* checking clocks compatibilty with computed clocks*)
170
      Clock_calculus.check_env_compat declared_clocks_env computed_clocks_env;
171
      
172
    with Sys_error _ -> ( 
173
      (* Printing lusi file is necessary *)
174
      report ~level:1 
175
	(fun fmt -> 
176
	  fprintf fmt 
177
	    ".. generating lustre interface file %s@,@?" lusi_name);
178
      let lusi_out = open_out lusi_name in
179
      let lusi_fmt = formatter_of_out_channel lusi_out in
180
      Printers.pp_lusi_header lusi_fmt source_name normalized_prog
181
    )
182
    | (Types.Error (loc,err)) as exc ->
183
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
184
	Types.pp_error err;
185
      raise exc
186
  in
105
  Log.report ~level:1 (fun fmt -> fprintf fmt "@[<v>");
106

  
107
   (* Parsing source *)
108
  let prog = parse_source source_name in
109
  stage1 prog dirname basename
187 110

  
188
  (* Printing code *)
189
  let basename    = Filename.basename basename in
190
  if !Options.java then
191
    failwith "Sorry, but not yet supported !"
192
    (*let source_file = basename ^ ".java" in
193
      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
194
      let source_out = open_out source_file in
195
      let source_fmt = formatter_of_out_channel source_out in
196
      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
197
      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
198
  else begin
199
    let header_file = basename ^ ".h" in (* Could be changed *)
200
    let source_file = basename ^ ".c" in (* Could be changed *)
201
    let makefile_file = basename ^ ".makefile" in (* Could be changed *)
202
    let spec_file_opt = if !Options.c_spec then 
203
	(
204
	  let spec_file = basename ^ "_spec.c" in
205
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@,@?" header_file source_file spec_file);
206
	  Some spec_file 
207
	) else (
208
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@,@?" header_file source_file);
209
	  None 
210
	 )
211
    in 
212
    let header_out = open_out header_file in
213
    let header_fmt = formatter_of_out_channel header_out in
214
    let source_out = open_out source_file in
215
    let source_fmt = formatter_of_out_channel source_out in
216
    let makefile_out = open_out makefile_file in
217
    let makefile_fmt = formatter_of_out_channel makefile_out in
218
    let spec_fmt_opt = match spec_file_opt with
219
	None -> None
220
      | Some f -> Some (formatter_of_out_channel (open_out f))
221
    in
222
    report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
223
    C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code;
224
  end;
225
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
226
  (* We stop the process here *)
227
  *)
228
  exit 0
229 111
  
230 112
let anonymous filename =
231
  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
113
  let ok_ext, ext = List.fold_left
114
    (fun (ok, ext) ext' ->
115
      if not ok && Filename.check_suffix filename ext' then
116
	true, ext'
117
      else
118
	ok, ext)
119
    (false, "") extensions in
232 120
  if ok_ext then
233
    let basename = Filename.chop_suffix filename ext in
234
    mutate basename ext
121
    let dirname = Filename.dirname filename in
122
    let basename = Filename.chop_suffix (Filename.basename filename) ext in
123
    mutate dirname basename ext
235 124
  else
236 125
    raise (Arg.Bad ("Can only compile *.lus or *.ec files"))
237 126

  
238 127
let _ =
128
  Global.initialize ();
239 129
  Corelang.add_internal_funs ();
240 130
  try
241 131
    Printexc.record_backtrace true;
242
    Arg.parse Options.lustrem_options anonymous usage
132

  
133
    let options = Options.options @ 
134
      List.flatten (
135
	List.map Options.plugin_opt [
136
	  Scopes.Plugin.name, Scopes.Plugin.activate, Scopes.Plugin.options
137
	]
138
      )
139
    in
140
    
141
    Arg.parse options anonymous usage
243 142
  with
244
  | Parse.Syntax_err _ | Lexer_lustre.Error _ 
143
  | Parse.Error _
245 144
  | Types.Error (_,_) | Clocks.Error (_,_)
246
  | Corelang.Error _ (*| Task_set.Error _*) 
247
  | Causality.Cycle _ -> exit 1
145
  | Corelang.Error _ (*| Task_set.Error _*)
146
  | Causality.Error _ -> exit 1
147
  | Sys_error msg -> (eprintf "Failure: %s@." msg)
248 148
  | exc -> (Utils.track_exception (); raise exc)
249 149

  
250 150
(* Local Variables: *)

Also available in: Unified diff