Output to debug console when uncaught_exc occurs.

Author: hackwaly

CHANGELOG.md

@@ -5,6 +5,7 @@
 * Fix breakpoints resolution algorithm.
 * Fix variables pane sometimes flooding by `Assertion_failure(...)` raised at Env_hack.ml.
 * Fix incorrectly inspect 'a type as int.
+* Output to debug console when uncaught_exc occurs.
 
 ## 1.0.2 - 2021-02-22
 

src/adapter/inspect.ml

@@ -32,7 +32,13 @@ let run ~init_args ~launch_args ~dbg rpc =
       Hashtbl.reset value_tbl;
       match status with
       | Running -> Lwt.return ()
-      | Stopped (Exited | Uncaught_exc) ->
+      | Stopped ((Exited | Uncaught_exc) as reason) ->
+          if reason = Uncaught_exc then
+            Debug_rpc.send_event rpc
+              (module Output_event)
+              Output_event.Payload.(
+                make ~output:"Program exited due to Uncaught_exc" ())
+          else Lwt.return ();%lwt
           Debug_rpc.send_event rpc
             (module Terminated_event)
             Terminated_event.Payload.(make ())
@@ -146,7 +152,8 @@ let run ~init_args ~launch_args ~dbg rpc =
                let num_named = value#num_named in
                let num_indexed = value#num_indexed in
                let is_complex =
-                 num_indexed > 0 || num_named > 0 || num_named = -1 || Option.is_some value#vscode_menu_context
+                 num_indexed > 0 || num_named > 0 || num_named = -1
+                 || Option.is_some value#vscode_menu_context
                in
                let handle = if is_complex then alloc_handle () else 0 in
                Hashtbl.replace value_tbl handle value;
@@ -184,5 +191,6 @@ let run ~init_args ~launch_args ~dbg rpc =
       let open VariableGetClosureCodeLocation in
       match Hashtbl.find_opt value_tbl arg.handle with
       | None -> Lwt.return { Result.location = None }
-      | Some value -> Lwt.return { Result.location = value#closure_code_location });
+      | Some value ->
+          Lwt.return { Result.location = value#closure_code_location });
   Lwt.join [ process_state_changes () ]

src/debugger/core/controller.ml

@@ -56,9 +56,9 @@ let _set_frag_events symbols conn frag =
          |> Seq.map (fun it -> (module_.frag, it.ev_pos)))
   |> Lwt_seq.iter_s (Wire_protocol.set_event conn);%lwt
   Lwt.return
-    ( debug_modules
+    (debug_modules
     |> Seq.map (fun (it : Code_module.t) -> (it.frag, it.module_id))
-    |> FragModuleIdSet_.of_seq )
+    |> FragModuleIdSet_.of_seq)
 
 let root ?debug_filter debug_sock symbols_file =
   let%lwt fd, _ = Lwt_unix.accept debug_sock in
@@ -94,7 +94,7 @@ let fork t debug_sock =
     if pid' = pid then Lwt.return conn
     else (
       Lwt_unix.close fd;%lwt
-      wait_conn () )
+      wait_conn ())
   in
   let%lwt conn = wait_conn () in
   Lwt.return
@@ -133,14 +133,14 @@ let stop ?(gracefully = false) t =
     if gracefully then Wire_protocol.stop t.conn
     else (
       Unix.kill t.pid 9;
-      Lwt.return () );%lwt
+      Lwt.return ());%lwt
     t.dead <- true;
     let () =
       match t.parent with
       | None -> ()
       | Some parent -> Lwt.async (fun () -> Wire_protocol.wait parent.conn)
     in
-    Lwt.return () )
+    Lwt.return ())
 
 let execute ?(yield_steps = Int.max_int)
     ?(on_yield = fun () -> Lwt.return `Continue) ?trap_barrier
@@ -197,33 +197,31 @@ let execute ?(yield_steps = Int.max_int)
           let%lwt r = run () in
           if not (t.breakpoints |> PcSet_.mem pc) then (
             Wire_protocol.reset_instr t.conn pc;%lwt
-            Wire_protocol.set_event t.conn pc )
+            Wire_protocol.set_event t.conn pc)
           else Lwt.return ();%lwt
           Lwt.return r
   in
-  let run =
-    match trap_barrier with
-    | None -> run
-    | Some trap_barrier ->
-        fun () ->
-          Wire_protocol.set_trap_barrier t.conn trap_barrier;%lwt
-          let%lwt summary, remaining_steps, sp_pc = run () in
-          Wire_protocol.set_trap_barrier t.conn 0;%lwt
-          if summary = `Trap_barrier then
-            let stop_on_event () =
-              let%lwt summary', remaining_steps', sp_pc' = exec_dynlink _1 in
-              let remaining_steps =
-                remaining_steps ++ (_1 -- remaining_steps')
-              in
-              match summary' with
-              | `Trap_barrier -> assert false
-              | `Event | `Breakpoint ->
-                  Lwt.return (`Trap_barrier, remaining_steps, sp_pc')
-              | `Exited | `Uncaught_exc | `Yield_stop _ ->
-                  Lwt.return (summary', remaining_steps, sp_pc')
-            in
-            stop_on_event ()
-          else Lwt.return (summary, remaining_steps, sp_pc)
+  let run () =
+    let%lwt () =
+      match trap_barrier with
+      | None -> Lwt.return ()
+      | Some trap_barrier -> Wire_protocol.set_trap_barrier t.conn trap_barrier
+    in
+    let%lwt summary, remaining_steps, sp_pc = run () in
+    Wire_protocol.set_trap_barrier t.conn 0;%lwt
+    if summary = `Trap_barrier then
+      let rec stop_on_event () =
+        let%lwt summary', remaining_steps', sp_pc' = exec_dynlink _1 in
+        let remaining_steps = remaining_steps ++ (_1 -- remaining_steps') in
+        match summary' with
+        | `Trap_barrier -> stop_on_event ()
+        | `Event | `Breakpoint ->
+            Lwt.return (`Trap_barrier, remaining_steps, sp_pc')
+        | `Exited | `Uncaught_exc | `Yield_stop _ ->
+            Lwt.return (summary', remaining_steps, sp_pc')
+      in
+      stop_on_event ()
+    else Lwt.return (summary, remaining_steps, sp_pc)
   in
   let%lwt summary, remaining_steps, sp_pc = run () in
   if summary = `Exited || summary = `Uncaught_exc then stop ~gracefully:true t

src/debugger/debugger.ml

@@ -274,7 +274,9 @@ let _summary_to_reason summary =
   match summary with
   | `Event -> Step
   | `Yield_stop 1 -> Pause
-  | `Yield_stop _ | `Trap_barrier -> raise (Invalid_argument "summary")
+  | `Yield_stop x ->
+      raise (Invalid_argument ("summary is `Yield_stop " ^ string_of_int x))
+  | `Trap_barrier -> raise (Invalid_argument "summary is `Trap_barrier")
   | `Breakpoint -> Breakpoint
   | `Exited -> Exited
   | `Uncaught_exc -> Uncaught_exc