From 3dae9e6014af007e41faf254e053c21d67a3557d Mon Sep 17 00:00:00 2001 From: Gabriel Scherer Date: May 10 2014 19:19:57 +0000 Subject: improve backtrace testsuite Test the behavior of the deprecated primitive [caml_get_exception_backtrace], and minimal tests for hashing/comparison of raw backtrace slots. git-svn-id: http://caml.inria.fr/svn/ocaml/trunk@14782 f963ae5c-01c2-4b8c-9fe0-0dff7051ff02 --- diff --git a/testsuite/tests/backtrace/Makefile b/testsuite/tests/backtrace/Makefile index 32533fd..1ca390f 100644 --- a/testsuite/tests/backtrace/Makefile +++ b/testsuite/tests/backtrace/Makefile @@ -14,7 +14,8 @@ BASEDIR=../.. EXECNAME=program$(EXE) ABCDFILES=backtrace.ml -OTHERFILES=backtrace2.ml raw_backtrace.ml +OTHERFILES=backtrace2.ml raw_backtrace.ml \ + backtrace_deprecated.ml backtrace_slots.ml default: $(MAKE) byte diff --git a/testsuite/tests/backtrace/backtrace_deprecated.ml b/testsuite/tests/backtrace/backtrace_deprecated.ml new file mode 100644 index 0000000..12621a1 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.ml @@ -0,0 +1,50 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +external get_backtrace : unit -> Printexc.backtrace_slot array option + = "caml_get_exception_backtrace" + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> function + | None -> () + | Some trace -> + Array.iteri + (fun i slot -> + if slot <> Printexc.Unknown_location true then + print_endline (Printexc.format_backtrace_slot i slot)) + trace + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_deprecated.reference b/testsuite/tests/backtrace/backtrace_deprecated.reference new file mode 100644 index 0000000..e9fea9f --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_deprecated.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_deprecated.Error("b") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Re-raised at file "backtrace_deprecated.ml", line 27, characters 68-71 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("c") +Raised at file "backtrace_deprecated.ml", line 28, characters 26-37 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Backtrace_deprecated.Error("d") +Raised at file "backtrace_deprecated.ml", line 21, characters 21-32 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 21, characters 42-53 +Called from file "backtrace_deprecated.ml", line 25, characters 4-11 +Called from file "backtrace_deprecated.ml", line 32, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_deprecated.ml", line 32, characters 14-22 diff --git a/testsuite/tests/backtrace/backtrace_slots.ml b/testsuite/tests/backtrace/backtrace_slots.ml new file mode 100644 index 0000000..a9f8451 --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.ml @@ -0,0 +1,69 @@ +(***********************************************************************) +(* *) +(* OCaml *) +(* *) +(* Xavier Leroy, projet Gallium, INRIA Rocquencourt *) +(* *) +(* Copyright 2008 Institut National de Recherche en Informatique et *) +(* en Automatique. All rights reserved. This file is distributed *) +(* under the terms of the Q Public License version 1.0. *) +(* *) +(***********************************************************************) + +(* A test for stack backtraces *) + +let get_backtrace () = + let raw_backtrace = Printexc.get_raw_backtrace () in + let convert = Printexc.convert_raw_backtrace_slot in + let backtrace = Array.map convert raw_backtrace in + (* we'll play with slots a bit to check that hashing and comparison work: + - create a hashtable that maps slots to their index in the raw backtrace + - create a balanced set of all slots + *) + let table = Hashtbl.create 100 in + Array.iteri (fun i slot -> Hashtbl.add table slot i) raw_backtrace; + let module S = Set.Make(struct + type t = Printexc.raw_backtrace_slot + let compare = Pervasives.compare + end) in + let slots = Array.fold_right S.add raw_backtrace S.empty in + Array.iteri (fun i slot -> + assert (S.mem slot slots); + assert (Hashtbl.mem table slot); + let j = + (* position in the table of the last slot equal to [slot] *) + Hashtbl.find table slot in + assert (slot = raw_backtrace.(j)); + assert (backtrace.(i) = backtrace.(j)); + ) raw_backtrace; + backtrace + +exception Error of string + +let rec f msg n = + if n = 0 then raise(Error msg) else 1 + f msg (n-1) + +let g msg = + try + f msg 5 + with Error "a" -> print_string "a"; print_newline(); 0 + | Error "b" as exn -> print_string "b"; print_newline(); raise exn + | Error "c" -> raise (Error "c") + +let run args = + try + ignore (g args.(0)); print_string "No exception\n" + with exn -> + Printf.printf "Uncaught exception %s\n" (Printexc.to_string exn); + get_backtrace () |> Array.iteri + (fun i slot -> + if slot <> Printexc.Unknown_location true then + print_endline (Printexc.format_backtrace_slot i slot)) + +let _ = + Printexc.record_backtrace true; + run [| "a" |]; + run [| "b" |]; + run [| "c" |]; + run [| "d" |]; + run [| |] diff --git a/testsuite/tests/backtrace/backtrace_slots.reference b/testsuite/tests/backtrace/backtrace_slots.reference new file mode 100644 index 0000000..bb6361c --- /dev/null +++ b/testsuite/tests/backtrace/backtrace_slots.reference @@ -0,0 +1,27 @@ +a +No exception +b +Uncaught exception Backtrace_slots.Error("b") +Raised at file "backtrace_slots.ml", line 44, characters 21-32 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 48, characters 4-11 +Re-raised at file "backtrace_slots.ml", line 50, characters 68-71 +Called from file "backtrace_slots.ml", line 55, characters 11-23 +Uncaught exception Backtrace_slots.Error("c") +Raised at file "backtrace_slots.ml", line 51, characters 26-37 +Called from file "backtrace_slots.ml", line 55, characters 11-23 +Uncaught exception Backtrace_slots.Error("d") +Raised at file "backtrace_slots.ml", line 44, characters 21-32 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 44, characters 42-53 +Called from file "backtrace_slots.ml", line 48, characters 4-11 +Called from file "backtrace_slots.ml", line 55, characters 11-23 +Uncaught exception Invalid_argument("index out of bounds") +Raised by primitive operation at file "backtrace_slots.ml", line 55, characters 14-22