Preserve backtraces in debugger

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

9 files changed, 26 insertions, 21 deletions

diff --git a/debugger/breakpoints.ml b/debugger/breakpoints.ml
index f375528211..049d1c3b62 100644
--- a/debugger/breakpoints.ml
+++ b/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
diff --git a/debugger/command_line.ml b/debugger/command_line.ml
index 8fb554b2bd..381700d382 100644
--- a/debugger/command_line.ml
+++ b/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
diff --git a/debugger/input_handling.ml b/debugger/input_handling.ml
index b043629bd1..e0dd6884ac 100644
--- a/debugger/input_handling.ml
+++ b/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 ***)
 
diff --git a/debugger/main.ml b/debugger/main.ml
index 60bbdd2b77..b37ce86b39 100644
--- a/debugger/main.ml
+++ b/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
diff --git a/debugger/primitives.ml b/debugger/primitives.ml
index 7c1f900fb9..4cf2fb8d07 100644
--- a/debugger/primitives.ml
+++ b/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. ***)
diff --git a/debugger/primitives.mli b/debugger/primitives.mli
index 76526cf96f..8b03d8d2da 100644
--- a/debugger/primitives.mli
+++ b/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 *)
diff --git a/debugger/program_management.ml b/debugger/program_management.ml
index 318e3f2c2e..74cc3db3e2 100644
--- a/debugger/program_management.ml
+++ b/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
diff --git a/debugger/question.ml b/debugger/question.ml
index 69e9ddbde1..0ecd63cb7a 100644
--- a/debugger/question.ml
+++ b/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
diff --git a/debugger/trap_barrier.ml b/debugger/trap_barrier.ml
index 33dfb04f21..8182f7719f 100644
--- a/debugger/trap_barrier.ml
+++ b/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 ()