Merge pull request #378 from bobot/feature/reraise_raw_backtrace_primitive

Add reraise_raw_backtrace primitive

Changes

@@ -152,6 +152,10 @@ OCaml 4.04.0:
   array of floats
   (Thomas Braibant)
 
+- GPR#378: Add [Printexc.raise_with_backtrace] raise an exception using
+  an explicit backtrace
+  (François Bobot, review by Gabriel Scherer, Xavier Leroy, Damien Doligez,
+   Frédéric Bour)
 
 ### Manual and documentation:
 

asmrun/backtrace_prim.c

@@ -69,6 +69,14 @@ frame_descr * caml_next_frame_descriptor(uintnat * pc, char ** sp)
   }
 }
 
+int caml_alloc_backtrace_buffer(void){
+  Assert(caml_backtrace_pos == 0);
+  caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
+                                 * sizeof(backtrace_slot));
+  if (caml_backtrace_buffer == NULL) return -1;
+  return 0;
+}
+
 /* Stores the return addresses contained in the given stack fragment
    into the backtrace array ; this version is performance-sensitive as
    it is called at each [raise] in a program compiled with [-g], so we
@@ -81,12 +89,9 @@ void caml_stash_backtrace(value exn, uintnat pc, char * sp, char * trapsp)
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = exn;
   }
-  if (caml_backtrace_buffer == NULL) {
-    Assert(caml_backtrace_pos == 0);
-    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE
-                                   * sizeof(backtrace_slot));
-    if (caml_backtrace_buffer == NULL) return;
-  }
+
+  if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
+    return;
 
   /* iterate on each frame  */
   while (1) {

bytecomp/translcore.ml

@@ -338,6 +338,9 @@ let primitives_table = create_hashtable 57 [
 let find_primitive prim_name =
   Hashtbl.find primitives_table prim_name
 
+let prim_restore_raw_backtrace =
+  Primitive.simple ~name:"caml_restore_raw_backtrace" ~arity:2 ~alloc:false
+
 let specialize_comparison table env ty =
   let (gencomp, intcomp, floatcomp, stringcomp,
            nativeintcomp, int32comp, int64comp, _) = table in
@@ -771,6 +774,26 @@ and transl_exp0 e =
         match argl with [obj; meth; cache; pos] ->
           wrap (Lsend(Cached, meth, obj, [cache; pos], e.exp_loc))
         | _ -> assert false
+      else if p.prim_name = "%raise_with_backtrace" then begin
+        let texn1 = List.hd args (* Should not fail by typing *) in
+        let texn2,bt = match argl with
+          | [a;b] -> a,b
+          | _ -> assert false (* idem *)
+        in
+        let vexn = Ident.create "exn" in
+        Llet(Strict, Pgenval, vexn, texn2,
+             event_before e begin
+               Lsequence(
+                 wrap  (Lprim (Pccall prim_restore_raw_backtrace,
+                               [Lvar vexn;bt],
+                               e.exp_loc)),
+                 wrap0 (Lprim(Praise Raise_reraise,
+                              [event_after texn1 (Lvar vexn)],
+                              e.exp_loc))
+               )
+             end
+            )
+      end
       else begin
         let prim = transl_primitive_application
             e.exp_loc p e.exp_env prim_type (Some path) args in

byterun/backtrace.c

@@ -49,9 +49,11 @@ CAMLprim value caml_record_backtrace(value vflag)
     caml_backtrace_active = flag;
     caml_backtrace_pos = 0;
     caml_backtrace_last_exn = Val_unit;
-    /* Note: lazy initialization of caml_backtrace_buffer in
-       caml_stash_backtrace to simplify the interface with the thread
-       libraries */
+    /* Note: We do lazy initialization of caml_backtrace_buffer when
+       needed in order to simplify the interface with the thread
+       library (thread creation doesn't need to allocate
+       caml_backtrace_buffer). So we don't have to allocate it here.
+    */
   }
   return Val_unit;
 }
@@ -167,6 +169,41 @@ CAMLprim value caml_get_exception_raw_backtrace(value unit)
   CAMLreturn(res);
 }
 
+/* Copy back a backtrace and exception to the global state.
+   This function should be used only with Printexc.raw_backtrace */
+/* noalloc (caml value): so no CAMLparam* CAMLreturn* */
+CAMLprim value caml_restore_raw_backtrace(value exn, value backtrace)
+{
+  intnat i;
+  mlsize_t bt_size;
+
+  caml_backtrace_last_exn = exn;
+
+  bt_size = Wosize_val(backtrace);
+  if(bt_size > BACKTRACE_BUFFER_SIZE){
+    bt_size = BACKTRACE_BUFFER_SIZE;
+  }
+
+  /* We don't allocate if the backtrace is empty (no -g or backtrace
+     not activated) */
+  if(bt_size == 0){
+    caml_backtrace_pos = 0;
+    return Val_unit;
+  }
+
+  /* Allocate if needed and copy the backtrace buffer */
+  if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1){
+    return Val_unit;
+  }
+
+  caml_backtrace_pos = bt_size;
+  for(i=0; i < caml_backtrace_pos; i++){
+    caml_backtrace_buffer[i] = Backtrace_slot_val(Field(backtrace, i));
+  }
+
+  return Val_unit;
+}
+
 #define Val_debuginfo(bslot) (Val_long((uintnat)(bslot)>>1))
 #define Debuginfo_val(vslot) ((debuginfo)(Long_val(vslot) << 1))
 

byterun/backtrace_prim.c

@@ -217,6 +217,13 @@ CAMLprim value caml_remove_debug_info(code_t start)
   CAMLreturn(Val_unit);
 }
 
+int caml_alloc_backtrace_buffer(void){
+  Assert(caml_backtrace_pos == 0);
+  caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
+  if (caml_backtrace_buffer == NULL) return -1;
+  return 0;
+}
+
 /* Store the return addresses contained in the given stack fragment
    into the backtrace array */
 
@@ -228,11 +235,8 @@ void caml_stash_backtrace(value exn, code_t pc, value * sp, int reraise)
     caml_backtrace_last_exn = exn;
   }
 
-  if (caml_backtrace_buffer == NULL) {
-    Assert(caml_backtrace_pos == 0);
-    caml_backtrace_buffer = malloc(BACKTRACE_BUFFER_SIZE * sizeof(code_t));
-    if (caml_backtrace_buffer == NULL) return;
-  }
+  if (caml_backtrace_buffer == NULL && caml_alloc_backtrace_buffer() == -1)
+    return;
 
   if (caml_backtrace_pos >= BACKTRACE_BUFFER_SIZE) return;
   /* testing the code region is needed: PR#1554 */

byterun/caml/backtrace_prim.h

@@ -70,6 +70,9 @@ void caml_debuginfo_location(debuginfo dbg, /*out*/ struct caml_loc_info * li);
 #define Val_backtrace_slot(bslot) (Val_long(((uintnat)(bslot))>>1))
 #define Backtrace_slot_val(vslot) ((backtrace_slot)(Long_val(vslot) << 1))
 
+/* Allocate the caml_backtrace_buffer. Returns 0 on success, -1 otherwise */
+int caml_alloc_backtrace_buffer(void);
+
 #define BACKTRACE_BUFFER_SIZE 1024
 
 /* Besides decoding backtrace info, [backtrace_prim] has two other

stdlib/printexc.ml

@@ -89,6 +89,9 @@ type raw_backtrace
 external get_raw_backtrace:
   unit -> raw_backtrace = "caml_get_exception_raw_backtrace"
 
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+  = "%raise_with_backtrace"
+
 type backtrace_slot =
   | Known_location of {
       is_raise    : bool;
@@ -236,8 +239,7 @@ external get_raw_backtrace_next_slot :
 
 (* confusingly named:
    returns the *string* corresponding to the global current backtrace *)
-let get_backtrace () =
-  backtrace_to_string (convert_raw_backtrace (get_raw_backtrace ()))
+let get_backtrace () = raw_backtrace_to_string (get_raw_backtrace ())
 
 external record_backtrace: bool -> unit = "caml_record_backtrace"
 external backtrace_status: unit -> bool = "caml_backtrace_status"

stdlib/printexc.mli

@@ -42,13 +42,20 @@ val print_backtrace: out_channel -> unit
     on the output channel [oc].  The backtrace lists the program
     locations where the most-recently raised exception was raised
     and where it was propagated through function calls.
+
+    If the call is not inside an exception handler, the returned
+    backtrace is unspecified. If the call is after some
+    exception-catching code (before in the handler, or in a when-guard
+    during the matching of the exception handler), the backtrace may
+    correspond to a later exception than the handled one.
+
     @since 3.11.0
 *)
 
 val get_backtrace: unit -> string
 (** [Printexc.get_backtrace ()] returns a string containing the
     same exception backtrace that [Printexc.print_backtrace] would
-    print.
+    print. Same restriction usage than {!print_backtrace}.
     @since 3.11.0
 *)
 
@@ -106,7 +113,7 @@ type raw_backtrace
 val get_raw_backtrace: unit -> raw_backtrace
 (** [Printexc.get_raw_backtrace ()] returns the same exception
     backtrace that [Printexc.print_backtrace] would print, but in
-    a raw format.
+    a raw format. Same restriction usage than {!print_backtrace}.
 
     @since 4.01.0
 *)
@@ -125,6 +132,14 @@ val raw_backtrace_to_string: raw_backtrace -> string
     @since 4.01.0
 *)
 
+external raise_with_backtrace: exn -> raw_backtrace -> 'a
+  = "%raise_with_backtrace"
+(** Reraise the exception using the given raw_backtrace for the
+    origin of the exception
+
+    @since 4.03.0
+*)
+
 (** {6 Current call stack} *)
 
 val get_callstack: int -> raw_backtrace

testsuite/tests/backtrace/backtrace2.byte.reference

@@ -2,26 +2,57 @@ a
 No exception
 b
 Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Re-raised at file "backtrace2.ml", line 13, characters 68-71
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 68-71
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 14, characters 26-37
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 16, characters 26-37
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 7, characters 21-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 8, characters 23-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 56-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 68-71
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 192, characters 19-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 67-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 24-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 192, characters 19-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 62-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 10-11
+Called from file "backtrace2.ml", line 58, characters 11-23

testsuite/tests/backtrace/backtrace2.ml

@@ -3,17 +3,57 @@
 
 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 =
+let test_Error msg =
+  let rec f msg n =
+    if n = 0 then raise(Error msg) else 1 + f msg (n-1) in
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> false in
   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")
+     (** [Error "d"] not caught *)
+     (** Test reraise when an exception is used in the middle of the exception
+         handler. Currently the wrong backtrace is used. *)
+     | Error "e" as exn ->
+         print_string "e"; print_newline ();
+         ignore (exception_raised_internally ()); raise exn
+     (** Test reraise of backtrace when a `when` clause use exceptions.
+         Currently the wrong backtrace is used.
+     *)
+     | Error "f" when exception_raised_internally () ->
+         assert false (** absurd: when false *)
+     | Error "f" as exn -> print_string "f"; print_newline(); raise exn
 
-let run args =
+let test_Not_found () =
+  let rec aux n =
+    if n = 0 then raise Not_found else 1 + aux (n-1)
+  in
+  try aux 5
+  (** Test the raise to reraise heuristic with included try_with.
+      Currently the wrong backtrace is used. *)
+  with exn ->
+    print_string "test_Not_found"; print_newline();
+    (try Hashtbl.find (Hashtbl.create 3) 0 with Not_found -> raise exn)
+
+let test_lazy =
+  let rec aux n =
+    if n = 0 then raise Not_found else 1 + aux (n-1)
+  in
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> () in
+  let l = lazy (aux 5) in
+  (** Test the backtrace obtained from a lazy value.
+      Currently the second time the value is forced the
+      wrong backtrace is used. *)
+  fun () ->
+    exception_raised_internally ();
+    Lazy.force l
+
+let run g args =
   try
     ignore (g args.(0)); print_string "No exception\n"
   with exn ->
@@ -22,8 +62,14 @@ let run args =
 
 let _ =
   Printexc.record_backtrace true;
-  run [| "a" |];
-  run [| "b" |];
-  run [| "c" |];
-  run [| "d" |];
-  run [| |]
+  run test_Error [| "a" |];
+  run test_Error [| "b" |];
+  run test_Error [| "c" |];
+  run test_Error [| "d" |];
+  run test_Error [| "e" |];
+  run test_Error [| "f" |];
+  run test_Error [| |];
+  run test_Not_found  [| () |];
+  run test_lazy  [| () |];
+  run test_lazy  [| () |];
+  ()

testsuite/tests/backtrace/backtrace2.native.reference

@@ -2,26 +2,57 @@ a
 No exception
 b
 Uncaught exception Backtrace2.Error("b")
-Raised at file "backtrace2.ml", line 7, characters 16-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Re-raised at file "backtrace2.ml", line 13, characters 62-71
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Re-raised at file "backtrace2.ml", line 15, characters 62-71
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Backtrace2.Error("c")
-Raised at file "backtrace2.ml", line 14, characters 20-37
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 16, characters 20-37
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Backtrace2.Error("d")
-Raised at file "backtrace2.ml", line 7, characters 16-32
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 7, characters 42-53
-Called from file "backtrace2.ml", line 11, characters 4-11
-Called from file "backtrace2.ml", line 18, characters 11-23
+Raised at file "backtrace2.ml", line 8, characters 18-34
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 8, characters 44-55
+Called from file "backtrace2.ml", line 13, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+e
+Uncaught exception Backtrace2.Error("e")
+Raised at file "backtrace2.ml", line 22, characters 50-59
+Called from file "backtrace2.ml", line 58, characters 11-23
+f
+Uncaught exception Backtrace2.Error("f")
+Raised at file "backtrace2.ml", line 28, characters 62-71
+Called from file "backtrace2.ml", line 58, characters 11-23
 Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "backtrace2.ml", line 18, characters 14-22
+Raised by primitive operation at file "backtrace2.ml", line 58, characters 14-22
+test_Not_found
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 192, characters 13-28
+Called from file "backtrace2.ml", line 39, characters 9-42
+Re-raised at file "backtrace2.ml", line 39, characters 61-70
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "backtrace2.ml", line 43, characters 18-33
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "backtrace2.ml", line 43, characters 43-52
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23
+Uncaught exception Not_found
+Raised at file "hashtbl.ml", line 192, characters 13-28
+Called from file "backtrace2.ml", line 46, characters 8-41
+Re-raised at file "camlinternalLazy.ml", line 33, characters 56-63
+Called from file "camlinternalLazy.ml", line 27, characters 17-27
+Re-raised at file "camlinternalLazy.ml", line 34, characters 4-11
+Called from file "backtrace2.ml", line 58, characters 11-23

testsuite/tests/backtrace/raw_backtrace.byte.reference

@@ -8,12 +8,12 @@ Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 13, characters 68-71
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 68-71
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 14, characters 26-37
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Raised at file "raw_backtrace.ml", line 19, characters 26-37
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Raw_backtrace.Error("d")
 Raised at file "raw_backtrace.ml", line 7, characters 21-32
 Called from file "raw_backtrace.ml", line 7, characters 42-53
@@ -21,7 +21,29 @@ Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 39-42
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+Raised at file "raw_backtrace.ml", line 7, characters 21-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 39-54
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22

testsuite/tests/backtrace/raw_backtrace.ml

@@ -6,12 +6,27 @@ exception Error of string
 let rec f msg n =
   if n = 0 then raise(Error msg) else 1 + f msg (n-1)
 
+exception Localized of exn
+
 let g msg =
+  let exception_raised_internally () =
+    try Hashtbl.find (Hashtbl.create 3) 0
+    with Not_found -> false in
   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")
+     (** [Error "d"] not caught *)
+     | Error "e" as exn ->
+         let bt = Printexc.get_raw_backtrace () in
+         print_string "e"; print_newline ();
+         ignore (exception_raised_internally ());
+         Printexc.raise_with_backtrace exn bt
+     | Error "f" as exn ->
+         let bt = Printexc.get_raw_backtrace () in
+         print_string "f"; print_newline ();
+         Printexc.raise_with_backtrace (Localized exn) bt
 
 let backtrace args =
   try
@@ -30,7 +45,8 @@ let run args =
         try ignore (f "c" 5); assert false with Error _ -> ();
       end;
       Printf.printf "Uncaught exception %s\n" exn;
-      Printexc.print_raw_backtrace stdout trace
+      Printexc.print_raw_backtrace stdout trace;
+      flush stdout
 
 let _ =
   Printexc.record_backtrace true;
@@ -38,4 +54,6 @@ let _ =
   run [| "b" |];
   run [| "c" |];
   run [| "d" |];
+  run [| "e" |];
+  run [| "f" |];
   run [| |]

testsuite/tests/backtrace/raw_backtrace.native.reference

@@ -8,12 +8,12 @@ Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Re-raised at file "raw_backtrace.ml", line 13, characters 62-71
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 18, characters 62-71
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Raw_backtrace.Error("c")
-Raised at file "raw_backtrace.ml", line 14, characters 20-37
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Raised at file "raw_backtrace.ml", line 19, characters 20-37
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Raw_backtrace.Error("d")
 Raised at file "raw_backtrace.ml", line 7, characters 16-32
 Called from file "raw_backtrace.ml", line 7, characters 42-53
@@ -21,7 +21,29 @@ Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
 Called from file "raw_backtrace.ml", line 7, characters 42-53
-Called from file "raw_backtrace.ml", line 11, characters 4-11
-Called from file "raw_backtrace.ml", line 18, characters 11-23
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+e
+Uncaught exception Raw_backtrace.Error("e")
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 25, characters 9-45
+Called from file "raw_backtrace.ml", line 33, characters 11-23
+f
+Uncaught exception Raw_backtrace.Localized(_)
+Raised at file "raw_backtrace.ml", line 7, characters 16-32
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 7, characters 42-53
+Called from file "raw_backtrace.ml", line 16, characters 4-11
+Re-raised at file "raw_backtrace.ml", line 29, characters 9-57
+Called from file "raw_backtrace.ml", line 33, characters 11-23
 Uncaught exception Invalid_argument("index out of bounds")
-Raised by primitive operation at file "raw_backtrace.ml", line 18, characters 14-22
+Raised by primitive operation at file "raw_backtrace.ml", line 33, characters 14-22

testsuite/tests/lib-threads/backtrace_threads.ml

@@ -0,0 +1,18 @@
+
+let () = Printexc.record_backtrace true
+
+let () =
+   let bt =
+     try
+       Hashtbl.find (Hashtbl.create 1) 1;
+       assert false
+     with Not_found ->
+       Printexc.get_raw_backtrace ()
+   in
+   let t = Thread.create (fun () ->
+       try
+         Printexc.raise_with_backtrace Not_found bt
+       with Not_found -> ()
+     ) () in
+   Thread.join t;
+   flush stdout