Better fuzzing options

git-svn-id: https://yquem.inria.fr/compcert/svn/compcert/trunk@1868 fca1b0fc-160b-0410-b1d3-a4f43f01ea2e

1 files changed, 58 insertions, 30 deletions

diff --git a/checklink/Fuzz.ml b/checklink/Fuzz.ml
index 56b665a..9653834 100644
--- a/checklink/Fuzz.ml
+++ b/checklink/Fuzz.ml
@@ -4,6 +4,8 @@ open ELF_types
 open Frameworks
 open Library
 
+let fuzz_debug = ref false
+
 let string_of_byte = Printf.sprintf "0x%02x"
 
 let full_range_of_byte elfmap byte =
@@ -18,6 +20,16 @@ let range_of_byte elfmap byte =
     when the check went fine) to stdout.
 *)
 let fuzz_check elfmap bs byte old sdumps =
+  let is_error = function ERROR(_) -> true | _ -> false in
+  let (str, _, _) = bs in
+  let fuzz_description =
+    string_of_int32 (int_int32 byte) ^ " <- " ^
+      string_of_byte (Char.code str.[byte]) ^ " (was " ^
+      string_of_byte (Char.code old) ^ ") - " ^
+      string_of_byte_chunk_desc (range_of_byte elfmap byte)
+  in
+  if !fuzz_debug
+  then print_endline fuzz_description;
   try
     (* The point here is to go all the way through the checks, and see whether
        the checker returns an ERROR or raises an exception. If not, then we
@@ -25,27 +37,32 @@ let fuzz_check elfmap bs byte old sdumps =
     *)
     let elf = read_elf_bs bs in
     let efw = check_elf_nodump elf sdumps in
-    if List.exists (function ERROR(s) -> true | _ -> false) efw.log
-    then () (* finding an ERROR is expected *)
-    else (* not finding an ERROR is bad! This is reported. *)
-      let (str, _, _) = bs in
-      print_endline (
-        string_of_int32 (int_int32 byte) ^ " <- " ^
-          string_of_byte (Char.code str.[byte]) ^ " (was " ^
-          string_of_byte (Char.code old) ^ ") - " ^
-          string_of_byte_chunk_desc (range_of_byte elfmap byte)
-      )
+    if List.exists is_error efw.log
+    then (* finding an ERROR is the expected behavior *)
+      begin
+        if !fuzz_debug
+        then print_endline (
+          string_of_log_entry false (List.find is_error efw.log)
+        )
+      end
+    else (* not finding an ERROR is bad thus reported *)
+      print_endline (fuzz_description ^ "DID NOT CAUSE AN ERROR!")
   with
   | Assert_failure(s, l, c) ->
-      Printf.eprintf "fuzz_check failed an assertion at %s (%d, %d)\n" s l c
+      if !fuzz_debug
+      then Printf.printf "fuzz_check failed an assertion at %s (%d, %d)\n" s l c
   | Match_failure(s, l, c) ->
-      Printf.eprintf "fuzz_check raised a match failure at %s (%d, %d)\n" s l c
+      if !fuzz_debug
+      then Printf.printf "fuzz_check raised a match failure at %s (%d, %d)\n" s l c
   | Not_found ->
-      Printf.eprintf "fuzz_check raised a not found exception\n"
+      if !fuzz_debug
+      then Printf.printf "fuzz_check raised a not found exception\n"
   | Invalid_argument(s) ->
-      Printf.eprintf "fuzz_check raised an invalid argument: %s\n" s
+      if !fuzz_debug
+      then Printf.printf "fuzz_check raised an invalid argument: %s\n" s
   | ELF_parsers.Unknown_endianness ->
-      Printf.eprintf "fuzz_check raised an unknown endianness exception\n"
+      if !fuzz_debug
+      then Printf.printf "fuzz_check raised an unknown endianness exception\n"
 
 (** Tries to prevent some easy-to-catch false positives. Some known false
     positives are however hard to predict. For instance, when the virtual
@@ -136,21 +153,32 @@ let fuzz_loop elffilename sdumps =
     fuzz_loop_aux ()
   in fuzz_loop_aux ()
 
+let rec fuzz_every_byte_once_aux elfmap bs sdumps (current: int): unit =
+  let (str, ofs, len) = bs in
+  if current = len / 8 (* len is in bits *)
+  then ()
+  else (
+    let fuzz = fuzz_byte str current in
+    if ok_fuzz elfmap str current fuzz
+    then (
+      let str' = String.copy str in
+      str'.[current] <- fuzz;
+      fuzz_check elfmap (str', ofs, len) current str.[current] sdumps
+    );
+    fuzz_every_byte_once_aux elfmap bs sdumps (current + 1)
+  )
+
 (** Fuzz each byte of the file once with a random new value *)
 let fuzz_every_byte_once elffilename sdumps =
   let elfmap = get_elfmap elffilename in
-  let (str, ofs, len) = Bitstring.bitstring_of_file elffilename in
-  let rec fuzz_every_byte_once_aux current limit =
-    if current = limit
-    then ()
-    else (
-      let fuzz = fuzz_byte str current in
-      if ok_fuzz elfmap str current fuzz
-      then (
-        let str' = String.copy str in
-        str'.[current] <- fuzz;
-        fuzz_check elfmap (str', ofs, len) current str.[current] sdumps
-      );
-      fuzz_every_byte_once_aux (current + 1) limit
-    )
-  in fuzz_every_byte_once_aux 0 (len/8)
+  let bs = Bitstring.bitstring_of_file elffilename in
+  fuzz_every_byte_once_aux elfmap bs sdumps 0
+
+(** Fuzz each byte of the file, then loop *)
+let fuzz_every_byte_loop elffilename sdumps =
+  let elfmap = get_elfmap elffilename in
+  let bs = Bitstring.bitstring_of_file elffilename in
+  let rec fuzz_every_byte_loop_aux () =
+    fuzz_every_byte_once_aux elfmap bs sdumps 0;
+    fuzz_every_byte_loop_aux ()
+  in fuzz_every_byte_loop_aux ()