Report a clear error when program is a native executable or other non-bytecode file

CHANGELOG.md

@@ -5,6 +5,16 @@
 * Fix the empty "Globals" scope on OCaml >= 5.2 (#74). Globals are numbered by
   `Symtable.Global.t` rather than by `Ident.t` since 5.2, and reading the SYMB
   section with the old key type left the scope empty.
+* Fix a crash when inspecting an array or other indexed value with a `variables`
+  request that omits the `filter` field. The spec says an omitted filter returns
+  both named and indexed children, however the adapter asserted there were no
+  indexed children and raised instead of returning them. Editors that page
+  variables send the filter and are unaffected (VS Code, and emacs dap-mode),
+  but nvim-dap has no variable paging and sends only `variablesReference`, so
+  expanding an array in nvim-dap crashed the adapter.
+* Report a clear error when `program` is a native executable or other
+  non-bytecode file (#33). Loading such a file failed with `Bad magic`; it now
+  explains that earlybird debugs bytecode and to point `program` at a `.bc`.
 
 ### Added
 

src/adapter/inspect.ml

@@ -109,25 +109,28 @@ let run ~init_args ~launch_args ~dbg rpc =
       let%lwt variables =
         match Hashtbl.find_opt value_tbl arg.variables_reference with
         | None -> Lwt.return []
-        | Some value -> (
+        | Some value ->
+            let indexed ?(start = 0) ?count () =
+              let end_ =
+                (match count with
+                | Some count -> start + count
+                | None -> value#num_indexed)
+                - 1
+              in
+              Seq.int_range ~start ~end_ ()
+              |> List.of_seq
+              |> Lwt_list.map_s (fun i ->
+                     let%lwt obj = value#get_indexed i in
+                     Lwt.return (string_of_int i, obj))
+            in
+            (* An omitted filter means fetch both named and indexed children. *)
             match arg.filter with
             | None ->
-                assert (value#num_indexed = 0);
-                value#list_named
+                let%lwt named = value#list_named in
+                let%lwt indexed = indexed () in
+                Lwt.return (named @ indexed)
             | Some Named -> value#list_named
-            | Some Indexed ->
-                let start = arg.start |> Option.value ~default:0 in
-                let end_ =
-                  (match arg.count with
-                  | Some count -> start + count
-                  | None -> value#num_indexed)
-                  - 1
-                in
-                Seq.int_range ~start ~end_ ()
-                |> List.of_seq
-                |> Lwt_list.map_s (fun i ->
-                       let%lwt obj = value#get_indexed i in
-                       Lwt.return (string_of_int i, obj)))
+            | Some Indexed -> indexed ?start:arg.start ?count:arg.count ()
       in
       let variables =
         variables

src/debugger/core/symbols/bytecode.ml

@@ -3,6 +3,15 @@ open Instruct
 
 type debug_info = (Instruct.debug_event list * string list) list
 
+(* Raised when [load_debuginfo] is pointed at a file that is not an OCaml
+   bytecode executable (most often a native executable). *)
+exception Not_ocaml_bytecode of string
+
+let () =
+  Printexc.register_printer (function
+    | Not_ocaml_bytecode message -> Some message
+    | _ -> None)
+
 let seek_section (pos, section_table) name =
   let rec seek_sec pos = function
     | [] -> raise Not_found
@@ -58,7 +67,14 @@ let load_debuginfo file =
       Lwt_io.read_string_exactly ic (String.length Config.exec_magic_number)
     in
     if%lwt Lwt.return (magic <> Config.exec_magic_number) then
-      Lwt.fail_invalid_arg "Bad magic";%lwt
+      Lwt.fail
+        (Not_ocaml_bytecode
+           (Printf.sprintf
+              "%s is not an OCaml bytecode executable. earlybird debugs \
+               bytecode programs, not native executables. Compile with \
+               `ocamlc -g` or a dune `(modes byte)` target and set \"program\" \
+               to the resulting .bc file."
+              file));%lwt
     let pos_toc = Int64.sub pos_trailer (Int64.of_int (8 * num_sections)) in
     Lwt_io.set_position ic pos_toc;%lwt
     let section_table = ref [] in

src/debugger/debugger.ml

@@ -5,6 +5,14 @@ open Frame
 module PcSet_ = Set.Make (Ordered_type.Make_tuple2 (Int) (Int))
 module IntMap_ = Map.Make (Int)
 
+(* The symbol table, re-exported so that it can be exercised on its own. Mapping
+   a source line to a debug event is subtle enough to be worth testing directly,
+   without a debuggee in the way. *)
+module Bytecode = Bytecode
+module Code_fragment = Code_fragment
+module Code_module = Code_module
+module Symbols = Symbols
+
 type pc = int * int
 
 type 'a source_location = 'a Debug_types.source_location = {

test/dap_client.ml

@@ -141,6 +141,94 @@ let scopes t ~(frame : Stack_frame.t) =
          in
          Lwt.return (scope.name, variables))
 
+let scope t ~frame ~name =
+  let%lwt scopes = scopes t ~frame in
+  match List.assoc_opt name scopes with
+  | Some variables -> Lwt.return variables
+  | None -> Lwt.fail_with (Printf.sprintf "no %s scope" name)
+
+(* One level of children of a structured value (the elements of a list, the
+   fields of a record, ...).
+
+   Values expose named children (record fields, closure captures) and indexed
+   children (array and list elements) separately, and the adapter expects them
+   to be fetched separately, with a filter, the way VS Code does when a value
+   reports both counts. *)
+let expand t ~(variable : Variable.t) =
+  let open Variables_command.Arguments in
+  let reference = variable.variables_reference in
+  let vars args =
+    let%lwt res = Debug_rpc.exec_command t.rpc (module Variables_command) args in
+    Lwt.return res.Variables_command.Result.variables
+  in
+  let named = Option.value variable.named_variables ~default:0 in
+  let indexed = Option.value variable.indexed_variables ~default:0 in
+  if reference = 0 then Lwt.return []
+  else if named = 0 && indexed = 0 then
+    (* Counts unknown; a single unfiltered request returns everything. *)
+    vars (make ~variables_reference:reference ())
+  else
+    let%lwt named =
+      if named > 0 then
+        vars (make ~variables_reference:reference ~filter:(Some Filter.Named) ())
+      else Lwt.return []
+    in
+    let%lwt indexed =
+      if indexed > 0 then
+        vars
+          (make ~variables_reference:reference ~filter:(Some Filter.Indexed)
+             ~start:(Some 0) ~count:(Some indexed) ())
+      else Lwt.return []
+    in
+    Lwt.return (named @ indexed)
+
+(* Children of a value fetched in a single request with no filter. The DAP spec
+   says an omitted filter returns both named and indexed children. *)
+let children_unfiltered t ~(variable : Variable.t) =
+  if variable.variables_reference = 0 then Lwt.return []
+  else
+    let%lwt res =
+      Debug_rpc.exec_command t.rpc
+        (module Variables_command)
+        Variables_command.Arguments.(
+          make ~variables_reference:variable.variables_reference ())
+    in
+    Lwt.return res.Variables_command.Result.variables
+
+(* Stepping. Each returns the frame the debuggee comes to rest in. *)
+
+let step t ~thread_id command =
+  let%lwt () = command () in
+  let%lwt _ = wait_stopped t in
+  top_frame t ~thread_id
+
+let next t ~thread_id =
+  step t ~thread_id (fun () ->
+      Debug_rpc.exec_command t.rpc
+        (module Next_command)
+        Next_command.Arguments.(make ~thread_id ()))
+
+let step_in t ~thread_id =
+  step t ~thread_id (fun () ->
+      Debug_rpc.exec_command t.rpc
+        (module Step_in_command)
+        Step_in_command.Arguments.(make ~thread_id ()))
+
+let step_out t ~thread_id =
+  step t ~thread_id (fun () ->
+      Debug_rpc.exec_command t.rpc
+        (module Step_out_command)
+        Step_out_command.Arguments.(make ~thread_id ()))
+
+let continue t ~thread_id =
+  step t ~thread_id (fun () ->
+      let%lwt _ =
+        Debug_rpc.exec_command t.rpc
+          (module Continue_command)
+          Continue_command.Arguments.(make ~thread_id ())
+      in
+      Lwt.return ())
+
 let string_of_reason (reason : Stopped_event.Payload.Reason.t) =
   match reason with
   | Breakpoint -> "breakpoint"

test/dune

@@ -1,7 +1,12 @@
-; Integration tests. Each test runs the real debug adapter against the bytecode
-; program in fixtures/, drives it over the debug adapter protocol just like an
-; editor would, and diffs the transcript it prints against a recorded .expected
-; file. Adding a test means adding a scenario module plus the two rules below.
+; Integration tests. Most run the real debug adapter against a bytecode program
+; in fixtures/, drive it over the debug adapter protocol just like an editor
+; would, and diff the transcript the scenario prints against a recorded
+; .expected file. test_events is different: it links against the debugger
+; library and exercises the symbol table directly.
+;
+; Adding a protocol-driven test means adding a scenario module to the
+; (executables) below and a pair of rules (run -> .actual, then diff) like the
+; ones here.
 
 (library
  (name dap_client)
@@ -11,12 +16,14 @@
  (libraries dap.types dap.rpc_lwt lwt lwt.unix lwt_react))
 
 (executables
- (names test_scopes test_frames)
- (modules test_scopes test_frames)
+ (names test_scopes test_frames test_stepping test_values test_heap test_indexed)
+ (modules test_scopes test_frames test_stepping test_values test_heap test_indexed)
  (preprocess
   (pps lwt_ppx))
  (libraries dap.types dap_client lwt lwt.unix))
 
+; --- protocol-driven scenarios ---------------------------------------------
+
 (rule
  (targets test_scopes.actual)
  (deps
@@ -25,12 +32,8 @@
   fixtures/hello.bc
   fixtures/hello.ml)
  (action
-  (setenv
-   EARLYBIRD_ADAPTER
-   %{adapter}
-   (with-stdout-to
-    %{targets}
-    (run %{driver})))))
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
 
 (rule
  (alias runtest)
@@ -45,14 +48,110 @@
   fixtures/hello.bc
   fixtures/hello.ml)
  (action
-  (setenv
-   EARLYBIRD_ADAPTER
-   %{adapter}
-   (with-stdout-to
-    %{targets}
-    (run %{driver})))))
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
 
 (rule
  (alias runtest)
  (action
   (diff test_frames.expected test_frames.actual)))
+
+(rule
+ (targets test_stepping.actual)
+ (deps
+  (:driver test_stepping.exe)
+  (:adapter %{exe:../src/main/main.exe})
+  fixtures/hello.bc
+  fixtures/hello.ml)
+ (action
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_stepping.expected test_stepping.actual)))
+
+(rule
+ (targets test_values.actual)
+ (deps
+  (:driver test_values.exe)
+  (:adapter %{exe:../src/main/main.exe})
+  fixtures/values.bc
+  fixtures/values.ml)
+ (action
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_values.expected test_values.actual)))
+
+(rule
+ (targets test_heap.actual)
+ (deps
+  (:driver test_heap.exe)
+  (:adapter %{exe:../src/main/main.exe})
+  fixtures/closure.bc
+  fixtures/closure.ml)
+ (action
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_heap.expected test_heap.actual)))
+
+(rule
+ (targets test_indexed.actual)
+ (deps
+  (:driver test_indexed.exe)
+  (:adapter %{exe:../src/main/main.exe})
+  fixtures/values.bc
+  fixtures/values.ml)
+ (action
+  (setenv EARLYBIRD_ADAPTER %{adapter}
+   (with-stdout-to %{targets} (run %{driver})))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_indexed.expected test_indexed.actual)))
+
+; --- symbol table, exercised directly --------------------------------------
+
+(executables
+ (names test_events test_bad_magic)
+ (modules test_events test_bad_magic)
+ (preprocess
+  (pps lwt_ppx))
+ (libraries debugger lwt lwt.unix))
+
+(rule
+ (targets test_events.actual)
+ (deps
+  (:driver test_events.exe)
+  fixtures/hello.bc
+  fixtures/hello.ml)
+ (action
+  (with-stdout-to %{targets} (run %{driver}))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_events.expected test_events.actual)))
+
+(rule
+ (targets test_bad_magic.actual)
+ (deps
+  (:driver test_bad_magic.exe)
+  fixtures/not_bytecode.txt)
+ (action
+  (with-stdout-to %{targets} (run %{driver}))))
+
+(rule
+ (alias runtest)
+ (action
+  (diff test_bad_magic.expected test_bad_magic.actual)))

test/fixtures/closure.ml

@@ -0,0 +1,19 @@
+(* Fixture for the Heap scope test: [bump] captures [count] and [step] from its
+   enclosing scope, so they live in the closure's environment (the Heap scope)
+   rather than on the stack. Keep the line numbers stable as the tests set
+   breakpoints by line. *)
+
+let make_counter start step =
+  let count = ref start in
+  let bump () =
+    let bumped = !count + step in
+    count := bumped;
+    bumped
+  in
+  bump
+
+let () =
+  let bump = make_counter 10 5 in
+  let first = bump () in
+  let second = bump () in
+  print_endline (string_of_int (first + second))