Revision 55a8633c
Added by Pierre-Loïc Garoche almost 7 years ago
| src/mutation.ml | ||
|---|---|---|
| 344 | 344 |
|
| 345 | 345 |
type mutant_t = Boolexpr of int | Pre of int | Op of string * int * string | IncrIntCst of int | DecrIntCst of int | SwitchIntCst of int * int |
| 346 | 346 |
|
| 347 |
(* Denotes the parent node, the equation lhs and the location of the mutation *) |
|
| 348 |
type mutation_loc = ident * ident list * Location.t |
|
| 347 | 349 |
let target : mutant_t option ref = ref None |
| 348 | 350 |
|
| 351 |
let mutation_info : mutation_loc option ref = ref None |
|
| 352 |
let current_node: ident option ref = ref None |
|
| 353 |
let current_eq_lhs : ident list option ref = ref None |
|
| 354 |
let current_loc : Location.t option ref = ref None |
|
| 355 |
|
|
| 356 |
let set_mutation_loc () = |
|
| 357 |
target := None; |
|
| 358 |
match !current_node, !current_eq_lhs, !current_loc with |
|
| 359 |
| Some n, Some elhs, Some l -> mutation_info := Some (n, elhs, l) |
|
| 360 |
| _ -> assert false (* Those global vars should be defined during the |
|
| 361 |
visitor pattern execution *) |
|
| 362 |
|
|
| 349 | 363 |
let print_directive fmt d = |
| 350 | 364 |
match d with |
| 351 | 365 |
| Pre n -> Format.fprintf fmt "pre %i" n |
| ... | ... | |
| 355 | 369 |
| DecrIntCst n -> Format.fprintf fmt "decr int cst %i" n |
| 356 | 370 |
| SwitchIntCst (n, m) -> Format.fprintf fmt "switch int cst %i -> %i" n m |
| 357 | 371 |
|
| 372 |
let print_directive_json fmt d = |
|
| 373 |
match d with |
|
| 374 |
| Pre _ -> Format.fprintf fmt "\"mutation\": \"pre\"" |
|
| 375 |
| Boolexpr _ -> Format.fprintf fmt "\"mutation\": \"not\"" |
|
| 376 |
| Op (o, _, d) -> Format.fprintf fmt "\"mutation\": \"op_conv\", \"from\": \"%s\", \"to\": \"%s\"" o d |
|
| 377 |
| IncrIntCst n -> Format.fprintf fmt "\"mutation\": \"cst_incr\"" |
|
| 378 |
| DecrIntCst n -> Format.fprintf fmt "\"mutation\": \"cst_decr\"" |
|
| 379 |
| SwitchIntCst (n, m) -> Format.fprintf fmt "\"mutation\": \"cst_switch\", \"to_cst\": \"%i\"" m |
|
| 380 |
|
|
| 381 |
let print_loc_json fmt (n,eqlhs, l) = |
|
| 382 |
Format.fprintf fmt "\"node_id\": \"%s\", \"eq_lhs\": [%a], \"loc_line\": \"%i\"" |
|
| 383 |
n |
|
| 384 |
(Utils.fprintf_list ~sep:", " (fun fmt s -> Format.fprintf fmt "\"%s\"" s)) eqlhs |
|
| 385 |
(Location.loc_line l) |
|
| 386 |
|
|
| 358 | 387 |
let fold_mutate_int i = |
| 359 | 388 |
if Random.int 100 > threshold_inc_int then |
| 360 | 389 |
i+1 |
| ... | ... | |
| 390 | 419 |
(* | _ -> op *) |
| 391 | 420 |
match !target with |
| 392 | 421 |
| Some (Op(op_orig, 0, op_new)) when op_orig = op -> ( |
| 393 |
target := None;
|
|
| 422 |
set_mutation_loc ();
|
|
| 394 | 423 |
op_new |
| 395 | 424 |
) |
| 396 | 425 |
| Some (Op(op_orig, n, op_new)) when op_orig = op -> ( |
| ... | ... | |
| 413 | 442 |
let fold_mutate_boolexpr expr = |
| 414 | 443 |
match !target with |
| 415 | 444 |
| Some (Boolexpr 0) -> ( |
| 416 |
target := None; |
|
| 445 |
set_mutation_loc (); |
|
| 446 |
|
|
| 417 | 447 |
mkpredef_call expr.expr_loc "not" [expr] |
| 418 | 448 |
) |
| 419 | 449 |
| Some (Boolexpr n) -> |
| ... | ... | |
| 423 | 453 |
let fold_mutate_pre orig_expr e = |
| 424 | 454 |
match !target with |
| 425 | 455 |
Some (Pre 0) -> ( |
| 426 |
target := None;
|
|
| 456 |
set_mutation_loc ();
|
|
| 427 | 457 |
Expr_pre ({orig_expr with expr_desc = Expr_pre e})
|
| 428 | 458 |
) |
| 429 | 459 |
| Some (Pre n) -> ( |
| ... | ... | |
| 436 | 466 |
match c with |
| 437 | 467 |
| Const_int i -> ( |
| 438 | 468 |
match !target with |
| 439 |
| Some (IncrIntCst 0) -> (target := None; Const_int (i+1))
|
|
| 440 |
| Some (DecrIntCst 0) -> (target := None; Const_int (i-1))
|
|
| 441 |
| Some (SwitchIntCst (0, id)) -> (target := None; Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id))
|
|
| 469 |
| Some (IncrIntCst 0) -> (set_mutation_loc (); Const_int (i+1))
|
|
| 470 |
| Some (DecrIntCst 0) -> (set_mutation_loc (); Const_int (i-1))
|
|
| 471 |
| Some (SwitchIntCst (0, id)) -> (set_mutation_loc (); Const_int (List.nth (IntSet.elements (IntSet.remove i !records.consts)) id))
|
|
| 442 | 472 |
| Some (IncrIntCst n) -> (target := Some (IncrIntCst (n-1)); c) |
| 443 | 473 |
| Some (DecrIntCst n) -> (target := Some (DecrIntCst (n-1)); c) |
| 444 | 474 |
| Some (SwitchIntCst (n, id)) -> (target := Some (SwitchIntCst (n-1, id)); c) |
| ... | ... | |
| 459 | 489 |
{ c with const_value = fold_mutate_const_value c.const_value }
|
| 460 | 490 |
|
| 461 | 491 |
let rec fold_mutate_expr expr = |
| 492 |
current_loc := Some expr.expr_loc; |
|
| 462 | 493 |
let new_expr = |
| 463 | 494 |
match expr.expr_desc with |
| 464 | 495 |
| Expr_ident id -> fold_mutate_var expr |
| ... | ... | |
| 492 | 523 |
new_expr |
| 493 | 524 |
|
| 494 | 525 |
let fold_mutate_eq eq = |
| 526 |
current_eq_lhs := Some eq.eq_lhs; |
|
| 495 | 527 |
{ eq with eq_rhs = fold_mutate_expr eq.eq_rhs }
|
| 496 | 528 |
|
| 497 | 529 |
let fold_mutate_stmt stmt = |
| ... | ... | |
| 499 | 531 |
| Eq eq -> Eq (fold_mutate_eq eq) |
| 500 | 532 |
| Aut aut -> assert false |
| 501 | 533 |
|
| 502 |
let fold_mutate_node nd = |
|
| 534 |
let fold_mutate_node nd = |
|
| 535 |
current_node := Some nd.node_id; |
|
| 503 | 536 |
{ nd with
|
| 504 | 537 |
node_stmts = |
| 505 | 538 |
List.fold_right (fun stmt res -> (fold_mutate_stmt stmt)::res) nd.node_stmts []; |
| ... | ... | |
| 519 | 552 |
let create_mutant prog directive = |
| 520 | 553 |
target := Some directive; |
| 521 | 554 |
let prog' = fold_mutate_prog prog in |
| 522 |
target := None; |
|
| 523 |
prog' |
|
| 555 |
let mutation_info = match !target , !mutation_info with |
|
| 556 |
| None, Some mi -> mi |
|
| 557 |
| _ -> assert false (* The mutation has not been performed. *) |
|
| 558 |
|
|
| 559 |
in |
|
| 560 |
(* target := None; (* should happen only if no mutation occured during the |
|
| 561 |
visit *)*) |
|
| 562 |
prog', mutation_info |
|
| 524 | 563 |
|
| 525 | 564 |
|
| 526 | 565 |
let op_mutation op = |
| ... | ... | |
| 645 | 684 |
create_mutants_directives (rnb-1) (random_mutation::mutants) |
| 646 | 685 |
in |
| 647 | 686 |
let mutants_directives = create_mutants_directives nb [] in |
| 648 |
List.map (fun d -> d, create_mutant prog d) mutants_directives |
|
| 687 |
List.map (fun d -> |
|
| 688 |
let mutant, loc = create_mutant prog d in |
|
| 689 |
d, loc, mutant ) mutants_directives |
|
| 649 | 690 |
|
| 650 | 691 |
|
| 651 | 692 |
let mutate nb prog = |
| ... | ... | |
| 655 | 696 |
(* !records.nb_boolexpr *) |
| 656 | 697 |
(* (\* !records.op *\) *) |
| 657 | 698 |
(* ; *) |
| 658 |
fold_mutate nb prog, print_directive
|
|
| 699 |
fold_mutate nb prog
|
|
| 659 | 700 |
|
| 660 | 701 |
|
| 661 | 702 |
|
Also available in: Unified diff
[lustret] Improved mutation with json traceability