1
|
(* Comments in function fold_mutate
|
2
|
|
3
|
TODO: check if we can generate more cases. The following lines were cylcing
|
4
|
and missing to detect that the enumaration was complete, leading to a non
|
5
|
terminating process. The current setting is harder but may miss enumerating
|
6
|
some cases. To be checked! *)
|
7
|
|
8
|
open Lustre_types
|
9
|
open Corelang
|
10
|
open Log
|
11
|
open Format
|
12
|
|
13
|
let random_seed = ref 0
|
14
|
|
15
|
let threshold_delay = 95
|
16
|
|
17
|
let threshold_inc_int = 97
|
18
|
|
19
|
let threshold_dec_int = 97
|
20
|
|
21
|
let threshold_random_int = 96
|
22
|
|
23
|
let threshold_switch_int = 100
|
24
|
(* not implemented yet *)
|
25
|
|
26
|
let threshold_random_float = 100
|
27
|
(* not used yet *)
|
28
|
|
29
|
let threshold_negate_bool_var = 95
|
30
|
|
31
|
let threshold_arith_op = 95
|
32
|
|
33
|
let threshold_rel_op = 95
|
34
|
|
35
|
let threshold_bool_op = 95
|
36
|
|
37
|
let int_consts = ref []
|
38
|
|
39
|
let rename_app id =
|
40
|
if List.mem id Basic_library.internal_funs || !Options.no_mutation_suffix then
|
41
|
id
|
42
|
else
|
43
|
let node = Corelang.node_from_name id in
|
44
|
let is_imported =
|
45
|
match node.top_decl_desc with ImportedNode _ -> true | _ -> false
|
46
|
in
|
47
|
if is_imported then id else id ^ "_mutant"
|
48
|
|
49
|
(************************************************************************************)
|
50
|
(* Gathering constants in the code *)
|
51
|
(************************************************************************************)
|
52
|
|
53
|
module IntSet = Set.Make (struct
|
54
|
type t = int
|
55
|
|
56
|
let compare = compare
|
57
|
end)
|
58
|
|
59
|
module OpCount = Mmap.Make (struct
|
60
|
type t = string
|
61
|
|
62
|
let compare = compare
|
63
|
end)
|
64
|
|
65
|
type records = {
|
66
|
consts : IntSet.t;
|
67
|
nb_consts : int;
|
68
|
nb_boolexpr : int;
|
69
|
nb_pre : int;
|
70
|
nb_op : int OpCount.t;
|
71
|
}
|
72
|
|
73
|
let arith_op = [ "+"; "-"; "*"; "/" ]
|
74
|
|
75
|
let bool_op = [ "&&"; "||"; "xor"; "impl" ]
|
76
|
|
77
|
let rel_op = [ "<"; "<="; ">"; ">="; "!="; "=" ]
|
78
|
|
79
|
let ops = arith_op @ bool_op @ rel_op
|
80
|
|
81
|
let all_ops = "not" :: ops
|
82
|
|
83
|
let empty_records =
|
84
|
{
|
85
|
consts = IntSet.empty;
|
86
|
nb_consts = 0;
|
87
|
nb_boolexpr = 0;
|
88
|
nb_pre = 0;
|
89
|
nb_op = OpCount.empty;
|
90
|
}
|
91
|
|
92
|
let records = ref empty_records
|
93
|
|
94
|
let merge_records records_list =
|
95
|
let merge_record r1 r2 =
|
96
|
{
|
97
|
consts = IntSet.union r1.consts r2.consts;
|
98
|
nb_consts = r1.nb_consts + r2.nb_consts;
|
99
|
nb_boolexpr = r1.nb_boolexpr + r2.nb_boolexpr;
|
100
|
nb_pre = r1.nb_pre + r2.nb_pre;
|
101
|
nb_op =
|
102
|
OpCount.merge
|
103
|
(fun _ r1opt r2opt ->
|
104
|
match r1opt, r2opt with
|
105
|
| None, _ ->
|
106
|
r2opt
|
107
|
| _, None ->
|
108
|
r1opt
|
109
|
| Some x, Some y ->
|
110
|
Some (x + y))
|
111
|
r1.nb_op r2.nb_op;
|
112
|
}
|
113
|
in
|
114
|
List.fold_left merge_record empty_records records_list
|
115
|
|
116
|
let compute_records_const_value c =
|
117
|
match c with
|
118
|
| Const_int i ->
|
119
|
{ empty_records with consts = IntSet.singleton i; nb_consts = 1 }
|
120
|
| _ ->
|
121
|
empty_records
|
122
|
|
123
|
let rec compute_records_expr expr =
|
124
|
let boolexpr =
|
125
|
if Types.is_bool_type expr.expr_type then
|
126
|
{ empty_records with nb_boolexpr = 1 }
|
127
|
else empty_records
|
128
|
in
|
129
|
let subrec =
|
130
|
match expr.expr_desc with
|
131
|
| Expr_const c ->
|
132
|
compute_records_const_value c
|
133
|
| Expr_tuple l ->
|
134
|
merge_records (List.map compute_records_expr l)
|
135
|
| Expr_ite (i, t, e) ->
|
136
|
merge_records (List.map compute_records_expr [ i; t; e ])
|
137
|
| Expr_arrow (e1, e2) ->
|
138
|
merge_records (List.map compute_records_expr [ e1; e2 ])
|
139
|
| Expr_pre e ->
|
140
|
merge_records
|
141
|
[ { empty_records with nb_pre = 1 }; compute_records_expr e ]
|
142
|
| Expr_appl (op_id, args, _) ->
|
143
|
if List.mem op_id ops then
|
144
|
merge_records
|
145
|
[
|
146
|
{ empty_records with nb_op = OpCount.singleton op_id 1 };
|
147
|
compute_records_expr args;
|
148
|
]
|
149
|
else compute_records_expr args
|
150
|
| _ ->
|
151
|
empty_records
|
152
|
in
|
153
|
merge_records [ boolexpr; subrec ]
|
154
|
|
155
|
let compute_records_eq eq = compute_records_expr eq.eq_rhs
|
156
|
|
157
|
let compute_records_node nd =
|
158
|
let eqs, auts = get_node_eqs nd in
|
159
|
assert (auts = []);
|
160
|
(* Automaton should be expanded by now *)
|
161
|
merge_records (List.map compute_records_eq eqs)
|
162
|
|
163
|
let compute_records_top_decl td =
|
164
|
match td.top_decl_desc with
|
165
|
| Node nd ->
|
166
|
compute_records_node nd
|
167
|
| Const cst ->
|
168
|
compute_records_const_value cst.const_value
|
169
|
| _ ->
|
170
|
empty_records
|
171
|
|
172
|
let compute_records prog =
|
173
|
merge_records (List.map compute_records_top_decl prog)
|
174
|
|
175
|
(*****************************************************************)
|
176
|
(* Random mutation *)
|
177
|
(*****************************************************************)
|
178
|
|
179
|
let check_mut e1 e2 =
|
180
|
let rec eq e1 e2 =
|
181
|
match e1.expr_desc, e2.expr_desc with
|
182
|
| Expr_const c1, Expr_const c2 ->
|
183
|
c1 = c2
|
184
|
| Expr_ident id1, Expr_ident id2 ->
|
185
|
id1 = id2
|
186
|
| Expr_tuple el1, Expr_tuple el2 ->
|
187
|
List.length el1 = List.length el2 && List.for_all2 eq el1 el2
|
188
|
| Expr_ite (i1, t1, e1), Expr_ite (i2, t2, e2) ->
|
189
|
eq i1 i2 && eq t1 t2 && eq e1 e2
|
190
|
| Expr_arrow (x1, y1), Expr_arrow (x2, y2) ->
|
191
|
eq x1 x2 && eq y1 y2
|
192
|
| Expr_pre e1, Expr_pre e2 ->
|
193
|
eq e1 e2
|
194
|
| Expr_appl (id1, e1, _), Expr_appl (id2, e2, _) ->
|
195
|
id1 = id2 && eq e1 e2
|
196
|
| _ ->
|
197
|
false
|
198
|
in
|
199
|
if not (eq e1 e2) then Some (e1, e2) else None
|
200
|
|
201
|
let mk_cst_expr c = mkexpr Location.dummy_loc (Expr_const c)
|
202
|
|
203
|
let rdm_mutate_int i =
|
204
|
if Random.int 100 > threshold_inc_int then i + 1
|
205
|
else if Random.int 100 > threshold_dec_int then i - 1
|
206
|
else if Random.int 100 > threshold_random_int then Random.int 10
|
207
|
else if Random.int 100 > threshold_switch_int then
|
208
|
let idx = Random.int (List.length !int_consts) in
|
209
|
List.nth !int_consts idx
|
210
|
else i
|
211
|
|
212
|
let rdm_mutate_real r =
|
213
|
if Random.int 100 > threshold_random_float then
|
214
|
(* interval [0, bound] for random values *)
|
215
|
let bound = 10 in
|
216
|
(* max number of digits after comma *)
|
217
|
let digits = 5 in
|
218
|
(* number of digits after comma *)
|
219
|
let shift = Random.int (digits + 1) in
|
220
|
let eshift = 10. ** float_of_int shift in
|
221
|
let i = Random.int (1 + (bound * int_of_float eshift)) in
|
222
|
let f = float_of_int i /. eshift in
|
223
|
Real.create (string_of_int i) shift (string_of_float f)
|
224
|
else r
|
225
|
|
226
|
let rdm_mutate_op op =
|
227
|
match op with
|
228
|
| ("+" | "-" | "*" | "/") when Random.int 100 > threshold_arith_op ->
|
229
|
let filtered = List.filter (fun x -> x <> op) [ "+"; "-"; "*"; "/" ] in
|
230
|
List.nth filtered (Random.int 3)
|
231
|
| ("&&" | "||" | "xor" | "impl") when Random.int 100 > threshold_bool_op ->
|
232
|
let filtered =
|
233
|
List.filter (fun x -> x <> op) [ "&&"; "||"; "xor"; "impl" ]
|
234
|
in
|
235
|
List.nth filtered (Random.int 3)
|
236
|
| ("<" | "<=" | ">" | ">=" | "!=" | "=")
|
237
|
when Random.int 100 > threshold_rel_op ->
|
238
|
let filtered =
|
239
|
List.filter (fun x -> x <> op) [ "<"; "<="; ">"; ">="; "!="; "=" ]
|
240
|
in
|
241
|
List.nth filtered (Random.int 5)
|
242
|
| _ ->
|
243
|
op
|
244
|
|
245
|
let rdm_mutate_var expr =
|
246
|
if Types.is_bool_type expr.expr_type then
|
247
|
(* if Random.int 100 > threshold_negate_bool_var then *)
|
248
|
let new_e = mkpredef_call expr.expr_loc "not" [ expr ] in
|
249
|
Some (expr, new_e), new_e
|
250
|
(* else *)
|
251
|
(* expr *)
|
252
|
else None, expr
|
253
|
|
254
|
let rdm_mutate_pre orig_expr =
|
255
|
let new_e = Expr_pre orig_expr in
|
256
|
Some (orig_expr, { orig_expr with expr_desc = new_e }), new_e
|
257
|
|
258
|
let rdm_mutate_const_value c =
|
259
|
match c with
|
260
|
| Const_int i ->
|
261
|
Const_int (rdm_mutate_int i)
|
262
|
| Const_real r ->
|
263
|
Const_real (rdm_mutate_real r)
|
264
|
| Const_array _
|
265
|
| Const_string _
|
266
|
| Const_modeid _
|
267
|
| Const_struct _
|
268
|
| Const_tag _ ->
|
269
|
c
|
270
|
|
271
|
let rdm_mutate_const c =
|
272
|
let new_const = rdm_mutate_const_value c.const_value in
|
273
|
let mut = check_mut (mk_cst_expr c.const_value) (mk_cst_expr new_const) in
|
274
|
mut, { c with const_value = new_const }
|
275
|
|
276
|
let select_in_list list rdm_mutate_elem =
|
277
|
let selected = Random.int (List.length list) in
|
278
|
let mutation_opt, new_list, _ =
|
279
|
List.fold_right
|
280
|
(fun elem (mutation_opt, res, cpt) ->
|
281
|
if cpt = selected then
|
282
|
let mutation, new_elem = rdm_mutate_elem elem in
|
283
|
Some mutation, new_elem :: res, cpt + 1
|
284
|
else mutation_opt, elem :: res, cpt + 1)
|
285
|
list (None, [], 0)
|
286
|
in
|
287
|
match mutation_opt with Some mut -> mut, new_list | _ -> assert false
|
288
|
|
289
|
let rec rdm_mutate_expr expr =
|
290
|
let mk_e d = { expr with expr_desc = d } in
|
291
|
match expr.expr_desc with
|
292
|
| Expr_ident _ ->
|
293
|
rdm_mutate_var expr
|
294
|
| Expr_const c ->
|
295
|
let new_const = rdm_mutate_const_value c in
|
296
|
let mut = check_mut (mk_cst_expr c) (mk_cst_expr new_const) in
|
297
|
mut, mk_e (Expr_const new_const)
|
298
|
| Expr_tuple l ->
|
299
|
let mut, l' = select_in_list l rdm_mutate_expr in
|
300
|
mut, mk_e (Expr_tuple l')
|
301
|
| Expr_ite (i, t, e) -> (
|
302
|
let mut, l = select_in_list [ i; t; e ] rdm_mutate_expr in
|
303
|
match l with
|
304
|
| [ i'; t'; e' ] ->
|
305
|
mut, mk_e (Expr_ite (i', t', e'))
|
306
|
| _ ->
|
307
|
assert false)
|
308
|
| Expr_arrow (e1, e2) -> (
|
309
|
let mut, l = select_in_list [ e1; e2 ] rdm_mutate_expr in
|
310
|
match l with
|
311
|
| [ e1'; e2' ] ->
|
312
|
mut, mk_e (Expr_arrow (e1', e2'))
|
313
|
| _ ->
|
314
|
assert false)
|
315
|
| Expr_pre e ->
|
316
|
let select_pre = Random.bool () in
|
317
|
if select_pre then
|
318
|
let mut, new_expr = rdm_mutate_pre expr in
|
319
|
mut, mk_e new_expr
|
320
|
else
|
321
|
let mut, e' = rdm_mutate_expr e in
|
322
|
mut, mk_e (Expr_pre e')
|
323
|
| Expr_appl (op_id, args, r) ->
|
324
|
let select_op = Random.bool () in
|
325
|
if select_op then
|
326
|
let new_op_id = rdm_mutate_op op_id in
|
327
|
let new_e = mk_e (Expr_appl (new_op_id, args, r)) in
|
328
|
let mut = check_mut expr new_e in
|
329
|
mut, new_e
|
330
|
else
|
331
|
let mut, new_args = rdm_mutate_expr args in
|
332
|
mut, mk_e (Expr_appl (op_id, new_args, r))
|
333
|
(* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of expr
|
334
|
list | Expr_access of expr * Dimension.dim_expr | Expr_power of expr *
|
335
|
Dimension.dim_expr | Expr_when of expr * ident * label | Expr_merge of
|
336
|
ident * (label * expr) list | Expr_uclock of expr * int | Expr_dclock of
|
337
|
expr * int | Expr_phclock of expr * rat *)
|
338
|
| _ ->
|
339
|
None, expr
|
340
|
|
341
|
let rdm_mutate_eq eq =
|
342
|
let mutation, new_rhs = rdm_mutate_expr eq.eq_rhs in
|
343
|
mutation, { eq with eq_rhs = new_rhs }
|
344
|
|
345
|
let rnd_mutate_stmt stmt =
|
346
|
match stmt with
|
347
|
| Eq eq ->
|
348
|
let mut, new_eq = rdm_mutate_eq eq in
|
349
|
report ~level:1 (fun fmt ->
|
350
|
fprintf fmt "mutation: %a becomes %a@ " Printers.pp_node_eq eq
|
351
|
Printers.pp_node_eq new_eq);
|
352
|
mut, Eq new_eq
|
353
|
| Aut _ ->
|
354
|
assert false
|
355
|
|
356
|
let rdm_mutate_node nd =
|
357
|
let mutation, new_node_stmts = select_in_list nd.node_stmts rnd_mutate_stmt in
|
358
|
mutation, { nd with node_stmts = new_node_stmts }
|
359
|
|
360
|
let rdm_mutate_top_decl td =
|
361
|
match td.top_decl_desc with
|
362
|
| Node nd ->
|
363
|
let mutation, new_node = rdm_mutate_node nd in
|
364
|
mutation, { td with top_decl_desc = Node new_node }
|
365
|
| Const cst ->
|
366
|
let mut, new_cst = rdm_mutate_const cst in
|
367
|
mut, { td with top_decl_desc = Const new_cst }
|
368
|
| _ ->
|
369
|
None, td
|
370
|
|
371
|
(* Create a single mutant with the provided random seed *)
|
372
|
let rdm_mutate_prog prog = select_in_list prog rdm_mutate_top_decl
|
373
|
|
374
|
let rdm_mutate nb prog =
|
375
|
let rec iterate nb res =
|
376
|
incr random_seed;
|
377
|
if nb <= 0 then res
|
378
|
else (
|
379
|
Random.init !random_seed;
|
380
|
let mutation, new_mutant = rdm_mutate_prog prog in
|
381
|
match mutation with
|
382
|
| None ->
|
383
|
iterate nb res
|
384
|
| Some mutation ->
|
385
|
if List.mem_assoc mutation res then iterate nb res
|
386
|
else (
|
387
|
report ~level:1 (fun fmt -> fprintf fmt "%i mutants remaining@ " nb);
|
388
|
iterate (nb - 1) ((mutation, new_mutant) :: res)))
|
389
|
in
|
390
|
iterate nb []
|
391
|
|
392
|
(*****************************************************************)
|
393
|
(* Random mutation *)
|
394
|
(*****************************************************************)
|
395
|
|
396
|
type mutant_t =
|
397
|
| Boolexpr of int
|
398
|
| Pre of int
|
399
|
| Op of string * int * string
|
400
|
| IncrIntCst of int
|
401
|
| DecrIntCst of int
|
402
|
| SwitchIntCst of int * int
|
403
|
|
404
|
(* Denotes the parent node, the equation lhs and the location of the mutation *)
|
405
|
type mutation_loc = ident * ident list * Location.t
|
406
|
|
407
|
let target : mutant_t option ref = ref None
|
408
|
|
409
|
let mutation_info : mutation_loc option ref = ref None
|
410
|
|
411
|
let current_node : ident option ref = ref None
|
412
|
|
413
|
let current_eq_lhs : ident list option ref = ref None
|
414
|
|
415
|
let current_loc : Location.t option ref = ref None
|
416
|
|
417
|
let set_mutation_loc () =
|
418
|
target := None;
|
419
|
match !current_node, !current_eq_lhs, !current_loc with
|
420
|
| Some n, Some elhs, Some l ->
|
421
|
mutation_info := Some (n, elhs, l)
|
422
|
| _ ->
|
423
|
assert false
|
424
|
(* Those global vars should be defined during the visitor pattern execution *)
|
425
|
|
426
|
let print_directive fmt d =
|
427
|
match d with
|
428
|
| Pre n ->
|
429
|
Format.fprintf fmt "pre %i" n
|
430
|
| Boolexpr n ->
|
431
|
Format.fprintf fmt "boolexpr %i" n
|
432
|
| Op (o, i, d) ->
|
433
|
Format.fprintf fmt "%s %i -> %s" o i d
|
434
|
| IncrIntCst n ->
|
435
|
Format.fprintf fmt "incr int cst %i" n
|
436
|
| DecrIntCst n ->
|
437
|
Format.fprintf fmt "decr int cst %i" n
|
438
|
| SwitchIntCst (n, m) ->
|
439
|
Format.fprintf fmt "switch int cst %i -> %i" n m
|
440
|
|
441
|
let print_directive_json fmt d =
|
442
|
match d with
|
443
|
| Pre _ ->
|
444
|
Format.fprintf fmt "\"mutation\": \"pre\""
|
445
|
| Boolexpr _ ->
|
446
|
Format.fprintf fmt "\"mutation\": \"not\""
|
447
|
| Op (o, _, d) ->
|
448
|
Format.fprintf fmt
|
449
|
"\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d
|
450
|
| IncrIntCst _ ->
|
451
|
Format.fprintf fmt "\"mutation\": \"cst_incr\""
|
452
|
| DecrIntCst _ ->
|
453
|
Format.fprintf fmt "\"mutation\": \"cst_decr\""
|
454
|
| SwitchIntCst (_, m) ->
|
455
|
Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m
|
456
|
|
457
|
let print_loc_json fmt (n, eqlhs, l) =
|
458
|
Format.fprintf fmt
|
459
|
"\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" n
|
460
|
(Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s))
|
461
|
eqlhs (Location.loc_line l)
|
462
|
|
463
|
let fold_mutate_int i =
|
464
|
if Random.int 100 > threshold_inc_int then i + 1
|
465
|
else if Random.int 100 > threshold_dec_int then i - 1
|
466
|
else if Random.int 100 > threshold_random_int then Random.int 10
|
467
|
else if Random.int 100 > threshold_switch_int then
|
468
|
try
|
469
|
let idx = Random.int (List.length !int_consts) in
|
470
|
List.nth !int_consts idx
|
471
|
with _ -> i
|
472
|
else i
|
473
|
|
474
|
let fold_mutate_float f =
|
475
|
if Random.int 100 > threshold_random_float then Random.float 10. else f
|
476
|
|
477
|
let fold_mutate_op op =
|
478
|
(* match op with *)
|
479
|
(* | "+" | "-" | "*" | "/" when Random.int 100 > threshold_arith_op -> *)
|
480
|
(* let filtered = List.filter (fun x -> x <> op) ["+"; "-"; "*"; "/"] in *)
|
481
|
(* List.nth filtered (Random.int 3) *)
|
482
|
(* | "&&" | "||" | "xor" | "impl" when Random.int 100 > threshold_bool_op -> *)
|
483
|
(* let filtered = List.filter (fun x -> x <> op) ["&&"; "||"; "xor"; "impl"]
|
484
|
in *)
|
485
|
(* List.nth filtered (Random.int 3) *)
|
486
|
(* | "<" | "<=" | ">" | ">=" | "!=" | "=" when Random.int 100 >
|
487
|
threshold_rel_op -> *)
|
488
|
(* let filtered = List.filter (fun x -> x <> op) ["<"; "<="; ">"; ">="; "!=";
|
489
|
"="] in *)
|
490
|
(* List.nth filtered (Random.int 5) *)
|
491
|
(* | _ -> op *)
|
492
|
match !target with
|
493
|
| Some (Op (op_orig, 0, op_new)) when op_orig = op ->
|
494
|
set_mutation_loc ();
|
495
|
op_new
|
496
|
| Some (Op (op_orig, n, op_new)) when op_orig = op ->
|
497
|
target := Some (Op (op_orig, n - 1, op_new));
|
498
|
op
|
499
|
| _ ->
|
500
|
op
|
501
|
|
502
|
let fold_mutate_var expr =
|
503
|
(* match (Types.repr expr.expr_type).Types.tdesc with *)
|
504
|
(* | Types.Tbool -> *)
|
505
|
(* (\* if Random.int 100 > threshold_negate_bool_var then *\) *)
|
506
|
(* mkpredef_unary_call Location.dummy_loc "not" expr *)
|
507
|
(* (\* else *\) *)
|
508
|
(* (\* expr *\) *)
|
509
|
(* | _ -> *)
|
510
|
expr
|
511
|
|
512
|
let fold_mutate_boolexpr expr =
|
513
|
match !target with
|
514
|
| Some (Boolexpr 0) ->
|
515
|
set_mutation_loc ();
|
516
|
|
517
|
mkpredef_call expr.expr_loc "not" [ expr ]
|
518
|
| Some (Boolexpr n) ->
|
519
|
target := Some (Boolexpr (n - 1));
|
520
|
expr
|
521
|
| _ ->
|
522
|
expr
|
523
|
|
524
|
let fold_mutate_pre orig_expr e =
|
525
|
match !target with
|
526
|
| Some (Pre 0) ->
|
527
|
set_mutation_loc ();
|
528
|
Expr_pre { orig_expr with expr_desc = Expr_pre e }
|
529
|
| Some (Pre n) ->
|
530
|
target := Some (Pre (n - 1));
|
531
|
Expr_pre e
|
532
|
| _ ->
|
533
|
Expr_pre e
|
534
|
|
535
|
let fold_mutate_const_value c =
|
536
|
match c with
|
537
|
| Const_int i -> (
|
538
|
match !target with
|
539
|
| Some (IncrIntCst 0) ->
|
540
|
set_mutation_loc ();
|
541
|
Const_int (i + 1)
|
542
|
| Some (DecrIntCst 0) ->
|
543
|
set_mutation_loc ();
|
544
|
Const_int (i - 1)
|
545
|
| Some (SwitchIntCst (0, id)) ->
|
546
|
set_mutation_loc ();
|
547
|
Const_int id
|
548
|
| Some (IncrIntCst n) ->
|
549
|
target := Some (IncrIntCst (n - 1));
|
550
|
c
|
551
|
| Some (DecrIntCst n) ->
|
552
|
target := Some (DecrIntCst (n - 1));
|
553
|
c
|
554
|
| Some (SwitchIntCst (n, id)) ->
|
555
|
target := Some (SwitchIntCst (n - 1, id));
|
556
|
c
|
557
|
| _ ->
|
558
|
c)
|
559
|
| _ ->
|
560
|
c
|
561
|
|
562
|
(* match c with | Const_int i -> Const_int (fold_mutate_int i) | Const_real s ->
|
563
|
Const_real s (* those are string, let's leave them *) | Const_float f ->
|
564
|
Const_float (fold_mutate_float f) | Const_array _ | Const_tag _ -> c TODO *)
|
565
|
let fold_mutate_const c =
|
566
|
{ c with const_value = fold_mutate_const_value c.const_value }
|
567
|
|
568
|
let rec fold_mutate_expr expr =
|
569
|
current_loc := Some expr.expr_loc;
|
570
|
let new_expr =
|
571
|
match expr.expr_desc with
|
572
|
| Expr_ident _ ->
|
573
|
fold_mutate_var expr
|
574
|
| _ ->
|
575
|
let new_desc =
|
576
|
match expr.expr_desc with
|
577
|
| Expr_const c ->
|
578
|
Expr_const (fold_mutate_const_value c)
|
579
|
| Expr_tuple l ->
|
580
|
Expr_tuple
|
581
|
(List.fold_right (fun e res -> fold_mutate_expr e :: res) l [])
|
582
|
| Expr_ite (i, t, e) ->
|
583
|
Expr_ite (fold_mutate_expr i, fold_mutate_expr t, fold_mutate_expr e)
|
584
|
| Expr_arrow (e1, e2) ->
|
585
|
Expr_arrow (fold_mutate_expr e1, fold_mutate_expr e2)
|
586
|
| Expr_pre e ->
|
587
|
fold_mutate_pre expr (fold_mutate_expr e)
|
588
|
| Expr_appl (op_id, args, r) ->
|
589
|
Expr_appl (fold_mutate_op op_id, fold_mutate_expr args, r)
|
590
|
(* Other constructs are kept. | Expr_fby of expr * expr | Expr_array of
|
591
|
expr list | Expr_access of expr * Dimension.dim_expr | Expr_power of
|
592
|
expr * Dimension.dim_expr | Expr_when of expr * ident * label |
|
593
|
Expr_merge of ident * (label * expr) list | Expr_uclock of expr * int
|
594
|
| Expr_dclock of expr * int | Expr_phclock of expr * rat *)
|
595
|
| _ ->
|
596
|
expr.expr_desc
|
597
|
in
|
598
|
|
599
|
{ expr with expr_desc = new_desc }
|
600
|
in
|
601
|
if Types.is_bool_type expr.expr_type then fold_mutate_boolexpr new_expr
|
602
|
else new_expr
|
603
|
|
604
|
let fold_mutate_eq eq =
|
605
|
current_eq_lhs := Some eq.eq_lhs;
|
606
|
{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
|
607
|
|
608
|
let fold_mutate_stmt stmt =
|
609
|
match stmt with Eq eq -> Eq (fold_mutate_eq eq) | Aut _ -> assert false
|
610
|
|
611
|
let fold_mutate_node nd =
|
612
|
current_node := Some nd.node_id;
|
613
|
let nd =
|
614
|
{
|
615
|
nd with
|
616
|
node_stmts =
|
617
|
List.fold_right
|
618
|
(fun stmt res -> fold_mutate_stmt stmt :: res)
|
619
|
nd.node_stmts [];
|
620
|
}
|
621
|
in
|
622
|
rename_node rename_app (fun x -> x) nd
|
623
|
|
624
|
let fold_mutate_top_decl td =
|
625
|
match td.top_decl_desc with
|
626
|
| Node nd ->
|
627
|
{ td with top_decl_desc = Node (fold_mutate_node nd) }
|
628
|
| Const cst ->
|
629
|
{ td with top_decl_desc = Const (fold_mutate_const cst) }
|
630
|
| _ ->
|
631
|
td
|
632
|
|
633
|
(* Create a single mutant with the provided random seed *)
|
634
|
let fold_mutate_prog prog =
|
635
|
List.fold_right (fun e res -> fold_mutate_top_decl e :: res) prog []
|
636
|
|
637
|
let create_mutant prog directive =
|
638
|
target := Some directive;
|
639
|
let prog' = fold_mutate_prog prog in
|
640
|
let mutation_info =
|
641
|
match !target, !mutation_info with
|
642
|
| None, Some mi ->
|
643
|
mi
|
644
|
| _ ->
|
645
|
Format.eprintf "Failed when creating mutant for directive %a@.@?"
|
646
|
print_directive directive;
|
647
|
let _ =
|
648
|
match !target with
|
649
|
| Some dir' ->
|
650
|
Format.eprintf "New directive %a@.@?" print_directive dir'
|
651
|
| _ ->
|
652
|
()
|
653
|
in
|
654
|
assert false
|
655
|
(* The mutation has not been performed. *)
|
656
|
in
|
657
|
|
658
|
(* target := None; (* should happen only if no mutation occured during the
|
659
|
visit *)*)
|
660
|
prog', mutation_info
|
661
|
|
662
|
let op_mutation op =
|
663
|
let res =
|
664
|
let rem_op l = List.filter (fun e -> e <> op) l in
|
665
|
if List.mem op arith_op then rem_op arith_op
|
666
|
else if List.mem op bool_op then rem_op bool_op
|
667
|
else if List.mem op rel_op then rem_op rel_op
|
668
|
else (
|
669
|
Format.eprintf "Failing with op %s@." op;
|
670
|
assert false)
|
671
|
in
|
672
|
(* Format.eprintf "Mutation op %s to [%a]@." op (Utils.fprintf_list ~sep:","
|
673
|
Format.pp_print_string) res; *)
|
674
|
res
|
675
|
|
676
|
let rec remains select list =
|
677
|
match list with
|
678
|
| [] ->
|
679
|
[]
|
680
|
| hd :: tl ->
|
681
|
if select hd then tl else remains select tl
|
682
|
|
683
|
let next_change m =
|
684
|
let res =
|
685
|
let rec first_op () =
|
686
|
try
|
687
|
let min_binding = OpCount.min_binding !records.nb_op in
|
688
|
Op (fst min_binding, 0, List.hd (op_mutation (fst min_binding)))
|
689
|
with Not_found -> first_boolexpr ()
|
690
|
and first_boolexpr () =
|
691
|
if !records.nb_boolexpr > 0 then Boolexpr 0 else first_pre ()
|
692
|
and first_pre () = if !records.nb_pre > 0 then Pre 0 else first_op ()
|
693
|
and first_intcst () =
|
694
|
if IntSet.cardinal !records.consts > 0 then IncrIntCst 0
|
695
|
else first_boolexpr ()
|
696
|
in
|
697
|
match m with
|
698
|
| Boolexpr n ->
|
699
|
if n + 1 >= !records.nb_boolexpr then first_pre () else Boolexpr (n + 1)
|
700
|
| Pre n ->
|
701
|
if n + 1 >= !records.nb_pre then first_op () else Pre (n + 1)
|
702
|
| Op (orig, id, mut_op) -> (
|
703
|
match remains (fun x -> x = mut_op) (op_mutation orig) with
|
704
|
| next_op :: _ ->
|
705
|
Op (orig, id, next_op)
|
706
|
| [] ->
|
707
|
if id + 1 >= OpCount.find orig !records.nb_op then
|
708
|
match
|
709
|
remains (fun (k1, _) -> k1 = orig) (OpCount.bindings !records.nb_op)
|
710
|
with
|
711
|
| [] ->
|
712
|
first_intcst ()
|
713
|
| hd :: _ ->
|
714
|
Op (fst hd, 0, List.hd (op_mutation (fst hd)))
|
715
|
else Op (orig, id + 1, List.hd (op_mutation orig)))
|
716
|
| IncrIntCst n ->
|
717
|
if n + 1 >= IntSet.cardinal !records.consts then DecrIntCst 0
|
718
|
else IncrIntCst (n + 1)
|
719
|
| DecrIntCst n ->
|
720
|
if n + 1 >= IntSet.cardinal !records.consts then SwitchIntCst (0, 0)
|
721
|
else DecrIntCst (n + 1)
|
722
|
| SwitchIntCst (n, m) ->
|
723
|
if m + 1 > -1 + IntSet.cardinal !records.consts then
|
724
|
SwitchIntCst (n, m + 1)
|
725
|
else if n + 1 >= IntSet.cardinal !records.consts then
|
726
|
SwitchIntCst (n + 1, 0)
|
727
|
else first_boolexpr ()
|
728
|
in
|
729
|
|
730
|
(* Format.eprintf "from: %a to: %a@." print_directive m print_directive res; *)
|
731
|
res
|
732
|
|
733
|
let fold_mutate nb prog =
|
734
|
incr random_seed;
|
735
|
Random.init !random_seed;
|
736
|
|
737
|
(* Local references to keep track of generated directives *)
|
738
|
|
739
|
(* build a set of integer 0, 1, ... n-1 for input n *)
|
740
|
let cpt_to_intset cpt =
|
741
|
let arr = Array.init cpt (fun x -> x) in
|
742
|
Array.fold_right IntSet.add arr IntSet.empty
|
743
|
in
|
744
|
|
745
|
let possible_const_id = cpt_to_intset !records.nb_consts in
|
746
|
|
747
|
(* let possible_boolexpr_id = cpt_to_intset !records.nb_boolexpr in *)
|
748
|
(* let possible_pre_id = cpt_to_intset !records.nb_pre in *)
|
749
|
let incremented_const_id = ref IntSet.empty in
|
750
|
let decremented_const_id = ref IntSet.empty in
|
751
|
|
752
|
let create_new_incr_decr registered build =
|
753
|
let possible =
|
754
|
IntSet.diff possible_const_id !registered |> IntSet.elements
|
755
|
in
|
756
|
let len = List.length possible in
|
757
|
if len <= 0 then false, build (-1) (* Should not be stored *)
|
758
|
else
|
759
|
let picked = List.nth possible (Random.int (List.length possible)) in
|
760
|
registered := IntSet.add picked !registered;
|
761
|
true, build picked
|
762
|
in
|
763
|
|
764
|
let module DblIntSet = Set.Make (struct
|
765
|
type t = int * int
|
766
|
|
767
|
let compare = compare
|
768
|
end) in
|
769
|
let switch_const_id = ref DblIntSet.empty in
|
770
|
let switch_set =
|
771
|
if IntSet.cardinal !records.consts <= 1 then DblIntSet.empty
|
772
|
else
|
773
|
(* First element is cst id (the ith cst) while second is the ith element
|
774
|
of the set of gathered constants !record.consts *)
|
775
|
IntSet.fold
|
776
|
(fun cst_id set ->
|
777
|
IntSet.fold
|
778
|
(fun ith_cst set -> DblIntSet.add (cst_id, ith_cst) set)
|
779
|
!records.consts set)
|
780
|
possible_const_id DblIntSet.empty
|
781
|
in
|
782
|
|
783
|
let create_new_switch registered build =
|
784
|
let possible =
|
785
|
DblIntSet.diff switch_set !registered |> DblIntSet.elements
|
786
|
in
|
787
|
let len = List.length possible in
|
788
|
if len <= 0 then false, build (-1, -1) (* Should not be stored *)
|
789
|
else
|
790
|
let picked = List.nth possible (Random.int (List.length possible)) in
|
791
|
registered := DblIntSet.add picked !registered;
|
792
|
true, build picked
|
793
|
in
|
794
|
|
795
|
let find_next_new mutants mutant =
|
796
|
let find_next_new init current =
|
797
|
if init = current || List.mem current mutants then raise Not_found
|
798
|
else
|
799
|
(* TODO: check if we can generate more cases. The following lines were
|
800
|
cylcing and missing to detect that the enumaration was complete,
|
801
|
leading to a non terminating process. The current setting is harder
|
802
|
but may miss enumerating some cases. To be checked! *)
|
803
|
|
804
|
(* if List.mem current mutants then *)
|
805
|
(* find_next_new init (next_change current) *)
|
806
|
(* else *)
|
807
|
current
|
808
|
in
|
809
|
find_next_new mutant (next_change mutant)
|
810
|
in
|
811
|
(* Creating list of nb elements of mutants *)
|
812
|
let rec create_mutants_directives rnb mutants =
|
813
|
if rnb <= 0 then mutants
|
814
|
else
|
815
|
(* Initial list of transformation *)
|
816
|
let rec init_list x = if x <= 0 then [ 0 ] else x :: init_list (x - 1) in
|
817
|
let init_list = init_list 5 in
|
818
|
(* We generate a random permutation of the list: the first item is the
|
819
|
transformation, the rest of the list act as fallback choices to make
|
820
|
sure we produce something *)
|
821
|
let shuffle l =
|
822
|
let nd = List.map (fun c -> Random.bits (), c) l in
|
823
|
let sond = List.sort compare nd in
|
824
|
List.map snd sond
|
825
|
in
|
826
|
let transforms = shuffle init_list in
|
827
|
let rec apply_transform transforms =
|
828
|
let f id =
|
829
|
match id with
|
830
|
| 5 ->
|
831
|
create_new_incr_decr incremented_const_id (fun x -> IncrIntCst x)
|
832
|
| 4 ->
|
833
|
create_new_incr_decr decremented_const_id (fun x -> DecrIntCst x)
|
834
|
| 3 ->
|
835
|
create_new_switch switch_const_id (fun (x, y) ->
|
836
|
SwitchIntCst (x, y))
|
837
|
| 2 ->
|
838
|
( !records.nb_pre > 0,
|
839
|
Pre (try Random.int !records.nb_pre with _ -> 0) )
|
840
|
| 1 ->
|
841
|
( !records.nb_boolexpr > 0,
|
842
|
Boolexpr (try Random.int !records.nb_boolexpr with _ -> 0) )
|
843
|
| 0 ->
|
844
|
let bindings = OpCount.bindings !records.nb_op in
|
845
|
let bindings_len = List.length bindings in
|
846
|
if bindings_len > 0 then
|
847
|
let op, nb_op =
|
848
|
List.nth bindings (try Random.int bindings_len with _ -> 0)
|
849
|
in
|
850
|
let op_mut = op_mutation op in
|
851
|
let new_op =
|
852
|
List.nth op_mut
|
853
|
(try Random.int (List.length op_mut) with _ -> 0)
|
854
|
in
|
855
|
true, Op (op, (try Random.int nb_op with _ -> 0), new_op)
|
856
|
else false, Boolexpr 0
|
857
|
(* Providing a dummy construct, it will be filtered out thanks to the
|
858
|
negative status (fst = false) *)
|
859
|
| _ ->
|
860
|
assert false
|
861
|
in
|
862
|
match transforms with
|
863
|
| [] ->
|
864
|
assert false
|
865
|
| [ hd ] ->
|
866
|
f hd
|
867
|
| hd :: tl ->
|
868
|
let ok, random_mutation = f hd in
|
869
|
if ok then ok, random_mutation else apply_transform tl
|
870
|
in
|
871
|
let ok, random_mutation = apply_transform transforms in
|
872
|
let stop_process () =
|
873
|
report ~level:1 (fun fmt ->
|
874
|
fprintf fmt
|
875
|
"Only %i mutants directives generated out of %i expected@ "
|
876
|
(nb - rnb) nb);
|
877
|
mutants
|
878
|
in
|
879
|
if not ok then stop_process ()
|
880
|
else if List.mem random_mutation mutants then
|
881
|
try
|
882
|
let new_mutant = find_next_new mutants random_mutation in
|
883
|
report ~level:2 (fun fmt ->
|
884
|
fprintf fmt " %i mutants directive generated out of %i expected@ "
|
885
|
(nb - rnb) nb);
|
886
|
create_mutants_directives (rnb - 1) (new_mutant :: mutants)
|
887
|
with Not_found -> stop_process ()
|
888
|
else create_mutants_directives (rnb - 1) (random_mutation :: mutants)
|
889
|
in
|
890
|
let mutants_directives = create_mutants_directives nb [] in
|
891
|
List.map
|
892
|
(fun d ->
|
893
|
let mutant, loc = create_mutant prog d in
|
894
|
d, loc, mutant)
|
895
|
mutants_directives
|
896
|
|
897
|
let mutate nb prog =
|
898
|
records := compute_records prog;
|
899
|
(* Format.printf "Records: %i pre, %i boolexpr" (\* , %a ops *\) *)
|
900
|
(* !records.nb_pre *)
|
901
|
(* !records.nb_boolexpr *)
|
902
|
(* (\* !records.op *\) *)
|
903
|
(* ; *)
|
904
|
fold_mutate nb prog
|
905
|
|
906
|
(* Local Variables: *)
|
907
|
(* compile-command:"make -C .." *)
|
908
|
(* End: *)
|