Permalink
Browse files

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
  • Loading branch information...
1 parent cc6b2ca commit 3dae9e6014af007e41faf254e053c21d67a3557d @gasche gasche committed May 10, 2014
@@ -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
@@ -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 [| |]
@@ -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
@@ -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 [| |]
@@ -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

0 comments on commit 3dae9e6

Please sign in to comment.