Preserve backtraces in debugger

Add Primitives.cleanup which allows handlers for unexpected exceptions
to cleanup and reraise the exception with its backtrace.

Changes

@@ -140,6 +140,10 @@ Working version
 
 ### Tools:
 
+- #9057: aid debugging the debugger by preserving backtraces of unhandled
+  exceptions.
+  (David Allsopp, review by Gabriel Scherer)
+
 - #9276: objinfo: cm[x]a print extra C options, objects and dlls in
   the order given on the cli. Follow up to #4949.
   (Daniel Bünzli, review by Gabriel Scherer)

debugger/breakpoints.ml

@@ -16,6 +16,7 @@
 
 (******************************* Breakpoints ***************************)
 
+open Primitives
 open Checkpoints
 open Debugcom
 open Instruct
@@ -211,5 +212,4 @@ let exec_with_temporary_breakpoint pc funct =
         Exec.protect remove
       with
         x ->
-          Exec.protect remove;
-          raise x
+          cleanup x Exec.protect remove

debugger/command_line.ml

@@ -576,11 +576,11 @@ let instr_source ppf lexbuf =
         user_channel := old_channel
       with
       | x ->
-          stop_user_input ();
-          close_io io_chan;
-          interactif := old_state;
-          user_channel := old_channel;
-          raise x
+          cleanup x (fun () ->
+            stop_user_input ();
+            close_io io_chan;
+            interactif := old_state;
+            user_channel := old_channel) ()
 
 let instr_set =
   find_variable

debugger/input_handling.ml

@@ -52,8 +52,7 @@ let execute_with_other_controller controller file funct =
         result
     with
       x ->
-        change_controller file old_controller;
-        raise x
+        cleanup x (change_controller file) old_controller
 
 (*** The "Main Loop" ***)
 
@@ -84,8 +83,7 @@ let main_loop () =
       continue_main_loop := old_state
     with
       x ->
-        continue_main_loop := old_state;
-        raise x
+        cleanup x ((:=) continue_main_loop) old_state
 
 (*** Managing user inputs ***)
 

debugger/main.ml

@@ -104,8 +104,7 @@ let rec protect ppf restart loop =
             restart ppf
           end)
   | x ->
-      kill_program ();
-      raise x
+      cleanup x kill_program
 
 let execute_file_if_any () =
   let buffer = Buffer.create 128 in

debugger/primitives.ml

@@ -19,6 +19,11 @@
 (*** Miscellaneous ***)
 exception Out_of_range
 
+let cleanup e f =
+  let bt = Printexc.get_raw_backtrace () in
+  let () = f () in
+  Printexc.raise_with_backtrace e bt
+
 let nothing _ = ()
 
 (*** Operations on lists. ***)

debugger/primitives.mli

@@ -22,6 +22,10 @@ val nothing : 'a -> unit
 (*** Types and exceptions. ***)
 exception Out_of_range
 
+(* [cleanup e f x] runs evaluates [f x] and reraises [e] with its original
+   backtrace. If [f x] raises, then [e] is not raised. *)
+val cleanup : exn -> (unit -> unit) -> 'a
+
 (*** Operations on lists. ***)
 
 (* Remove an element from a list *)

debugger/program_management.ml

@@ -77,7 +77,7 @@ let open_connection address continue =
            connection := io_channel_of_descr sock;
            Input_handling.add_file !connection (accept_connection continue);
            connection_opened := true
-         with x -> close sock; raise x)
+         with x -> cleanup x @@ fun () -> close sock)
   with
     Failure _ -> raise Toplevel
   | (Unix_error _) as err -> report_error err; raise Toplevel
@@ -157,6 +157,5 @@ let ensure_loaded () =
       prerr_endline "done."
     with
       x ->
-        kill_program();
-        raise x
+        cleanup x kill_program
   end

debugger/question.ml

@@ -44,8 +44,8 @@ let yes_or_no message =
           answer
       with
         x ->
-          current_prompt := old_prompt;
-          stop_user_input ();
-          raise x
+          cleanup x (fun () ->
+            current_prompt := old_prompt;
+            stop_user_input ()) ()
   else
     false

debugger/trap_barrier.ml

@@ -16,6 +16,7 @@
 
 (************************** Trap barrier *******************************)
 
+open Primitives
 open Debugcom
 open Checkpoints
 
@@ -44,5 +45,4 @@ let exec_with_trap_barrier trap_barrier funct =
     remove_trap_barrier ()
   with
     x ->
-      remove_trap_barrier ();
-      raise x
+      cleanup x remove_trap_barrier ()