Add tests and Changes entry for afl-fuzz classes fix.

5 files changed, 146 insertions, 0 deletions

diff --git a/Changes b/Changes
index 65f531f2d7..38b2025ca6 100644
--- a/Changes
+++ b/Changes
@@ -686,6 +686,9 @@ Release branch for 4.06:
 - GPR#1308: Only treat pure patterns as inactive
   (Leo White, review by Alain Frisch and Gabriel Scherer)
 
+- MPR#7612, GPR#1345: afl-instrumentation bugfix for classes.
+  (Stephen Dolan, review by Gabriel Scherer and David Allsopp)
+
 - MPR#7619, GPR#1387: position of the optional last semi-column not included
   in the position of the expression (same behavior as for lists)
   (Christophe Raffalli, review by Gabriel Scherer)
diff --git a/testsuite/tests/afl-instrumentation/Makefile b/testsuite/tests/afl-instrumentation/Makefile
new file mode 100644
index 0000000000..b741d5acc6
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/Makefile
@@ -0,0 +1,15 @@
+BASEDIR=../..
+
+default:
+	@printf " ... testing 'afl_instrumentation':"
+	@if ! which afl-showmap > /dev/null; then \
+	  echo " => skipped (afl-showmap unavailable)"; \
+	else \
+	  if OCAMLOPT='$(OCAMLOPT)' ./test.sh > /dev/null; then \
+	    echo " => passed"; \
+	  else \
+	    echo " => failed"; \
+	  fi \
+	fi
+
+include $(BASEDIR)/makefiles/Makefile.common
diff --git a/testsuite/tests/afl-instrumentation/harness.ml b/testsuite/tests/afl-instrumentation/harness.ml
new file mode 100644
index 0000000000..dbcbebf0b1
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/harness.ml
@@ -0,0 +1,22 @@
+external reset_instrumentation : bool -> unit = "caml_reset_afl_instrumentation"
+external sys_exit : int -> 'a = "caml_sys_exit"
+
+let name n =
+  fst (Test.tests.(int_of_string n - 1))
+let run n =
+  snd (Test.tests.(int_of_string n - 1)) ()
+
+let orig_random = Random.get_state ()
+
+let () =
+  (* Random.set_state orig_random; *)
+  reset_instrumentation true;
+  begin
+    match Sys.argv with
+    | [| _; "len" |] -> print_int (Array.length Test.tests); print_newline (); flush stdout
+    | [| _; "name"; n |] -> print_string (name n); flush stdout
+    | [| _; "1"; n |] -> run n
+    | [| _; "2"; n |] -> run n; (* Random.set_state orig_random;  *)reset_instrumentation false; run n
+    | _ -> failwith "error"
+  end;
+  sys_exit 0
diff --git a/testsuite/tests/afl-instrumentation/test.ml b/testsuite/tests/afl-instrumentation/test.ml
new file mode 100644
index 0000000000..83c1fc00fe
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/test.ml
@@ -0,0 +1,73 @@
+let opaque = Sys.opaque_identity
+
+let lists n =
+  let l = opaque [n; n; n] in
+  match List.rev l with
+  | [a; b; c] when a = n && b = n && c = n -> ()
+  | _ -> assert false
+
+let fresh_exception x =
+  opaque @@
+    let module M = struct
+        exception E of int
+        let throw () = raise (E x)
+      end in
+    try
+      M.throw ()
+    with
+      M.E n -> assert (n = x)
+
+let obj_with_closure x =
+  opaque (object method foo = x end)
+
+let r = ref 42
+let state () =
+  incr r;
+  if !r > 43 then print_string "woo" else ()
+
+let classes (x : int) =
+  opaque @@
+    let module M = struct
+        class a = object
+          method foo = x
+        end
+        class c = object
+          inherit a
+        end
+      end in
+    let o = new M.c in
+    assert (o#foo = x)
+
+
+class c_global = object
+  method foo = 42
+end
+let obj_ordering () = opaque @@
+  (* Object IDs change, but should be in the same relative order *)
+  let a = new c_global in
+  let b = new c_global in
+  if a < b then print_string "a" else print_string "b"
+
+let random () = opaque @@
+  (* as long as there's no self_init, this should be deterministic *)
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b";
+  if Random.int 100 < 50 then print_string "a" else print_string "b"
+
+let tests =
+  [| ("lists", fun () -> lists 42);
+     ("manylists", fun () -> for i = 1 to 10 do lists 42 done);
+     ("exceptions", fun () -> fresh_exception 100);
+     ("objects", fun () -> ignore (obj_with_closure 42));
+     (* ("state", state); *) (* this one should fail *)
+     ("classes", fun () -> classes 42);
+     ("obj_ordering", obj_ordering);
+     (* ("random", random); *)
+  |]
+  
diff --git a/testsuite/tests/afl-instrumentation/test.sh b/testsuite/tests/afl-instrumentation/test.sh
new file mode 100755
index 0000000000..804db5f210
--- /dev/null
+++ b/testsuite/tests/afl-instrumentation/test.sh
@@ -0,0 +1,33 @@
+#!/bin/bash
+
+set -e
+
+$OCAMLOPT -c -afl-instrument test.ml
+$OCAMLOPT -afl-inst-ratio 0 test.cmx harness.ml -o test
+
+NTESTS=`./test len`
+failures=''
+echo "running $NTESTS tests..."
+for t in `seq 1 $NTESTS`; do
+  printf "%14s: " `./test name $t`
+  # when run twice, the instrumentation output should double
+  afl-showmap -q -o output-1 -- ./test 1 $t
+  afl-showmap -q -o output-2 -- ./test 2 $t
+  # see afl-showmap.c for what the numbers mean
+  cat output-1 | sed '
+    s/:6/:7/; s/:5/:6/;
+    s/:4/:5/; s/:3/:4/;
+    s/:2/:4/; s/:1/:2/;
+  ' > output-2-predicted
+  if cmp -s output-2-predicted output-2; then
+    echo "passed."
+  else
+    echo "failed:"
+    paste output-2 output-1
+    failures=1
+  fi
+done
+
+if [ -z "$failures" ]; then echo "all tests passed"; else exit 1; fi
+
+rm -f {test,harness}.{cmi,cmx,o} test output-{1,2,2-predicted}