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