Fix reraise, provide a better with_backtraces and fix the existing one (#20)

The `reraise` function on `master` drops the backtrace of the old exception, change this.
The `with_backtraces` function can print a message that `with_backtraces` needs to be called, change the inner workings to provide an empty backtrace and print that it's missing, and provide a new version that uses results.

All this is cram-tested to easily see how this changes the logs produced with these functions.

Author: psafont

.git-blame-ignore-revs

@@ -0,0 +1,26 @@
+## v0.8 (13-Mar-2026)
+* Set a license
+* Provide a new with_backtraces that prevents printing invalid traces
+* Fix losing backtraces when reraising
+* Add regression tests
+
+## v0.7 (18-Sep-2018)
+* Remove dependency on full sexplib
+* Simplify jbuild, quiet warnings, move to dune and update opam dependencies
+* jbuild: remove ppx_deriving_rpc from libraries
+* Move to dune and update opam dependencies
+
+## v0.6 (16-May-2018)
+* Add support for ppx_sexp_conv >= v0.11.0
+
+## v0.5 (04-Aug-2017)
+* port to jbuilder
+
+## v0.3 (21-Aug-2015)
+* correct ordering
+* add rpc to opam
+* add doc gen to _oasis
+
+## v0.2 (20-Nov-2014)
+* store backtraces as lists of records rather than strings
+* change the API for "importing" backtraces from other languages

CHANGES

@@ -22,5 +22,11 @@ test:
 doc:
 	dune build @doc --profile=release
 
+check:
+	dune build @check
+
+format:
+	dune build @fmt --auto-promote
+
 reindent:
 	ocp-indent --syntax cstruct -i **/*.ml*

CHANGES.md

@@ -1 +1,2 @@
-(lang dune 1.0)
+(lang dune 2.7)
+(cram enable)

Makefile

@@ -27,12 +27,6 @@ module Mutex = struct
     r
 end
 
-let rec split_c c str =
-  try
-    let i = String.index str c in
-    String.sub str 0 i :: (split_c c (String.sub str (i+1) (String.length str - i - 1)))
-  with Not_found -> [str]
-
 type frame = {
   process: string;
   filename: string;
@@ -52,7 +46,9 @@ let to_string_hum xs =
     Buffer.add_string results (Printf.sprintf "%d/%d %s %s file %s, line %d" i xs' x.process (if first_line then "Raised at" else "Called from") x.filename x.line);
     Buffer.add_string results "\n";
     loop false (i + 1) xs in
-  loop true 1 xs
+  match xs with
+  | [] -> Printf.sprintf "%s: Thread %d has no backtrace table" !my_name Thread.(id (self ()))
+  | _ -> loop true 1 xs
 
 type table = {
   backtraces: t array;
@@ -68,11 +64,11 @@ let max_backtraces = 100
 
 let frame_of_string process x =
   try
-    begin match split_c '"' x with
+    begin match String.split_on_char '"' x with
     | [ _; filename; rest ] ->
-      begin match split_c ',' rest with
+      begin match String.split_on_char ',' rest with
       | [ _; line_n; _ ] ->
-        begin match split_c ' ' line_n with
+        begin match String.split_on_char ' ' line_n with
         | _ :: _ :: n :: _ ->
           { process; filename; line = int_of_string n }
         | _ ->
@@ -88,7 +84,7 @@ let frame_of_string process x =
 
 let get_backtrace_401 () =
   Printexc.get_backtrace ()
-  |> split_c '\n'
+  |> String.split_on_char '\n'
   |> List.filter (fun x -> x <> "")
   |> List.map (frame_of_string !my_name)
 
@@ -147,65 +143,110 @@ let remove t exn =
       bt :: acc
   ) [] |> remove_dups |> List.concat
 
-let per_thread_backtraces = Hashtbl.create 37
-let per_thread_backtraces_m = Mutex.create ()
 
-let with_lock f x =
-  Mutex.lock per_thread_backtraces_m;
-  try
-    let result = f x in
-    Mutex.unlock per_thread_backtraces_m;
-    result
-  with e ->
-    Mutex.unlock per_thread_backtraces_m;
-    raise e
-
-let with_backtraces f =
-  let id = Thread.(id (self ())) in
-  let tbl = with_lock
-    (fun () ->
-      let tbl =
-        if Hashtbl.mem per_thread_backtraces id
-        then Hashtbl.find per_thread_backtraces id
-        else make () in
-      (* If we nest these functions we add multiple bindings
-         to the same mutable table which is ok *)
-      Hashtbl.add per_thread_backtraces id tbl;
-      tbl
-    ) () in
-  try
-    let result = f () in
-    with_lock (Hashtbl.remove per_thread_backtraces) id;
-    `Ok result
-  with e ->
-    let bt = get tbl e in
-    with_lock (Hashtbl.remove per_thread_backtraces) id;
-    `Error(e, bt)
+module IntMap = Map.Make (Int)
+
+module ThreadLocalTable = struct
+  (* The map values behave like stacks here, with shadowing as in Hashtbl.
+     A Hashtbl is not used here, in order to avoid taking the lock in `find`. *)
+  type 'a t = {mutable tbl: 'a list IntMap.t; m: Mutex.t}
+
+  let make () =
+    let tbl = IntMap.empty in
+    let m = Mutex.create () in
+    {tbl; m}
+
+  let add t v =
+    let id = Thread.(id (self ())) in
+    Mutex.execute t.m (fun () ->
+        t.tbl <-
+          IntMap.update id
+            (function Some v' -> Some (v :: v') | None -> Some [v])
+            t.tbl
+    )
+
+  let remove t =
+    let id = Thread.(id (self ())) in
+    Mutex.execute t.m (fun () ->
+        t.tbl <-
+          IntMap.update id
+            (function
+              | Some [_] ->
+                  None
+              | Some (_hd :: tl) ->
+                  Some tl
+              | Some [] | None ->
+                  None
+              )
+            t.tbl
+    )
+
+  let find t =
+    let id = Thread.(id (self ())) in
+    IntMap.find_opt id t.tbl
+    |> Option.fold ~none:None ~some:(function v :: _ -> Some v | [] -> None)
+end
+
+let per_thread_backtraces = ThreadLocalTable.make ()
+
+let ( let@ ) f x = f x
 
-let with_table f default =
-  let id = Thread.(id (self ())) in
-  match with_lock (fun () ->
-    if Hashtbl.mem per_thread_backtraces id
-    then Some (Hashtbl.find per_thread_backtraces id)
-    else None
-  ) () with
-  | None -> default ()
-  | Some tbl -> f tbl
+let try_result f = try Ok (f ()) with exn -> Error exn
+
+let with_backtraces_common f with_table =
+  let tbl =
+    let tbl = 
+      match ThreadLocalTable.find per_thread_backtraces with
+      | Some tbl -> tbl
+      | None -> make ()
+    in
+    (* If we nest these functions we add multiple bindings
+       to the same mutable table which is ok *)
+    ThreadLocalTable.add per_thread_backtraces tbl;
+    tbl
+  in
+  let finally () = ThreadLocalTable.remove per_thread_backtraces in
+  Fun.protect ~finally (fun () -> with_table tbl (try_result f))
+
+module V1 = struct
+  let with_backtraces f = 
+    let with_table tbl = function
+      | Ok ok -> `Ok ok 
+      | Error e -> `Error (e, get tbl e)
+    in
+    with_backtraces_common f with_table
+end
+
+module V2 = struct
+  let with_backtraces ~finally f =
+    let with_table tbl result =
+      result
+      |> Result.map_error (function e -> (e, get tbl e))
+      |> finally
+    in
+    with_backtraces_common f with_table
+end
 
-let is_important exn = with_table (fun tbl -> is_important tbl exn) (fun () -> ())
+let with_backtraces = V1.with_backtraces
 
-let add exn bt = with_table (fun tbl -> add tbl exn bt) (fun () -> ())
+let is_important exn =
+  ThreadLocalTable.find per_thread_backtraces
+  |> Option.iter (fun tbl -> is_important tbl exn)
 
-let warning () =
-  [ { process = !my_name;
-      filename = Printf.sprintf "(Thread %d has no backtrace table. Was with_backtraces called?" Thread.(id (self ()));
-      line = 0 } ]
+let add exn bt =
+  ThreadLocalTable.find per_thread_backtraces
+  |> Option.iter (fun tbl -> add tbl exn bt)
 
-let remove exn = with_table (fun tbl -> remove tbl exn) warning
+let remove exn =
+  ThreadLocalTable.find per_thread_backtraces
+  |> Option.fold ~some:(fun tbl -> remove tbl exn) ~none:empty
 
-let get exn = with_table (fun tbl -> get tbl exn) warning
+let get exn =
+  ThreadLocalTable.find per_thread_backtraces
+  |> Option.fold ~some:(fun tbl -> get tbl exn) ~none:empty
 
 let reraise old newexn =
+  is_important old;
   add newexn (remove old);
   raise newexn
 

dune-project

@@ -28,11 +28,24 @@ val to_string_hum: t -> string
     stash away a copy of the backtrace buffer if there is any risk
     of us raising another (or even the same) exception) *)
 
+module V1 : sig
+  val with_backtraces : (unit -> 'a) -> [ `Ok of 'a | `Error of (exn * t) ]
+  [@@deprecated "V2.with_backtraces"]
+end
+
+module V2 : sig
+  val with_backtraces : finally:(('a, exn * t) result -> 'a) -> (unit -> 'a) ->  'a
+  (** [with_backtraces thread finally] Allows backtraces to be recorded within
+      [thread]. [finally] is executed whenever [thread] finishes, this allows
+      users to use the stacktrace before it's dropped from the cache, for
+      example, to log it. *)
+end
+
 val with_backtraces: (unit -> 'a) -> [ `Ok of 'a | `Error of (exn * t) ]
 (** Allow backtraces to be recorded for this thread. All new threads
     must be wrapped in this for the backtrace tracking to work.
     It is acceptable to nest these wrappers; it will not affect the
-    backtrace recording behaviour. *)
+    backtrace recording behaviour. Please change to [V2.with_backtraces] *)
 
 val is_important: exn -> unit
 (** Declare that the backtrace is important for debugging and should be

lib/backtrace.ml

@@ -0,0 +1,13 @@
+(library
+  (name test_lib)
+  (modules log)
+  (libraries backtrace)
+  )
+
+(executable
+  (name raiser)
+  (modules raiser)
+  (libraries test_lib)
+  )
+
+(cram (deps ./raiser.exe))

lib/backtrace.mli

@@ -0,0 +1,55 @@
+let ( let@ ) f x = f x
+
+let output_log s = Printf.printf "%s\n%!" s
+
+let log_backtrace_exn exn bt =
+  (* We already got the backtrace in the `bt` argument when called from
+     with_thread_associated. Log that, and remove `exn` from the backtraces
+     table. If with_backtraces was not nested then looking at `bt` is the only
+     way to get a proper backtrace, otherwise exiting from `with_backtraces`
+     would've removed the backtrace from the thread-local backtraces table, and
+     we'd always just log a message complaining about with_backtraces not being
+     called, which is not true because it was.
+  *)
+  let bt' = Backtrace.remove exn in
+  (* bt could be empty, but bt' would contain a non-empty warning, so compare 'bt' here *)
+  let bt =
+    if bt = Backtrace.empty then
+      bt'
+    else
+      bt
+  in
+  let all = String.split_on_char '\n' Backtrace.(to_string_hum bt) in
+  output_log (Printf.sprintf "Raised %s" (Printexc.to_string exn)) ;
+  List.iter output_log all
+
+let with_thread_associated_old desc f x =
+  let result = 
+    let@ () = begin [@alert "-deprecated"] Backtrace.V1.with_backtraces end in
+    try f x with e -> Backtrace.is_important e ; raise e
+  in
+  match result with
+  | `Ok result ->
+      result
+  | `Error (exn, bt) ->
+      output_log
+        (Printf.sprintf "%s failed with exception %s" desc
+           (Printexc.to_string exn)
+        ) ;
+      log_backtrace_exn exn bt ;
+      raise exn
+
+let with_thread_associated desc f x =
+  let print_backtrace = function 
+    | Ok result ->
+        result
+    | Error (exn, bt) ->
+        output_log
+          (Printf.sprintf "%s failed with exception %s" desc
+             (Printexc.to_string exn)
+          ) ;
+        log_backtrace_exn exn bt ;
+        raise exn
+  in
+  let@ () = Backtrace.V2.with_backtraces ~finally:print_backtrace in
+  try f x with e -> Backtrace.is_important e ; raise e

test/dune

@@ -0,0 +1,5 @@
+val with_thread_associated : string -> ('a -> 'b) -> 'a -> 'b
+
+val with_thread_associated_old : string -> ('a -> 'b) -> 'a -> 'b
+(** Uses V1.with_backtrace *)
+