Merge pull request #9057 from dra27/debugging-the-debugger

Aid debugging the debugger

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

@@ -206,10 +206,4 @@ let exec_with_temporary_breakpoint pc funct =
     in
       Exec.protect (function () -> insert_position pc);
       temporary_breakpoint_position := Some pc;
-      try
-        funct ();
-        Exec.protect remove
-      with
-        x ->
-          Exec.protect remove;
-          raise x
+      Fun.protect ~finally:(fun () -> Exec.protect remove) funct

debugger/command_line.ml

@@ -210,7 +210,7 @@ let line_loop ppf line_buffer =
       done
     with
     | Exit ->
-        stop_user_input ()
+        ()
 (*    | Sys_error s ->
         error ("System error: " ^ s) *)
 
@@ -567,20 +567,17 @@ let instr_source ppf lexbuf =
       | Not_found -> error "Source file not found."
       | (Unix_error _) as x  -> Unix_tools.report_error x; raise Toplevel
     in
-      try
-        interactif := false;
-        user_channel := io_chan;
-        line_loop ppf (Lexing.from_function read_user_input);
+      interactif := false;
+      user_channel := io_chan;
+      let loop () =
+        line_loop ppf (Lexing.from_function read_user_input)
+      and finally () =
+        stop_user_input ();
         close_io io_chan;
         interactif := old_state;
         user_channel := old_channel
-      with
-      | x ->
-          stop_user_input ();
-          close_io io_chan;
-          interactif := old_state;
-          user_channel := old_channel;
-          raise x
+      in
+      Fun.protect ~finally loop
 
 let instr_set =
   find_variable

debugger/input_handling.ml

@@ -46,14 +46,8 @@ let current_controller file =
 let execute_with_other_controller controller file funct =
   let old_controller = current_controller file in
     change_controller file controller;
-    try
-      let result = funct () in
-        change_controller file old_controller;
-        result
-    with
-      x ->
-        change_controller file old_controller;
-        raise x
+    let finally () = change_controller file old_controller in
+    Fun.protect ~finally funct
 
 (*** The "Main Loop" ***)
 
@@ -65,8 +59,11 @@ let exit_main_loop _ =
 
 (* Handle active files until `continue_main_loop' is false. *)
 let main_loop () =
-  let old_state = !continue_main_loop in
-    try
+  let finally =
+    let old_state = !continue_main_loop in
+    fun () -> continue_main_loop := old_state
+  in
+    Fun.protect ~finally @@ fun () ->
       continue_main_loop := true;
       while !continue_main_loop do
         try
@@ -80,12 +77,7 @@ let main_loop () =
               input
         with
           Unix_error (EINTR, _, _) -> ()
-      done;
-      continue_main_loop := old_state
-    with
-      x ->
-        continue_main_loop := old_state;
-        raise x
+      done
 
 (*** Managing user inputs ***)
 

debugger/main.ml

@@ -29,7 +29,7 @@ open Primitives
 
 let line_buffer = Lexing.from_function read_user_input
 
-let loop ppf = line_loop ppf line_buffer
+let loop ppf = line_loop ppf line_buffer; stop_user_input ()
 
 let current_duration = ref (-1L)
 
@@ -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
@@ -131,7 +130,8 @@ let execute_file_if_any () =
   let len = Buffer.length buffer in
   if len > 0 then
     let commands = Buffer.sub buffer 0 (pred len) in
-    line_loop Format.std_formatter (Lexing.from_string commands)
+    line_loop Format.std_formatter (Lexing.from_string commands);
+    stop_user_input ()
 
 let toplevel_loop () =
   interactif := false;
@@ -246,4 +246,4 @@ let main () =
       exit 2
 
 let _ =
-  Printexc.catch (Unix.handle_unix_error main) ()
+  Unix.handle_unix_error main ()

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

@@ -20,8 +20,11 @@ module Lexer = Debugger_lexer
 (* Ask user a yes or no question. *)
 let yes_or_no message =
   if !interactif then
-    let old_prompt = !current_prompt in
-      try
+    let finally =
+      let old_prompt = !current_prompt in
+      fun () -> stop_user_input (); current_prompt := old_prompt
+    in
+      Fun.protect ~finally @@ fun () ->
         current_prompt := message ^ " ? (y or n) ";
         let answer =
           let rec ask () =
@@ -29,23 +32,17 @@ let yes_or_no message =
             let line =
               string_trim (Lexer.line (Lexing.from_function read_user_input))
             in
-              stop_user_input ();
               match (if String.length line > 0 then line.[0] else ' ') with
                 'y' -> true
               | 'n' -> false
               | _ ->
+                stop_user_input ();
                 print_string "Please answer y or n.";
                 print_newline ();
                 ask ()
           in
             ask ()
         in
-          current_prompt := old_prompt;
           answer
-      with
-        x ->
-          current_prompt := old_prompt;
-          stop_user_input ();
-          raise x
   else
     false

debugger/trap_barrier.ml

@@ -38,11 +38,5 @@ let update_trap_barrier () =
 (* Execute `funct' with a trap barrier. *)
 (* --- Used by `finish'. *)
 let exec_with_trap_barrier trap_barrier funct =
-  try
-    install_trap_barrier trap_barrier;
-    funct ();
-    remove_trap_barrier ()
-  with
-    x ->
-      remove_trap_barrier ();
-      raise x
+  install_trap_barrier trap_barrier;
+  Fun.protect ~finally:remove_trap_barrier funct