Project

General

Profile

Revision f30a2012

View differences:

_oasis
20 20
  Command: make test-compile 
21 21
  WorkingDirectory: test
22 22
  Run: true
23
Executable lustrem
24
  Path:       src
25
  BuildTools: ocamlbuild
26
  MainIs:     main_lustre_mutator.ml
27
  BuildDepends: ocamlgraph,str,unix
28
  CompiledObject: native
_tags
1 1
# OASIS_START
2
# DO NOT EDIT (digest: 54aa7498411485980381101fb69226dd)
2
# DO NOT EDIT (digest: e6ba8fd5bf2047819b329a6e17ea3b1f)
3 3
# Executable lustrec
4 4
"src/main_lustre_compiler.native": pkg_unix
5 5
"src/main_lustre_compiler.native": pkg_str
6 6
"src/main_lustre_compiler.native": pkg_ocamlgraph
7
# Executable lustrem
8
"src/main_lustre_mutator.native": pkg_unix
9
"src/main_lustre_mutator.native": pkg_str
10
"src/main_lustre_mutator.native": pkg_ocamlgraph
7 11
<src/*.ml{,i}>: pkg_unix
8 12
<src/*.ml{,i}>: pkg_str
9 13
<src/*.ml{,i}>: pkg_ocamlgraph
setup.ml
1 1
(* setup.ml generated for the first time by OASIS v0.2.0 *)
2 2

  
3 3
(* OASIS_START *)
4
(* DO NOT EDIT (digest: bfbef9a3c28e55b657d10679aeb14c68) *)
4
(* DO NOT EDIT (digest: 288c7853541e9b001252c37919a5ce7b) *)
5 5
(*
6 6
   Regenerated by OASIS v0.2.0
7 7
   Visit http://oasis.forge.ocamlcore.org for more information and
......
5221 5221
                      exec_custom = false;
5222 5222
                      exec_main_is = "main_lustre_compiler.ml";
5223 5223
                      });
5224
               Executable
5225
                 ({
5226
                     cs_name = "lustrem";
5227
                     cs_data = PropList.Data.create ();
5228
                     cs_plugin_data = [];
5229
                     },
5230
                   {
5231
                      bs_build = [(OASISExpr.EBool true, true)];
5232
                      bs_install = [(OASISExpr.EBool true, true)];
5233
                      bs_path = "src";
5234
                      bs_compiled_object = Native;
5235
                      bs_build_depends =
5236
                        [
5237
                           FindlibPackage ("ocamlgraph", None);
5238
                           FindlibPackage ("str", None);
5239
                           FindlibPackage ("unix", None)
5240
                        ];
5241
                      bs_build_tools = [ExternalTool "ocamlbuild"];
5242
                      bs_c_sources = [];
5243
                      bs_data_files = [];
5244
                      bs_ccopt = [(OASISExpr.EBool true, [])];
5245
                      bs_cclib = [(OASISExpr.EBool true, [])];
5246
                      bs_dlllib = [(OASISExpr.EBool true, [])];
5247
                      bs_dllpath = [(OASISExpr.EBool true, [])];
5248
                      bs_byteopt = [(OASISExpr.EBool true, [])];
5249
                      bs_nativeopt = [(OASISExpr.EBool true, [])];
5250
                      },
5251
                   {
5252
                      exec_custom = false;
5253
                      exec_main_is = "main_lustre_mutator.ml";
5254
                      });
5224 5255
               Test
5225 5256
                 ({
5226 5257
                     cs_name = "nonregression";
src/main_lustre_compiler.ml
267 267
  Corelang.add_internal_funs ();
268 268
  try
269 269
    Printexc.record_backtrace true;
270
    Arg.parse Options.options anonymous usage
270
    Arg.parse Options.lustrec_options anonymous usage
271 271
  with
272 272
  | Parse.Syntax_err _ | Lexer_lustre.Error _ 
273 273
  | Types.Error (_,_) | Clocks.Error (_,_)
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 *)
25

  
26
open Format
27
open Log
28

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

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

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

  
67
(* Loading Lusi file and filing type tables with parsed
68
   functions/nodes *)
69
let load_lusi filename =
70
  Location.input_name := filename;
71
  let lexbuf = Lexing.from_channel (open_in filename) in
72
  Location.init lexbuf filename;
73
  (* Parsing *)
74
  report ~level:1 (fun fmt -> fprintf fmt "@[<v>.. parsing header file %s@,@?" filename);
75
  let header = 
76
    try
77
      Parse.prog Parser_lustre.header Lexer_lustre.token lexbuf
78
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
79
      Parse.report_error err;
80
      raise exc
81
  in
82
  let new_tenv = type_decls Basic_library.type_env header in   (* Typing *)
83
  let new_cenv: Clocks.clock_expr Utils.IMap.t = clock_decls Basic_library.clock_env header in   (* Clock calculus *)
84
  header, new_tenv, new_cenv
85
  
86
    
87
let rec mutate basename extension =
88
  (* Loading the input file *)
89
  let source_name = basename^extension in
90
  Location.input_name := source_name;
91
  let lexbuf = Lexing.from_channel (open_in source_name) in
92
  Location.init lexbuf source_name;
93

  
94
  (* Parsing *)
95
  report ~level:1 
96
    (fun fmt -> fprintf fmt "@[<v>.. parsing file %s@,@?" source_name);
97
  let prog =
98
    try
99
      Parse.prog Parser_lustre.prog Lexer_lustre.token lexbuf
100
    with (Lexer_lustre.Error err) | (Parse.Syntax_err err) as exc -> 
101
      Parse.report_error err;
102
      raise exc
103
  in
104

  
105
  (* Extracting dependencies *)
106
  report ~level:1 (fun fmt -> fprintf fmt ".. extracting dependencies@,@?");
107
  let dependencies = 
108
    List.fold_right 
109
      (fun d accu -> match d.Corelang.top_decl_desc with 
110
      | Corelang.Open s -> s::accu 
111
      | _ -> accu) 
112
      prog [] 
113
  in
114
  let type_env, clock_env =
115
    List.fold_left (fun (type_env, clock_env) s -> 
116
      try
117
	let basename = s ^ ".lusi" in 
118
	report ~level:1 (fun fmt -> fprintf fmt "@[<v 2>Library %s@ " s);
119
	let _, lusi_type_env, lusi_clock_env = load_lusi basename in 
120
	report ~level:1 (fun fmt -> fprintf fmt "@]@,@?");
121
	Env.overwrite type_env lusi_type_env,
122
	Env.overwrite clock_env lusi_clock_env      
123
      with Sys_error msg -> (
124
	Format.eprintf "Failure: impossible to load library %s.@.%s@." s msg;
125
	exit 1
126
      )
127
    )  (Basic_library.type_env, Basic_library.clock_env) dependencies
128
  in
129
  
130
  (* Sorting nodes *)
131
  let prog = SortProg.sort prog in
132
  
133
  (* Typing *)
134
  let computed_types_env = type_decls type_env prog in
135
  
136
  (* Clock calculus *)
137
  let computed_clocks_env = clock_decls clock_env prog in
138

  
139
  (* generate mutants *)
140
  let mutants = Mutation.mutate !Options.nb_mutants prog in
141
  
142
  (* Print generated mutants in target directory. *)
143
  let cpt = ref 0 in
144
  List.iter (fun mutant ->
145
    incr cpt;
146
    let mutant_filename = 
147
      match !Options.dest_dir with
148
      | "" -> (* Mutants are generated in source directory *)
149
	basename^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
150
      | dir ->  (* Mutants are generated in targer directory *)
151
	dir ^ "/" ^ (Filename.basename basename)^ ".mutant.n" ^ (string_of_int !cpt) ^ extension 
152
    in
153
    let mutant_out = (
154
      try 
155
	open_out mutant_filename 
156
      with
157
	Sys_error _ -> Format.eprintf "Unable to open file %s for writing.@." mutant_filename; exit 1
158
    )
159
    in
160
    let mutant_fmt = formatter_of_out_channel mutant_out in
161
    report ~level:1 (fun fmt -> fprintf fmt ".. generating mutant %s@,@?" mutant_filename);
162
    Format.fprintf mutant_fmt "%a@." Printers.pp_prog mutant    
163
  )
164
    mutants;
165

  
166
  (*
167

  
168

  
169
  (* Normalization phase *)
170
  report ~level:1 (fun fmt -> fprintf fmt ".. normalization@,@?");
171
  let normalized_prog = Normalization.normalize_prog prog in
172
  Typing.uneval_prog_generics normalized_prog;
173
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?" Printers.pp_prog normalized_prog);
174
  (* Checking array accesses *)
175
  if !Options.check then
176
    begin
177
      report ~level:1 (fun fmt -> fprintf fmt ".. array access checks@,@?");
178
      Access.check_prog normalized_prog;
179
    end;
180

  
181
  (* DFS with modular code generation *)
182
  report ~level:1 (fun fmt -> fprintf fmt ".. machines generation@,@?");
183
  let machine_code = Machine_code.translate_prog normalized_prog in
184
  report ~level:2 (fun fmt -> fprintf fmt "@[<v 2>@ %a@]@,@?"
185
    (Utils.fprintf_list ~sep:"@ " Machine_code.pp_machine)
186
    machine_code);
187

  
188
  (* Checking the existence of a lusi (Lustre Interface file) *)
189
  let lusi_name = basename ^ ".lusi" in
190
  let _ = 
191
    try 
192
      let _ = open_in lusi_name in
193
      let _, declared_types_env, declared_clocks_env = load_lusi lusi_name in
194
      (* checking type compatibilty with computed types*)
195
      Typing.check_env_compat declared_types_env computed_types_env;
196
      (* checking clocks compatibilty with computed clocks*)
197
      Clock_calculus.check_env_compat declared_clocks_env computed_clocks_env;
198
      
199
    with Sys_error _ -> ( 
200
      (* Printing lusi file is necessary *)
201
      report ~level:1 
202
	(fun fmt -> 
203
	  fprintf fmt 
204
	    ".. generating lustre interface file %s@,@?" lusi_name);
205
      let lusi_out = open_out lusi_name in
206
      let lusi_fmt = formatter_of_out_channel lusi_out in
207
      Printers.pp_lusi_header lusi_fmt source_name normalized_prog
208
    )
209
    | (Types.Error (loc,err)) as exc ->
210
      Format.eprintf "Type mismatch between computed type and declared type in lustre interface file: %a@]@."
211
	Types.pp_error err;
212
      raise exc
213
  in
214

  
215
  (* Printing code *)
216
  let basename    = Filename.basename basename in
217
  if !Options.java then
218
    failwith "Sorry, but not yet supported !"
219
    (*let source_file = basename ^ ".java" in
220
      report ~level:1 (fun fmt -> fprintf fmt ".. opening file %s@,@?" source_file);
221
      let source_out = open_out source_file in
222
      let source_fmt = formatter_of_out_channel source_out in
223
      report ~level:1 (fun fmt -> fprintf fmt ".. java code generation@,@?");
224
      Java_backend.translate_to_java source_fmt basename normalized_prog machine_code;*)
225
  else begin
226
    let header_file = basename ^ ".h" in (* Could be changed *)
227
    let source_file = basename ^ ".c" in (* Could be changed *)
228
    let makefile_file = basename ^ ".makefile" in (* Could be changed *)
229
    let spec_file_opt = if !Options.c_spec then 
230
	(
231
	  let spec_file = basename ^ "_spec.c" in
232
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s, %s and %s@,@?" header_file source_file spec_file);
233
	  Some spec_file 
234
	) else (
235
	  report ~level:1 (fun fmt -> fprintf fmt ".. opening files %s and %s@,@?" header_file source_file);
236
	  None 
237
	 )
238
    in 
239
    let header_out = open_out header_file in
240
    let header_fmt = formatter_of_out_channel header_out in
241
    let source_out = open_out source_file in
242
    let source_fmt = formatter_of_out_channel source_out in
243
    let makefile_out = open_out makefile_file in
244
    let makefile_fmt = formatter_of_out_channel makefile_out in
245
    let spec_fmt_opt = match spec_file_opt with
246
	None -> None
247
      | Some f -> Some (formatter_of_out_channel (open_out f))
248
    in
249
    report ~level:1 (fun fmt -> fprintf fmt ".. C code generation@,@?");
250
    C_backend.translate_to_c header_fmt source_fmt makefile_fmt spec_fmt_opt basename normalized_prog machine_code;
251
  end;
252
  report ~level:1 (fun fmt -> fprintf fmt ".. done !@ @]@.");
253
  (* We stop the process here *)
254
  *)
255
  exit 0
256
  
257
let anonymous filename =
258
  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
259
  if ok_ext then
260
    let basename = Filename.chop_suffix filename ext in
261
    mutate basename ext
262
  else
263
    raise (Arg.Bad ("Can only compile *.lus or *.ec files"))
264

  
265
let _ =
266
  Corelang.add_internal_funs ();
267
  try
268
    Printexc.record_backtrace true;
269
    Arg.parse Options.lustrem_options anonymous usage
270
  with
271
  | Parse.Syntax_err _ | Lexer_lustre.Error _ 
272
  | Types.Error (_,_) | Clocks.Error (_,_)
273
  | Corelang.Error _ (*| Task_set.Error _*) 
274
  | Causality.Cycle _ -> exit 1
275
  | exc -> (Utils.track_exception (); raise exc)
276

  
277
(* Local Variables: *)
278
(* compile-command:"make -C .." *)
279
(* End: *)
src/mutation.ml
1
open Corelang
2
open Log
3
open Format
4

  
5
let random_seed = ref 0
6
let threshold_delay = 95
7
let threshold_inc_int = 97
8
let threshold_dec_int = 97
9
let threshold_random_int = 96
10
let threshold_switch_int = 100 (* not implemented yet *)
11
let threshold_random_float = 100 (* not used yet *)
12
let threshold_negate_bool_var = 95
13
let threshold_arith_op = 95
14
let threshold_rel_op = 95
15
let threshold_bool_op = 95
16

  
17
let mutate_int i = 
18
  if Random.int 100 > threshold_inc_int then
19
    i+1
20
  else if Random.int 100 > threshold_dec_int then
21
    i-1
22
  else if Random.int 100 > threshold_random_int then
23
    Random.int 10
24
  else if Random.int 100 > threshold_switch_int then
25
    assert false
26
  else
27
    i
28
  
29
let mutate_float f =
30
  if Random.int 100 > threshold_random_float then
31
    Random.float 10.
32
  else 
33
    f
34

  
35
let mutate_op op = 
36
match op with
37
| "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op ->
38
  let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in
39
  List.nth filtered (Random.int 3)
40
| "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op ->
41
  let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"] in
42
  List.nth filtered (Random.int 3)
43
| "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 > threshold_rel_op ->
44
  let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!="; "="] in
45
  List.nth filtered (Random.int 5)
46
| _ -> op
47

  
48

  
49
let mutate_var expr = 
50
  match (Types.repr expr.expr_type).Types.tdesc with 
51
  | Types.Tbool ->
52
    if Random.int 100 > threshold_negate_bool_var then
53
      mkpredef_unary_call Location.dummy_loc "not" expr
54
    else 
55
      expr
56
  | _ -> expr
57
    
58
let mutate_pre orig_expr e = 
59
  if Random.int 100 <= threshold_delay then
60
    (* We do not nothing *)
61
    Expr_pre e 
62
  else (* We add a pre *)
63
    Expr_pre ({orig_expr with expr_desc = Expr_pre e}) 
64

  
65

  
66
let mutate_const_value c =
67
  match c with
68
  | Const_int i -> Const_int (mutate_int i)
69
  | Const_real s -> Const_real s (* those are string, let's leave them *)
70
  | Const_float f -> Const_float (mutate_float f)
71
  | Const_array _
72
  | Const_tag _ -> c
73

  
74
let mutate_const c =
75
  { c with const_value = mutate_const_value c.const_value }
76

  
77

  
78
let rec mutate_expr expr =
79
  match expr.expr_desc with
80
  | Expr_ident id -> mutate_var expr
81
  | _ -> (
82
    let new_desc = match expr.expr_desc with
83
      | Expr_const c -> Expr_const (mutate_const_value c)
84
      | Expr_tuple l -> Expr_tuple (List.map mutate_expr l)
85
      | Expr_ite (i,t,e) -> Expr_ite (mutate_expr i, mutate_expr t, mutate_expr e)
86
      | Expr_arrow (e1, e2) -> Expr_arrow (mutate_expr e1, mutate_expr e2)
87
      | Expr_pre e -> mutate_pre expr (mutate_expr e)
88
      | Expr_appl (op_id, args, r) -> Expr_appl (mutate_op op_id, mutate_expr args, r)
89
  (* Other constructs are kept.
90
  | Expr_fby of expr * expr
91
  | Expr_array of expr list
92
  | Expr_access of expr * Dimension.dim_expr
93
  | Expr_power of expr * Dimension.dim_expr
94
  | Expr_when of expr * ident * label
95
  | Expr_merge of ident * (label * expr) list
96
  | Expr_uclock of expr * int
97
  | Expr_dclock of expr * int
98
  | Expr_phclock of expr * rat *)
99
  | _ -> expr.expr_desc
100

  
101
    in
102
    { expr with expr_desc = new_desc }
103
  )
104

  
105
let mutate_eq eq =
106
  { eq with eq_rhs = mutate_expr eq.eq_rhs }
107

  
108
let mutate_node nd = 
109
  { nd with node_eqs = List.map mutate_eq nd.node_eqs }
110

  
111
let mutate_top_decl td =
112
  match td.top_decl_desc with
113
  | Node nd -> { td with top_decl_desc = Node (mutate_node nd)}
114
  | Consts constsl -> { td with top_decl_desc = Consts (List.map mutate_const constsl)}
115
  | _ -> td
116
    
117
(* Create a single mutant with the provided random seed *)
118
let mutate_prog prog = 
119
  List.map mutate_top_decl prog
120

  
121
let rec mutate nb prog = 
122
  let rec iterate nb res =
123
    incr random_seed;
124
    if nb <= 0 then
125
      res
126
    else (
127
      Random.init !random_seed;
128
      let new_mutant = mutate_prog prog in
129
      if List.mem new_mutant res then (
130
	report ~level:1 (fun fmt -> fprintf fmt "New mutant is not new %i@." nb);
131
	iterate nb res
132
      )
133
      else
134
	iterate (nb-1) (new_mutant::res)
135
    )
136
  in
137
  iterate nb []
138

  
139

  
140

  
141

  
142
(* Local Variables: *)
143
(* compile-command:"make -C .." *)
144
(* End: *)
145

  
146
    
src/options.ml
33 33
let java = ref false
34 34
let dest_dir = ref ""
35 35
let verbose_level = ref 1
36
let nb_mutants = ref 1000
36 37

  
37
let options =
38
  [ "-d", Arg.Set_string dest_dir,
39
    "produces code in the specified directory";
38
let common_options =
39
  [  "-print_types", Arg.Set print_types, "prints node types";
40
    "-print_clocks", Arg.Set print_clocks, "prints node clocks";
41
    "-verbose", Arg.Set_int verbose_level, " changes verbose level <default: 1>";
42
    "-version", Arg.Unit (fun () -> print_endline version), " displays the version";]
43

  
44
let lustrec_options = 
45
  [ "-d", Arg.Set_string dest_dir, "produces code in the specified directory";
40 46
    "-node", Arg.Set_string main_node, "specifies the main node";
41 47
    "-init", Arg.Set delay_calculus, "performs an initialisation analysis for Lustre nodes";
42 48
    "-dynamic", Arg.Clear static_mem, "specifies a dynamic allocation scheme for main Lustre node (default: static)";
......
45 51
    "-c-spec", Arg.Set c_spec, 
46 52
    "generates a C encoding of the specification instead of ACSL contracts and annotations. Only meaningful for the C backend";
47 53
    "-java", Arg.Set java, "generates Java output instead of C";
48
    "-print_types", Arg.Set print_types, "prints node types";
49
    "-print_clocks", Arg.Set print_clocks, "prints node clocks";
50
    "-verbose", Arg.Set_int verbose_level, " changes verbose level <default: 1>";
51
    "-version", Arg.Unit (fun () -> print_endline version), " displays the version";]
54
  ] @ common_options
52 55

  
56
let lustrem_options =
57
  [ "-d", Arg.Set_string dest_dir, "produces mutants in the specified directory";
58
    "-nb", Arg.Set_int nb_mutants, "Number of mutants to produce (default 1000)"
59
 ]
60
  @ common_options
53 61

  
54 62
(* Local Variables: *)
55 63
(* compile-command:"make -C .." *)
src/printers.ml
139 139
(*   ) *)
140 140

  
141 141
let pp_node fmt nd = 
142
fprintf fmt "@[<v>node %s (%a) returns (%a)@ %a%alet@ @[<h 2>   @ @[%a@]@ @]@ tel@]@ "
142
fprintf fmt "@[<v>node %s (%a) returns (%a)@ %a%a@[<v 4>let@ %a@ @]@ tel@]@ "
143 143
  nd.node_id
144 144
  pp_node_args nd.node_inputs
145 145
  pp_node_args nd.node_outputs

Also available in: Unified diff