From e2f278c7a4b43ef8e8f171f5a1ddd972312ac8ca Mon Sep 17 00:00:00 2001 From: David Allsopp Date: Sat, 19 Oct 2019 10:38:48 +0100 Subject: Preserve backtraces in debugger Add Primitives.cleanup which allows handlers for unexpected exceptions to cleanup and reraise the exception with its backtrace. --- debugger/breakpoints.ml | 4 ++-- debugger/command_line.ml | 10 +++++----- debugger/input_handling.ml | 6 ++---- debugger/main.ml | 3 +-- debugger/primitives.ml | 5 +++++ debugger/primitives.mli | 4 ++++ debugger/program_management.ml | 5 ++--- debugger/question.ml | 6 +++--- debugger/trap_barrier.ml | 4 ++-- 9 files changed, 26 insertions(+), 21 deletions(-) (limited to 'debugger') 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 () -- cgit v1.2.1