Better fuzzing options

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

4 files changed, 81 insertions, 55 deletions

diff --git a/checklink/Check.ml b/checklink/Check.ml
index 34e6efd..dfefbfb 100644
--- a/checklink/Check.ml
+++ b/checklink/Check.ml
@@ -181,15 +181,12 @@ let mark_covered_fun_sym_ndx (ndx: int) ffw: f_framework =
   in
   ffw.sf.ef.chkd_fun_syms.(ndx) <- true;
   ffw
-  >>> ff_ef ^%=
-      add_range sym_begin sym_size align (Function_symbol(sym))
+  >>> (ff_ef ^%= add_range sym_begin sym_size align (Function_symbol(sym)))
   >>> (ff_sf ^%=
       if not (is_well_aligned sym_ofs_local align)
       then (
         sf_ef ^%=
-          add_log (ERROR(
-            "Symbol not correctly aligned in the ELF file"
-          ))
+          add_log (ERROR("Symbol not correctly aligned in the ELF file"))
       )
       else id
   )
@@ -2928,7 +2925,7 @@ let check_elf_identification efw =
   >>> ef_checkb (ei.ei_data = ELFDATA2MSB || ei.ei_data = ELFDATA2LSB)
     "ELF should be MSB or LSB"
   >>> ef_checkb (ei.ei_version = EV_CURRENT)
-    "ELF identificatin version should be EV_CURRENT"
+    "ELF identification version should be EV_CURRENT"
 
 let check_elf_header efw: e_framework =
   let eh = efw.elf.e_hdr in
diff --git a/checklink/Frameworks.ml b/checklink/Frameworks.ml
index f63eb9a..fdd0769 100644
--- a/checklink/Frameworks.ml
+++ b/checklink/Frameworks.ml
@@ -103,12 +103,6 @@ let log = {
   get = (fun ef -> ef.log);
   set = (fun l ef -> { ef with log = l });
 }
-(*
-let chkd_syms = {
-  get = (fun ef -> ef.chkd_syms);
-  set = (fun s ef -> { ef with chkd_syms = s });
-}
-*)
 
 let ident_to_sym_ndx = {
   get = (fun sf -> sf.ident_to_sym_ndx);
@@ -128,7 +122,6 @@ let add_range (start: int32) (length: int32) (align: int) (bcd: byte_chunk_desc)
   let stop = Int32.(sub (add start length) 1l) in
   {
     efw with
-      (*chkd_bytes_diet = ELFCoverage.r_add start stop efw.chkd_bytes_diet;*)
       chkd_bytes_list =
       (* Float constants can appear several times in the code, we don't
          want to add them multiple times *)
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 ()
diff --git a/checklink/Validator.ml b/checklink/Validator.ml
index f91a131..c413c75 100644
--- a/checklink/Validator.ml
+++ b/checklink/Validator.ml
@@ -6,6 +6,7 @@ open Fuzz
 let elf_file = ref (None: string option)
 let sdump_files = ref ([] : string list)
 let option_fuzz = ref false
+let option_bytefuzz = ref false
 let option_printelf = ref false
 
 let set_elf_file s =
@@ -14,20 +15,24 @@ let set_elf_file s =
   | Some _ -> raise (Arg.Bad "multiple ELF executables given on command line")
 
 let options = [
+  "-exe <filename>", Arg.String set_elf_file,
+  "Specify the ELF executable file to analyze";
+  "-debug", Arg.Set Check.debug,
+  "Print a detailed trace of verification";
+  "-noexhaust", Arg.Clear Check.exhaustivity,
+  "Disable the exhaustivity check of ELF function and data symbols";
   "-printelf", Arg.Set option_printelf,
-    "Print the contents of the unanalyzed ELF executable";
+  "Print the contents of the unanalyzed ELF executable";
   "-printelfmap", Arg.Set Check.print_elfmap,
-    "Print a map of the analyzed ELF executable";
-  "-debug", Arg.Set Check.debug,
-    "Print a detailed trace of verification";
+  "Print a map of the analyzed ELF executable";
   "-dumpelfmap", Arg.Set Check.dump_elfmap,
-    "Dump an ELF map to <exename>.elfmap, for use with random fuzzing";
-  "-exe <filename>", Arg.String set_elf_file,
-    "Specify the ELF executable file to analyze";
+  "Dump an ELF map to <exename>.elfmap, for use with random fuzzing";
   "-fuzz", Arg.Set option_fuzz,
-    "Random fuzzing test";
-  "-noexhaust", Arg.Clear Check.exhaustivity,
-    "Disable the exhaustivity check of ELF function and data symbols"
+  "Random fuzz testing";
+  "-bytefuzz", Arg.Set option_bytefuzz,
+  "Random fuzz testing byte per byte";
+  "-debugfuzz", Arg.Set Fuzz.fuzz_debug,
+  "Print a detailed trace of ongoing fuzz testing";
 ]
 
 let anonymous arg =
@@ -37,7 +42,7 @@ let anonymous arg =
     set_elf_file arg
 
 let usage =
-"The CompCert C post-linking validator, version " ^ Configuration.version ^ "
+  "The CompCert C post-linking validator, version " ^ Configuration.version ^ "
 Usage: cchecklink [options] <.sdump files> <ELF executable>
 In the absence of options, checks are performed and a short result is displayed.
 Options are:"
@@ -50,7 +55,10 @@ let _ =
       exit 2
   | Some elffilename ->
       let sdumps = List.rev !sdump_files in
-      if !option_fuzz then begin
+      if !option_bytefuzz then begin
+        Random.self_init();
+        fuzz_every_byte_loop elffilename sdumps
+      end else if !option_fuzz then begin
         Random.self_init();
         fuzz_loop elffilename sdumps
       end else if !option_printelf then begin