From de0aff8816ae7fc3b4fb7ee83c7b7da2f14eb4a4 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Tue, 14 Jul 2026 21:08:50 +1000 Subject: [PATCH 1/2] Fix empty Globals scope on OCaml >= 5.2 Since 5.2 the SYMB section of a bytecode executable numbers globals by Symtable.Global.t (compilation units and predefined exceptions) rather than by Ident.t. Marshal is untyped, so reading the table as an int Ident.Map.t kept working silently, the names still decode, but every key looks like a local ident rather than a persistent one, so the is_structure_module filter in Value_scope rejected all of them and the Globals scope came out empty. Eval.value_path could no longer resolve globals either. Read the table with the compiler's own key type on 5.2 and later, and map compunits back to persistent idents and predefs to predef idents, which is what the table held before 5.2. A future change to the representation is now a compile error rather than a silently empty scope. --- CHANGELOG.md | 8 ++++ src/debugger/core/symbols/bytecode.ml | 63 +++++++++++++++++++-------- src/debugger/dune | 2 +- 3 files changed, 54 insertions(+), 19 deletions(-) diff --git a/CHANGELOG.md b/CHANGELOG.md index 6f94fe0..cea4c05 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -1,3 +1,11 @@ +## Unreleased + +### Fixed + +* 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. + ## 1.3.6 - 2026-04-25 ### Added diff --git a/src/debugger/core/symbols/bytecode.ml b/src/debugger/core/symbols/bytecode.ml index 4350afa..f1112ba 100644 --- a/src/debugger/core/symbols/bytecode.ml +++ b/src/debugger/core/symbols/bytecode.ml @@ -3,6 +3,51 @@ open Instruct type debug_info = (Instruct.debug_event list * string list) list +let seek_section (pos, section_table) name = + let rec seek_sec pos = function + | [] -> raise Not_found + | (name', len) :: rest -> + let pos = Int64.sub pos (Int64.of_int len) in + if name' = name then (pos, len) else seek_sec pos rest + in + seek_sec pos section_table + +[%%if ocaml_version >= (5, 2, 0)] + +(* Since 5.2, globals are numbered by [Symtable.Global.t] (compilation units and + predefined exceptions) rather than by [Ident.t]. *) +let read_global_table ic toc = + let pos, _ = seek_section toc "SYMB" in + Lwt_io.set_position ic pos;%lwt + let module T = struct + type t = { cnt : int; tbl : int Symtable.Global.Map.t } + end in + let%lwt (global_table : T.t) = Lwt_io.read_value ic in + let ident_of_global global = + let name = Symtable.Global.name global in + match global with + | Symtable.Global.Glob_compunit _ -> Ident.create_persistent name + | Symtable.Global.Glob_predef _ -> Ident.create_predef name + in + Lwt.return + (global_table.tbl + |> Symtable.Global.Map.to_seq + |> Seq.map (fun (global, pos) -> (ident_of_global global, pos)) + |> Ident.Map.of_seq) + +[%%else] + +let read_global_table ic toc = + let pos, _ = seek_section toc "SYMB" in + Lwt_io.set_position ic pos;%lwt + let module T = struct + type t = { cnt : int; tbl : int Ident.Map.t } + end in + let%lwt (global_table : T.t) = Lwt_io.read_value ic in + Lwt.return global_table.tbl + +[%%endif] + let load_debuginfo file = let read_toc ic = let%lwt len = Lwt_io.length ic in @@ -25,24 +70,6 @@ let load_debuginfo file = done;%lwt Lwt.return (pos_toc, !section_table) in - let seek_section (pos, section_table) name = - let rec seek_sec pos = function - | [] -> raise Not_found - | (name', len) :: rest -> - let pos = Int64.sub pos (Int64.of_int len) in - if name' = name then (pos, len) else seek_sec pos rest - in - seek_sec pos section_table - in - let read_global_table ic toc = - let pos, _ = seek_section toc "SYMB" in - Lwt_io.set_position ic pos;%lwt - let module T = struct - type t = { cnt : int; tbl : int Ident.Map.t } - end in - let%lwt (global_table : T.t) = Lwt_io.read_value ic in - Lwt.return global_table.tbl - in let relocate_event orig ev = ev.Instruct.ev_pos <- orig + ev.Instruct.ev_pos; match ev.ev_repr with Event_parent repr -> repr := ev.ev_pos | _ -> () diff --git a/src/debugger/dune b/src/debugger/dune index 764efa2..4cc995e 100644 --- a/src/debugger/dune +++ b/src/debugger/dune @@ -4,4 +4,4 @@ (name debugger) (preprocess (pps lwt_ppx ppx_deriving.show ppx_deriving.make ppx_optcomp)) - (libraries ground ocaml-compiler-libs.common typenv trivia_check lwt lwt.unix lwt_react path_glob str iter)) + (libraries ground ocaml-compiler-libs.common ocaml-compiler-libs.bytecomp typenv trivia_check lwt lwt.unix lwt_react path_glob str iter)) From adc14b27573ffce5747f2a5c7227f843e4ce4770 Mon Sep 17 00:00:00 2001 From: Tim McGilchrist Date: Tue, 14 Jul 2026 21:10:25 +1000 Subject: [PATCH 2/2] Add integration tests for the debug adapter The tests spawn the real adapter, launch a bytecode program over the debug adapter protocol, stop at a breakpoint and diff a transcript of what they find against a recorded file. test_scopes covers the Globals scope regression from #74. test_frames stops inside a function and walks the call stack. --- .github/workflows/ci.yml | 3 + CHANGELOG.md | 4 + test/dap_client.ml | 182 ++++++++++++++++++++++++++++++++++++++ test/dune | 58 ++++++++++++ test/fixtures/dune | 10 +++ test/fixtures/hello.ml | 13 +++ test/test_frames.expected | 6 ++ test/test_frames.ml | 34 +++++++ test/test_scopes.expected | 9 ++ test/test_scopes.ml | 43 +++++++++ 10 files changed, 362 insertions(+) create mode 100644 test/dap_client.ml create mode 100644 test/dune create mode 100644 test/fixtures/dune create mode 100644 test/fixtures/hello.ml create mode 100644 test/test_frames.expected create mode 100644 test/test_frames.ml create mode 100644 test/test_scopes.expected create mode 100644 test/test_scopes.ml diff --git a/.github/workflows/ci.yml b/.github/workflows/ci.yml index cf6e811..a8ad6b5 100644 --- a/.github/workflows/ci.yml +++ b/.github/workflows/ci.yml @@ -49,3 +49,6 @@ jobs: - name: Build run: opam exec -- dune build + + - name: Test + run: opam exec -- dune runtest diff --git a/CHANGELOG.md b/CHANGELOG.md index cea4c05..29b27a6 100644 --- a/CHANGELOG.md +++ b/CHANGELOG.md @@ -6,6 +6,10 @@ `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. +### Added + +* Add integration tests driving the adapter over the debug adapter protocol. + ## 1.3.6 - 2026-04-25 ### Added diff --git a/test/dap_client.ml b/test/dap_client.ml new file mode 100644 index 0000000..808b881 --- /dev/null +++ b/test/dap_client.ml @@ -0,0 +1,182 @@ +(* A minimal DAP client, used by the integration tests to drive ocamlearlybird + the way an editor would: spawn the adapter, launch a bytecode program, stop + at a breakpoint and inspect the frames. + + It talks to the adapter over the protocol rather than linking against its + internals. + + The tests print a transcript on stdout which dune diffs against the recorded + .expected file, so anything printed by a test must be stable across the OCaml + versions we support (4.12 .. 5.x) and across platforms. *) + +open Debug_protocol + +(* ocamlearlybird extends the standard launch arguments; [program] is the + bytecode executable to debug. See src/adapter/debug_protocol_ex.ml. *) +module Launch_command = struct + let type_ = Launch_command.type_ + + module Arguments = struct + type t = { + name : string; + program : string; + stop_on_entry : bool; [@key "stopOnEntry"] + console : string; + } + [@@deriving yojson { strict = false }] + end + + module Result = Launch_command.Result +end + +type t = { + rpc : Debug_rpc.t; + proc : Lwt_process.process; + stopped : Stopped_event.Payload.t Lwt_stream.t; +} + +(* Fail rather than hang a CI run forever. *) +let timeout = 60.0 + +let with_timeout what f = + Lwt.pick + [ + f (); + (Lwt_unix.sleep timeout;%lwt + Lwt.fail_with + (Printf.sprintf "timed out after %.0fs waiting for %s" timeout what)); + ] + +(* [launch] must not wait for the launch response before setting breakpoints: + the adapter announces it is ready with an initialized event, expects the + breakpoints and a configurationDone in between, and only then replies. *) +let launch ~adapter ~program ~source ~breakpoints = + let proc = Lwt_process.open_process (adapter, [| adapter; "debug" |]) in + let rpc = Debug_rpc.create ~in_:proc#stdout ~out:proc#stdin () in + let stopped = + Debug_rpc.event rpc (module Stopped_event) |> Lwt_react.E.to_stream + in + let initialized = + Debug_rpc.event rpc (module Initialized_event) |> Lwt_react.E.to_stream + in + Lwt.async (fun () -> Debug_rpc.start rpc); + let%lwt _ = + Debug_rpc.exec_command rpc + (module Initialize_command) + Initialize_command.Arguments.( + make ~adapter_id:"ocaml" ~lines_start_at1:(Some true) + ~columns_start_at1:(Some true) ()) + in + let launched = + Debug_rpc.exec_command rpc + (module Launch_command) + Launch_command.Arguments. + { + name = "integration test"; + program; + stop_on_entry = false; + console = "internalConsole"; + } + in + with_timeout "initialized event" (fun () -> Lwt_stream.next initialized);%lwt + let%lwt _ = + Debug_rpc.exec_command rpc + (module Set_breakpoints_command) + Set_breakpoints_command.Arguments.( + make + ~source:Source.(make ~path:(Some source) ()) + ~breakpoints: + (Some + (breakpoints |> List.map (fun line -> Source_breakpoint.(make ~line ())))) + ()) + in + let%lwt _ = + Debug_rpc.exec_command rpc + (module Configuration_done_command) + () + in + let%lwt () = with_timeout "launch response" (fun () -> launched) in + Lwt.return { rpc; proc; stopped } + +let wait_stopped t = + with_timeout "stopped event" (fun () -> Lwt_stream.next t.stopped) + +let stack_trace t ~thread_id = + let%lwt res = + Debug_rpc.exec_command t.rpc + (module Stack_trace_command) + Stack_trace_command.Arguments.(make ~thread_id ()) + in + Lwt.return res.Stack_trace_command.Result.stack_frames + +let top_frame t ~thread_id = + match%lwt stack_trace t ~thread_id with + | [] -> Lwt.fail_with "no stack frames" + | frame :: _ -> Lwt.return frame + +(* The scopes of [frame], each with its variables, in the order the adapter + reports them. + + The pseudo-variables the adapter synthesises (%accu, the bytecode + accumulator) are dropped. Whether they show up depends on the kind of debug + event the breakpoint landed on. *) +let scopes t ~(frame : Stack_frame.t) = + let%lwt res = + Debug_rpc.exec_command t.rpc + (module Scopes_command) + Scopes_command.Arguments.(make ~frame_id:frame.id) + in + res.Scopes_command.Result.scopes + |> Lwt_list.map_s (fun (scope : Scope.t) -> + let%lwt res = + Debug_rpc.exec_command t.rpc + (module Variables_command) + Variables_command.Arguments.( + make ~variables_reference:scope.variables_reference ()) + in + let variables = + res.Variables_command.Result.variables + |> List.filter (fun (variable : Variable.t) -> + not (String.length variable.name > 0 && variable.name.[0] = '%')) + in + Lwt.return (scope.name, variables)) + +let string_of_reason (reason : Stopped_event.Payload.Reason.t) = + match reason with + | Breakpoint -> "breakpoint" + | Entry -> "entry" + | Step -> "step" + | Exception -> "exception" + | Pause -> "pause" + | _ -> "other" + +let disconnect t = + (try%lwt + Debug_rpc.exec_command t.rpc + (module Disconnect_command) + Disconnect_command.Arguments.(make ~terminate_debuggee:(Some true) ()) + with _ -> Lwt.return ());%lwt + t.proc#terminate; + Lwt.return () + +(* Run [f] against a freshly launched adapter, tearing it down afterwards. *) +let with_session ~program ~source ~breakpoints f = + let adapter = + match Sys.getenv_opt "EARLYBIRD_ADAPTER" with + | Some adapter -> adapter + | None -> failwith "EARLYBIRD_ADAPTER is not set" + in + (* The adapter resolves the debuggee's sources relative to its own working + directory, using the search dirs recorded in the bytecode; so it is run + from the directory the fixture was compiled in, and everything handed to it + has to be an absolute path. *) + let absolute path = + if Filename.is_relative path then Filename.concat (Sys.getcwd ()) path + else path + in + let adapter = absolute adapter in + let program = absolute program in + let source = absolute source in + Sys.chdir (Filename.dirname program); + let%lwt t = launch ~adapter ~program ~source ~breakpoints in + (f t) [%finally disconnect t] diff --git a/test/dune b/test/dune new file mode 100644 index 0000000..16430da --- /dev/null +++ b/test/dune @@ -0,0 +1,58 @@ +; 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. + +(library + (name dap_client) + (modules dap_client) + (preprocess + (pps lwt_ppx ppx_deriving_yojson)) + (libraries dap.types dap.rpc_lwt lwt lwt.unix lwt_react)) + +(executables + (names test_scopes test_frames) + (modules test_scopes test_frames) + (preprocess + (pps lwt_ppx)) + (libraries dap.types dap_client lwt lwt.unix)) + +(rule + (targets test_scopes.actual) + (deps + (:driver test_scopes.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_scopes.expected test_scopes.actual))) + +(rule + (targets test_frames.actual) + (deps + (:driver test_frames.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_frames.expected test_frames.actual))) diff --git a/test/fixtures/dune b/test/fixtures/dune new file mode 100644 index 0000000..9b2595d --- /dev/null +++ b/test/fixtures/dune @@ -0,0 +1,10 @@ +; The debuggee used by the integration tests. It is compiled with ocamlc +; directly rather than with an (executable) stanza so that the debug information +; records this directory as a search dir, which is what lets the adapter resolve +; hello.ml back from the bytecode. + +(rule + (targets hello.bc) + (deps hello.ml) + (action + (run %{bin:ocamlc} -g hello.ml -o hello.bc))) diff --git a/test/fixtures/hello.ml b/test/fixtures/hello.ml new file mode 100644 index 0000000..50f9bce --- /dev/null +++ b/test/fixtures/hello.ml @@ -0,0 +1,13 @@ +(* Fixture program debugged by the integration tests. Keep the line numbers + stable as the tests set breakpoints by line. *) + +let greet name = + let greeting = "Hello, " ^ name in + greeting + +let () = + let x = 41 in + let y = x + 1 in + let msg = greet "world" in + print_endline msg; + print_endline (string_of_int y) diff --git a/test/test_frames.expected b/test/test_frames.expected new file mode 100644 index 0000000..8d96f40 --- /dev/null +++ b/test/test_frames.expected @@ -0,0 +1,6 @@ +frame Hello.greet at line 5 + Stack: name = "world" + Heap: +frame Hello at line 11 + Stack: greet = «fun», x = 41, y = 42 + Heap: diff --git a/test/test_frames.ml b/test/test_frames.ml new file mode 100644 index 0000000..2e05fd9 --- /dev/null +++ b/test/test_frames.ml @@ -0,0 +1,34 @@ +(* Stop inside a function and walk the call stack: this covers the frames the + adapter reports and the variables it finds in each of them. *) + +open Debug_protocol + +let main () = + Dap_client.with_session ~program:"fixtures/hello.bc" + ~source:"fixtures/hello.ml" ~breakpoints:[ 5 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt frames = Dap_client.stack_trace t ~thread_id in + frames + |> Lwt_list.iter_s (fun (frame : Stack_frame.t) -> + Printf.printf "frame %s at line %d\n" frame.name frame.line; + let%lwt scopes = Dap_client.scopes t ~frame in + scopes + |> List.iter (fun (name, variables) -> + (* The Global scope is the same in every frame and has its + own test. *) + if name <> "Global" then + let variables = + variables + |> List.map (fun (variable : Variable.t) -> + Printf.sprintf "%s = %s" variable.name + variable.value) + in + match variables with + | [] -> Printf.printf " %s: \n" name + | variables -> + Printf.printf " %s: %s\n" name + (String.concat ", " variables)); + Lwt.return ())) + +let () = Lwt_main.run (main ()) diff --git a/test/test_scopes.expected b/test/test_scopes.expected new file mode 100644 index 0000000..ae4401d --- /dev/null +++ b/test/test_scopes.expected @@ -0,0 +1,9 @@ +stopped: reason=breakpoint at Hello:12 +scope Stack: + greet = «fun» + x = 41 + y = 42 + msg = "Hello, world" +scope Heap: +scope Global: + includes Stdlib: true diff --git a/test/test_scopes.ml b/test/test_scopes.ml new file mode 100644 index 0000000..881894f --- /dev/null +++ b/test/test_scopes.ml @@ -0,0 +1,43 @@ +(* Stop at a breakpoint and print what each scope of the frame contains. + + The Global scope is the regression test for + https://github.com/hackwaly/ocamlearlybird/issues/74: since OCaml 5.2 the + SYMB section of a bytecode executable numbers globals by Symtable.Global.t + rather than by Ident.t, and reading it with the old key type left the scope + empty. *) + +open Debug_protocol + +let print_scope variables = + variables + |> List.iter (fun (variable : Variable.t) -> + Printf.printf " %s = %s\n" variable.name variable.value) + +(* Which modules a program links in, and so what the Global scope lists, is up + to the compiler; only the standard library is asserted on here. The point is + that the scope is populated at all. *) +let print_global_scope variables = + let names = + variables |> List.map (fun (variable : Variable.t) -> variable.name) + in + Printf.printf " includes Stdlib: %b\n" (List.mem "Stdlib" names) + +let main () = + Dap_client.with_session ~program:"fixtures/hello.bc" + ~source:"fixtures/hello.ml" ~breakpoints:[ 12 ] (fun t -> + let%lwt stopped = Dap_client.wait_stopped t in + let thread_id = Option.value stopped.thread_id ~default:0 in + let%lwt frame = Dap_client.top_frame t ~thread_id in + Printf.printf "stopped: reason=%s at %s:%d\n" + (Dap_client.string_of_reason stopped.reason) + frame.name frame.line; + let%lwt scopes = Dap_client.scopes t ~frame in + scopes + |> List.iter (fun (name, variables) -> + Printf.printf "scope %s:\n" name; + match name with + | "Global" -> print_global_scope variables + | _ -> print_scope variables); + Lwt.return ()) + +let () = Lwt_main.run (main ())