From ae23787c040b846a23355ae1abda0ecb6e71f85d Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 25 Sep 2026 19:57:39 +0700 Subject: [PATCH] The inspector reads a stopped program's memory through the compiled layouts, so locals, inspect, at, condition and globals build no module, and the inspector reads a generic instance's type arguments. --- TODO.org | 13 +- docs/BUILT.md | 52 ++- emacs/flan-inspect.el | 41 ++- emacs/test-flan-cider.el | 18 ++ lib/dev.ml | 574 +++++++++++++++++----------------- lib/inspect.ml | 432 +++++++++++++++++++++++++ lib/render.ml | 12 +- lib/session.ml | 431 ++----------------------- runtime/flan_dev.c | 45 ++- runtime/flan_dyn.c | 5 + test/programs/dev-parity.flan | 109 +++++++ test/test_dev.ml | 100 ++++++ vendor/agent/flan_agent.c | 191 ++++++++++- 13 files changed, 1273 insertions(+), 750 deletions(-) create mode 100644 lib/inspect.ml create mode 100644 test/programs/dev-parity.flan diff --git a/TODO.org b/TODO.org index d2c3d726..2d7e6333 100644 --- a/TODO.org +++ b/TODO.org @@ -1685,10 +1685,15 @@ Settled for conditions and for structs, because =Load= qualifies every declarati at import. Still open for locals, where the debug information gives a bare name and nothing qualifies it. -** NEXT The render-thunk-per-inspection design -Decided 2026-09-25: the inspector reads a value through the type layouts the compiler records, with no compile per inspection, which lets it hold a value. -An inspection still compiles a thunk per request. A redesign rather than a -deletion, and its own lane: it is what unblocks the inspector retaining a value. +** DONE Reading a value compiles nothing +CLOSED: [2026-09-25] +=locals=, =inspect=, =at=, =condition= and =globals= read memory through the agent and walk it in lib/inspect.ml; only writes still build a module. Rules out a render thunk per read, and a reply spelling a value differently from =C-x C-e= (test_dev's parity block). docs/BUILT.md, "Reading a value compiles nothing". + +** TODO The inspector holds a value +Reading needs no module now, so an address and a type are enough to keep a value on the daemon's side between requests, the way CIDER keeps a JVM object. Nothing holds one yet: the Emacs stack is still a stack of expressions. + +** TODO A frame that prints is skipped from the globals section +A frame whose body calls =print= comes back in =:skipped= as "running a body that has been redefined since" though nothing was redefined: its global-reference fingerprint differs between the build and the daemon. test/programs/dev-parity.flan stores each global to itself instead of printing it for this reason. ** DONE The watch table stays pushed CLOSED: [2026-09-25] diff --git a/docs/BUILT.md b/docs/BUILT.md index 3ded16d5..993fff31 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -2057,7 +2057,7 @@ The fixed caps go with it: the snapshot is taken **on the game thread**, so it c What the merge *does* unlock here is one thing and it is the next item: `flan_agent_frame_slot` already hands back the address of a slot, and in one process the compiler could read the value at that address instead of compiling a render thunk to print it. That is the render-thunk-per-inspection redesign — a different mechanism rather than a deletion, and -what makes "the inspector can retain a value" reachable. It is deliberately not done here. +what makes "the inspector can retain a value" reachable. It was done later; see "Reading a value compiles nothing". **So of the three things the merge was expected to make deletable, one was.** The socket was transport and is gone; the result cap and the snapshot are both concurrency, and they were only ever mistaken for transport because the socket was @@ -2614,6 +2614,40 @@ escaping — was built and timed as the obvious alternative and is worse on both calling function's own stack is already hot, and an indexed store into a megabyte of BSS is not. It also has a fixed depth, which a chain of stack records does not. +### Reading a value compiles nothing + +`locals`, `inspect`, `at`, `condition` and `globals` used to each build a render thunk — `Render.render` over the +value's address, compiled, loaded, run on the stopped thread, read back — a third of a second of `llc` per question. +They now read the stopped program's memory from the daemon and walk it in OCaml (`lib/inspect.ml`), through the same +`Emit.lay` offsets both backends lay values out by. The sections below still describe *what* each verb answers; where +they say a thunk renders it, `Inspect` now does. + +**What the program is asked** is six agent verbs, all refused unless stopped: `slot F I`, `cond-at` and `global SYM` +for where a root is; `peek ADDR LEN` for bytes; `ptr ADDR` for the registry's live/dead/unknown and the epitaph +(`flan_dev_reg_epitaph`, which `flan_dev_reg_emit` now writes through, so the sentence has one author); and `dyn WORD`, +because a dyn value's tag is the runtime's to read and `flan_dyn_emit_to` renders it. They go through `Dev.request`, +so the two-process daemon answers them over the socket and the merged one by a call. `peek` reads through +`process_vm_readv` on its own process, so an unmapped address is a refusal and not a fault that takes the program — +and in one process, the daemon — down with it. + +**The text is `Render.render`'s, byte for byte**, because the editor parses it back and because the same value must not +read differently at `C-x C-e` and in the break buffer. That walk still exists — `println` and an evaluated value are +rendered at compile time — so this is two walks over the same arms. What can be shared is: which types are refused is +decided by running `Render.render` over the type ([Inspect.refusal]), and a struct's head is `Render.head`. What +cannot, the arms themselves, is pinned by `test_dev`'s parity block, which asks both renderers about a global of every +shape on both backends. The output cap is now per value (4096, `...` as the runtime writes it) rather than per module; +a locals listing used to share one 4096-byte buffer between every slot and drop the ones past the cut. + +**A path ends at an address.** `Session.step_into` still decides which steps a type admits and how each is refused; +`Inspect.place` works out where the resulting expression lives. Two checks the compiled thunk made in the program are +made there instead: a slice index against the slice's length, and a data case against the value's tag. + +**Held to one stop.** The daemon serves one request at a time, so nothing it is asked can resume the program in the +middle of a read; `Dev.one_stop` compares the stop generation before and after anyway, and refuses on a difference. + +Writes still compile: `set` and a restart's arguments store an expression somebody typed, so they need a module, and +their read-back after the store is the thunk renderer's. + ### Locals of a stopped frame The half the shadow stack was built for. `(:op "locals" :frame N)` answers what a stopped frame's named locals hold. @@ -6147,16 +6181,14 @@ the name quoted and never defaulted to bytes. ### The address root renders a pointer, not a pointee -`(:op "at" :addr N)` — `M-x flan-inspect-address` — builds a `(Ptr T)` at the address and renders **that**. Rendering -the `T` directly would read the storage whatever the registry said, which is the hex dump this project is trying not -to be. Rendering the pointer puts the walk through `render.ml`'s pointer arm, which is the arm that asks first, so an -address root and a slot root reach the same two answers by the same code and permission is asked in exactly one place -in the compiler. +`(:op "at" :addr N)` — `M-x flan-inspect-address` — renders a `(Ptr T)` holding the address, not the `T` at it. +Rendering the `T` directly would read the storage whatever the registry said, which is the hex dump this project is +trying not to be. Rendering the pointer puts the walk through the pointer arm, which is the arm that asks first, so an +address root and a slot root reach the same two answers by the same code. -The one piece the thunk cannot do for itself is the address: **Flan has no integer-to-pointer cast**, deliberately, so -`flan_dev_reg_addr` is an extern beside `flan_agent_frame_slot` and for the same reason — the compiler knows the type -and something outside the language supplies the address. `flan_dev_reg_number` is the other direction, for a *program* -that has to say an address out loud; the language still has no operator for either. +The reader does the same with no thunk: `Inspect.render_ptr` enters the walk at the pointer arm, so the registry is +asked (`ptr ADDR`) before a byte of the pointee is read. `flan_dev_reg_number` is the other direction, for a *program* +that has to say an address out loud; the language still has no operator for it, deliberately. Three refusals, each by name: an address the registry never saw **with no `:type` given** (a stack local, a global, a pointer from C — the first two are answered by name already); an address the block's element size does not divide, diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index 72cc68a4..451fd977 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -31,9 +31,11 @@ ;; That is available to it because a JVM value can be retained: the middleware ;; keeps a reference and the collector leaves it alone. ;; -;; Nothing here can do that. A Flan value has no header, the thunk that -;; rendered it is `dlclose'd the moment it returns, and there is no heap to -;; retain anything in. So the stack is a stack of **expressions**, on this +;; Nothing here does that yet. A Flan value has no header and there is no +;; heap to retain anything in; the daemon reads a stopped program's memory +;; through the layouts it compiled (lib/inspect.ml), which is what would let +;; it hold an address and a type, but it holds nothing between requests +;; today. So the stack is a stack of **expressions**, on this ;; side, and going into a field means sending a *different expression* — ;; `(.pos b)' where the last one was `b'. Two consequences, one good and one ;; that has to be said out loud: @@ -129,6 +131,8 @@ reply without a daemon behind them, and so that this file names ;; ;; (Name {.f V .f V}) a struct, with ` ...' before the `}' if the walk hit ;; its span bound of 8 fields +;; (Name A {.f V}) an instance of a generic struct, its type arguments +;; kept on the head (:text) and the name alone as :type ;; [ V V V] an array or a slice, ` ...' likewise ;; (some V) / none an option ;; a pointer, never followed @@ -202,7 +206,7 @@ reply without a daemon behind them, and so that this file names (let ((j (1+ i))) (let ((start j)) (while (and (< j (length s)) (not (memq (aref s j) '(?\s ?\))))) (setq j (1+ j))) - (let ((head (substring s start j))) + (let* ((head (substring s start j)) (name head)) (cond ;; (some V). There is no accessor form in Flan that reaches an ;; option's payload — the compiler gets at it as field 1 and nothing @@ -215,8 +219,27 @@ reply without a daemon behind them, and so that this file names :children (list (cons "some" (car r)))) (if (and (< k (length s)) (eq (aref s k) ?\))) (1+ k) k)))) (t - ;; `(Name {' then `.field VALUE' pairs, then `})'. - (setq j (flan-inspect--skip-space s j)) + ;; `(Name {' then `.field VALUE' pairs, then `})'. A generic + ;; struct's instance carries its type arguments between the name + ;; and the brace — `(Pair i32 {…})', `(Box (Option u8) {…})' — and + ;; they are read here as balanced text, since they are a type's + ;; spelling and not values. They stay on the head, so that + ;; `flan-inspect--literal' writes back what was read. + (let ((args nil)) + (setq j (flan-inspect--skip-space s j)) + (while (and (< j (length s)) (not (memq (aref s j) '(?\{ ?\))))) + (let ((start j) (depth 0)) + (while (and (< j (length s)) + (or (> depth 0) + (not (memq (aref s j) '(?\s ?\{ ?\)))))) + (pcase (aref s j) + ((or ?\( ?\[) (setq depth (1+ depth))) + ((or ?\) ?\]) (setq depth (1- depth)))) + (setq j (1+ j))) + (push (substring s start j) args)) + (setq j (flan-inspect--skip-space s j))) + (when args + (setq head (mapconcat #'identity (cons head (nreverse args)) " ")))) (when (and (< j (length s)) (eq (aref s j) ?\{)) (setq j (1+ j))) (let ((kids nil) (more nil) (done nil)) (while (not done) @@ -252,7 +275,7 @@ reply without a daemon behind them, and so that this file names (push (cons "?" (car r)) kids)))))) (setq j (flan-inspect--skip-space s j)) (when (and (< j (length s)) (eq (aref s j) ?\))) (setq j (1+ j))) - (cons (list :kind 'struct :text head :type head + (cons (list :kind 'struct :text head :type name :truncated more :children (nreverse kids)) j)))))))) @@ -512,7 +535,7 @@ stated honestly — every Flan integer is rendered through i64." (defun flan-inspect--summary (node) "One line for NODE, as it appears beside its label." (pcase (plist-get node :kind) - ('struct (format "(%s …%s)" (plist-get node :type) + ('struct (format "(%s …%s)" (plist-get node :text) (let ((n (length (plist-get node :children)))) (format " %d field%s" n (if (= n 1) "" "s"))))) ('seq (plist-get node :text)) @@ -536,7 +559,7 @@ value is stored, when the reply said." (if declared (format "%s\n" declared) (pcase (plist-get node :kind) - ('struct (format "a %s\n" (plist-get node :type))) + ('struct (format "a %s\n" (plist-get node :text))) ('seq (format "%s\n" (plist-get node :text))) ('option "an option\n") ('ptr "a pointer — never followed\n") diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index 1cdcaf74..04568f6a 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -74,6 +74,24 @@ (equal (mapcar #'car (plist-get (cdr (assoc "tags" kids)) :children)) '(0 1 2)))) +;; A generic struct's instance, its type arguments between the name and the +;; brace, compound ones included. Written back as it was read. +(let* ((src "(Pair (Option u8) [3 i32] {.a (some 1) .b [ 1 2 3]})") + (n (flan-inspect-parse src))) + (test-flan--check "a generic instance is a struct" + (eq (plist-get n :kind) 'struct)) + (test-flan--check "its type arguments are not read as fields" + (equal (mapcar #'car (plist-get n :children)) '("a" "b"))) + (test-flan--check "its name is the type, its head keeps the arguments" + (and (equal (plist-get n :type) "Pair") + (equal (plist-get n :text) "Pair (Option u8) [3 i32]"))) + (test-flan--check "and it is written back with them" + (equal (flan-inspect-parse (flan-inspect--literal n)) n))) +(test-flan--check "the older spelling of an instance still reads" + (equal (mapcar #'car (plist-get (flan-inspect-parse "(Pair-i32 {.a 1})") + :children)) + '("a"))) + ;; [ 0 42 0] — Types.Slice and Types.Array both write this. (let ((n (flan-inspect-parse "[ 0 42 0]"))) (test-flan--check "a sequence is a sequence" (eq (plist-get n :kind) 'seq)) diff --git a/lib/dev.ml b/lib/dev.ml index 0f4e7e86..3d41df1a 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -2165,72 +2165,35 @@ let backtrace_op t = Printf.sprintf ":more %d" more ] | Error m -> error ("the program refused to say where it is: " ^ m)) -(* Build a render thunk, hand it to the program, and read back what it wrote. +(* Build a thunk that changes something in the stopped program, hand it over, + and read back what it wrote. - The same five steps for every verb that renders something inside the - stopped program — [locals], [globals] and [inspect] — and they are here - once rather than three times because the note this file already carries - about the fingerprint applies to plumbing too: four of five hand-offs - present looks exactly like one hand-off dropping a step, and that is a bug - nobody sees until the one path that lost it is the one being used. + Only writes come here now — [set] storing into a frame, and a restart's + arguments stored before it is taken. Reading a value compiles nothing: see + [Inspect] and the verbs that use it below. A write still needs a module, + because the value being stored is an expression somebody typed. [tag] only names the [.so] on disk, which is what someone reads when they go looking at [t.dir] to find out which verb produced what. - ── [stopped_only], and why only one of the three wants it ──────────── + ── [at_stop] ───────────────────────────────────────────────────────── Everything between the gate and the thunk takes time the gate does not - cover. The verb checks that the program is stopped, the agent checks it - again, and then a module is *built* — a third of a second of llc and a - linker — and delivered, and waited on for up to five seconds. A [restart] - arriving anywhere in there resumes the game thread, and the thunk runs at - the next frame boundary instead of from the break. The wait below does not - even notice: it keeps waiting while liveness is [Live], and a resumed - program is the liveliest thing there is. - - What that costs depends entirely on what the thunk holds. - - [inspect] by *address* holds a number. [Dev.render_addr] bakes the address - into the module as an integer literal, because the registry's blessing — - "something live is there, and it is a [Foo]" — was given at build time by a - table that the running program is exactly the thing that changes. Run that - thunk after a resume and it dereferences an address whose blessing expired, - possibly into storage the program has since freed. So it is delivered - stopped-only, and the agent drops it rather than running it. - - [locals], [inspect] by *slot* and [globals] hold no address at all, and that - is the line. A local is reached through [flan/dev-slot], which is - [flan_agent_frame_slot], which asks [snap_top] for the frame *when the thunk - runs* — and [snap_top] is empty once the break that pushed it has been - resumed past. A global is reached by name: [Emit.redefinition] leaves it - [external], the dynamic linker binds it to the program's own storage, and - that storage has existed since the process started. Neither carries a - permission that can go stale between the asking and the running, because - neither was given one. Tagging them stopped-only would refuse work that is - sound, which is the other way to lose an answer. - - ── [at_stop], the third setting, and the only one a write may use ──── - - A write through [flan/dev-slot] is the case the paragraph above declares - safe and is not. What makes a *read* of a frame slot safe against a resume - is that [snap_top] is then empty and the render produces nothing; what makes - a write unsafe is that a resume followed by a second stop refills it, and - the store lands in the same slot index of a stack the reader never saw. - [stopped_only] is blind to that — the program is stopped, which is all it - asks. So a write names the generation instead, and the agent compares it - against the stop actually in force at the moment it claims the job. - - The wait below is shared: both settings are watched through the same - refusal counter, because the agent drops both the same way and the sentence - it hands back is the one that says which. *) -let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag + cover: a module is *built* — a third of a second of llc and a linker — and + delivered, and waited on for up to five seconds. A [restart] arriving in + there resumes the game thread, and a second stop refills the snapshot, so a + store through [flan/dev-slot] would land in the same slot index of a stack + the reader never saw. So a write names the generation it was built against, + and the agent compares it against the stop actually in force at the moment + it claims the job, and drops it otherwise. *) +let run_render_thunk ?at_stop t ~tag ~(c : Session.change) : (string, string) result = let before = match result t with Some (g, _) -> g | None -> 0L in (* Read *before* the build, not before the wait: the resume this is watching for can land while llc is still running, and the job it kills is this one. [None] when the program cannot say, in which case nothing below compares against it — a missing count is no evidence either way. *) - let watched = stopped_only || at_stop <> None in + let watched = at_stop <> None in let refused_before = if watched then refusals t else None in let resumed () = match (refused_before, if watched then refusals t else None) with @@ -2245,7 +2208,7 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag (match (match at_stop with | Some gen -> deliver_at_stop t ~gen out - | None -> if stopped_only then deliver_stopped_only t out else deliver t out) + | None -> deliver t out) with | exception Unix.Unix_error (e, _, _) -> Error (unreachable t e) @@ -2324,6 +2287,91 @@ let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag wait 5000 | reply -> Error ("the program refused the module: " ^ reply)) +(* ── Reading a stopped program's memory ────────────────────────────── *) + +(* [locals], [inspect], [at], [condition] and [globals] read values here, on + the daemon's side, through [Inspect] — the layouts this session compiled + and the bytes the agent hands back — rather than building a render thunk + for the program to run. See lib/inspect.ml for why that is possible and + what stays shared with the thunk renderer. + + Through [request], so the same verbs answer in one process, where the agent + is a call, and in the two-process daemon, where it is the socket. *) + +let chomp s = + let n = String.length s in + if n > 0 && s.[n - 1] = '\n' then String.sub s 0 (n - 1) else s + +let unhex s = + String.init (String.length s / 2) (fun i -> + Char.chr (int_of_string ("0x" ^ String.sub s (2 * i) 2))) + +let starts s pre = + String.length s >= String.length pre + && String.sub s 0 (String.length pre) = pre + +let after s pre = String.sub s (String.length pre) (String.length s - String.length pre) + +(* One line back from the agent, with a refusal as [Error] and its sentence + kept. *) +let agent_line t line : (string, string) result = + match request t line with + | exception Unix.Unix_error (e, _, _) -> Error (unreachable t e) + | text -> + let l = chomp (List.hd (String.split_on_char '\n' (text ^ "\n"))) in + if starts l "err " then Error (after l "err ") else Ok l + +let agent_mem t : Inspect.mem = + { Inspect.read = + (fun a n -> + match agent_line t (Printf.sprintf "peek %d %d" a n) with + | Ok l when starts l "ok " -> unhex (after l "ok ") + | Ok l | Error l -> + raise + (Inspect.Unreadable + (Printf.sprintf "the %d bytes at 0x%x could not be read (%s)" n a l))); + ptr = + (fun a -> + match agent_line t (Printf.sprintf "ptr %d" a) with + | Ok "live" -> Inspect.Live + (* The epitaph keeps its leading space: it is written straight after + " Inspect.Dead (after l "dead") + | _ -> Inspect.Unknown); + dyn = + (fun w -> + match agent_line t (Printf.sprintf "dyn %Lu" w) with + | Ok l when starts l "ok " -> unhex (after l "ok ") + | Ok l | Error l -> raise (Inspect.Unreadable ("a dyn value: " ^ l))) } + +let reader t = + Inspect.make ~program:t.session.Session.program + ~enums:(Hashtbl.fold (fun k v acc -> (k, v) :: acc) + t.session.Session.env.Check.enums []) + ~mem:(agent_mem t) + +(* "ok ADDR" from one of the agent's root verbs. *) +let agent_addr t line : (int, string) result = + match agent_line t line with + | Error m -> Error m + | Ok l when starts l "ok " -> + (match int_of_string_opt (after l "ok ") with + | Some a -> Ok a + | None -> Error ("the program answered " ^ l)) + | Ok l -> Error ("the program answered " ^ l) + +(* A read that spans several requests, held to one stop. The daemon serves one + request at a time, so nothing it is asked can resume the program mid-read; + this is the check that says so rather than the argument. *) +let one_stop t f = + let before = stop_gen t in + let r = f () in + if stop_gen t = before then r + else + Error + "the program moved on while it was being read, so what was read may \ + mix two stops; ask again" + (* The frame checks, which every verb that reads a *frame* has to make and must make the same way. [inspect] exists precisely because the listing is frame-accurate and the inspector was not, so it sharing this function with @@ -2412,13 +2460,11 @@ let stopped_frame t ~frame ~what : (string * Tast.fn, string) result = the shadow stack was built rather than more DWARF: DWARF would have put these in lldb, and the point is to need lldb less often. - Nothing is copied out of the program. A Flan value has no header, so bytes - read from another process would be bytes with no meaning; what this end has - is the *type* — [Tast.fn.slots], from the build it owns — and the name - beside it in [snames]. So it compiles a thunk that renders those types at - those addresses, in the program, on the stopped thread, and reads the text - back the way [C-x C-e] does. The only thing that comes from the running - program is where the frame is. + A Flan value has no header, so bytes read out of the program mean nothing + on their own; what this end has is the *type* — [Tast.fn.slots], from the + build it owns — and the name beside it in [snames]. So it asks the agent + where each slot is and reads the value there through [Inspect], which walks + the bytes by the layouts this session compiled. Nothing is built. Three refusals, each by name and with its reason rather than by omission: a slot the compiler invented and nobody named; a slot whose binding had not @@ -2451,27 +2497,46 @@ let locals t ~frame = (match bound_slots t ~frame with | Error m -> error ("the program refused to say which slots are bound: " ^ m) | Ok bound -> - let c, refused = Session.render_locals t.session ~frame ~fn ~bound in - (match run_render_thunk t ~tag:"l" ~c with + let c = reader t in + let names = Session.shown_names fn in + (* Each entry is name, type, value and slot index. The index is last + and it is what [i] in the break buffer hands back to [inspect]: + two slots can share a name, so the name is not an identifier and + the position in this list is not one either, since a refused slot + is not in it. A slot the compiler made up is hidden, not refused; + see [Session.shown_names]. *) + let read () = + let entries = ref [] and refused = ref [] in + Array.iteri + (fun i ty -> + match names.(i) with + | None -> () + | Some n when not (List.mem i bound) -> + refused := (n, "not bound yet where the program stopped") :: !refused + | Some n -> + let v = + match agent_addr t (Printf.sprintf "slot %d %d" frame i) with + | Error m -> Error m + | Ok addr -> Inspect.render c ~addr ty + in + (match v with + | Ok v -> + entries := + Wire.list + [ Wire.quote n; Wire.quote (Types.to_string ty); + Wire.quote v; string_of_int i ] + :: !entries + (* A type the structural printer has no arm for, or storage + that could not be read. Named, with the reason, rather + than left out: a local that is missing and a local that + could not be printed are different facts. *) + | Error why -> refused := (n, why) :: !refused)) + fn.Tast.slots; + Ok (List.rev !entries, List.rev !refused) + in + (match one_stop t read with | Error m -> error m - | Ok v -> - (* One line per slot — name, type, value, slot index — tab - separated, and safe because every string the renderer emits is - escaped. The index is last and it is what [i] in the break - buffer hands back to [inspect]: two slots can share a name, so - the name is not an identifier and the position in this list is - not one either, since a refused slot is not in it. *) - let entries = - List.filter_map - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value; slot ] -> - Some - (Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value; slot ]) - | _ -> None) - (String.split_on_char '\n' v) - in + | Ok (entries, refused) -> ok [ ":frame " ^ Wire.quote name; ":locals " ^ Wire.list entries; @@ -2487,16 +2552,13 @@ let locals t ~frame = involved; this is the other half. The break loop stashed the pointer it was handed in the agent's snapshot, and this end knows the type at that address — it compiled it, and [status] reports its qualified name. So it - is [locals] pointed at the condition: a thunk renders each field through - [flan/dev-cond], on the stopped thread, and the text comes back the same - way. + is [locals] pointed at the condition: the agent says where the condition + is and [Inspect] reads each field at its offset. - Delivered at-stop, and that is the correctness of it rather than a nicety. - The thunk reads whatever pointer the snapshot on top holds when it runs; a - program that resumed and stopped again holds a *different* condition, and - rendering the old stop's type over the new stop's pointer would be a - misread with a plausible shape. Naming the stop makes the agent drop the - thunk instead. + Held to one stop, and that is the correctness of it rather than a nicety: + a program that resumed and stopped again holds a *different* condition, + and reading the old stop's type over the new stop's pointer would be a + misread with a plausible shape. Refused, by name, for a stop that has no value to read: a trap like [NullAllocator] is a name with no struct behind it, and a trap with no @@ -2533,36 +2595,40 @@ let condition_op t = match stop_gen t with | None | Some 0 -> error "cannot pin the stop this condition belongs to; ask again" - | Some gen -> - let c, refused = Session.render_condition t.session ~st in - (match run_render_thunk ~at_stop:gen t ~tag:"c" ~c with + | Some _ -> + let c = reader t in + let read () = + match agent_addr t "cond-at" with + | Error m -> Error m + | Ok base -> + let _, _, offs = + Emit.lay_fields c.Inspect.md + (List.map (fun (f : Tast.field) -> f.Tast.fty) st.Tast.fields) + in + let entries = ref [] and refused = ref [] in + List.iter2 + (fun (f : Tast.field) off -> + match Inspect.render c ~addr:(base + off) f.Tast.fty with + | Ok v -> + entries := + Wire.list + [ Wire.quote f.Tast.fname; + Wire.quote (Types.to_string f.Tast.fty); + Wire.quote v ] + :: !entries + (* A field the structural printer has no arm for, named + with the reason, so the buffer shows the field and + says why its value is not beside it. *) + | Error why -> refused := (f.Tast.fname, why) :: !refused) + st.Tast.fields offs; + Ok (List.rev !entries, List.rev !refused) + in + (* Held to one stop: the type was chosen against the stop [status] + answered for, and a program that resumed and stopped again + holds a different condition behind the same verb. *) + (match one_stop t read with | Error m -> error m - | Ok v -> - (* One line per field — name, type, value, tab separated, and - safe because every string the renderer emits is escaped. - - A line that is not three parts is *not* dropped. Nothing - should produce one, which is exactly why it must be visible - if anything ever does: a field silently in neither list - would read as a condition that has fewer fields than it - has. It joins the refusals, with what came back. *) - let entries = ref [] and strays = ref [] in - List.iter - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value ] -> - entries := - Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value ] - :: !entries - | _ -> - if String.trim line <> "" then - strays := - (line, "the renderer wrote a line this end could not \ - read as a field") - :: !strays) - (String.split_on_char '\n' v); - let entries = List.rev !entries in + | Ok (entries, refused) -> ok [ ":type " ^ Wire.quote cname; ":fields " ^ Wire.list entries; @@ -2577,7 +2643,7 @@ let condition_op t = (List.map (fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ]) - (refused @ List.rev !strays)) ]) + refused) ]) (* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second rooting mode. [docs/BUILT.md]'s "Two ways to root a walk" says what each root @@ -2593,9 +2659,9 @@ let condition_op t = This roots the walk where the listing roots it: a frame and a slot index, which is the address the shadow stack knows, plus the type [Tast.fn.slots] knows. A step into a field is then an address plus an offset with that - field's type, which is arithmetic [Render.render] already does — see - [Session.render_slot], which is [render_locals] with a path applied to the - root and one line out instead of one per slot. + field's type — see [Session.slot_path], which builds the path, and + [Inspect.place], which works out where it ends. The value there is read + the way [locals] reads a slot. The frame checks are [locals]'s, by construction: both go through [stopped_frame]. An inspector that made its own would be free to read a @@ -2619,37 +2685,49 @@ let inspect t ~frame ~slot ~path = | Ok bound -> if not (List.mem slot bound) then (* The same refusal the listing gives, and for the same reason: an - unbound slot's entry is null, and a thunk that rendered it would - fault on the game thread of a program that is already stopped. *) + unbound slot's entry is null, and there is nothing there to read. *) error (Printf.sprintf "slot %d of %s was not bound yet at the point the program \ stopped; there is nothing at that address to read" slot name) else - match Session.render_slot t.session ~frame ~fn ~slot ~path with + let c = reader t in + let read () = + match agent_addr t (Printf.sprintf "slot %d %d" frame slot) with + | Error m -> Error m + | Ok base -> + (match + Session.slot_path t.session ~fn ~slot ~path + ~root:(Inspect.root ~addr:base) + with + | Error why -> Error why + | Ok (v, label) -> + (match Inspect.place c v with + | Error why -> Error (label ^ ": " ^ why) + | Ok addr -> + (match Inspect.render c ~addr v.Tast.ty with + | Error why -> Error (label ^ ": " ^ why) + | Ok value -> + (* Where the value is stored, when the path ends at a + place in the stopped frame: a data case's field is + not one — [set] refuses to store to it, because the + tag decides which case the bytes are — so it has no + address to offer. *) + let addr = + if Emit.addr_is_place v then Some addr else None + in + Ok (label, Types.to_string v.Tast.ty, value, addr)))) + in + match one_stop t read with | Error why -> error why - | Ok (c, label, ty) -> - (match run_render_thunk t ~tag:"i" ~c with - | Error m -> error m - | Ok out -> - (* The address the value is stored at, on a line of its own, and - then the value. See [Session.render_slot]. *) - let addr, v = - match String.index_opt out '\n' with - | Some i -> - ( Int64.of_string_opt (String.sub out 0 i), - String.sub out (i + 1) (String.length out - i - 1) ) - | None -> (None, out) - in + | Ok (label, ty, v, addr) -> ok ([ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label; ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ] @ (match addr with - (* Unsigned, as an address is: a user-space pointer is - positive as an i64 today, and printing it as the - unsigned number keeps that true if it ever is not. *) - | Some a -> [ Printf.sprintf ":addr %Lu" a ] + (* Unsigned, as an address is. *) + | Some a -> [ Printf.sprintf ":addr %Lu" (Int64.of_int a) ] | None -> []) @ [ (* Which stop this was read at, so that a write built from @@ -2659,7 +2737,7 @@ let inspect t ~frame ~slot ~path = moment at which it is true of what the reader is looking at, and an editor that asked for it separately would be asking a second time about a different instant. *) - ":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ]))) + ":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ])) (* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the @@ -2866,90 +2944,6 @@ let type_of_spelling t spelling : (Types.t, string) result = | ty -> Ok ty | exception Loc.Error { Loc.dmsg = why; _ } -> refuse why) -(* The extern that hands a number back as a pointer. - - The one piece an address-rooted thunk cannot work out for itself, and it is - the same arrangement [flan/dev-slot] has for a frame's slot: Flan has no - integer-to-pointer cast, deliberately, and the inspector is not a Flan - program. Everything after this is ordinary — a pointer-to-pointer cast and - a render, which is what [Session.render_slot] already does at a slot's - address. *) -let addr_extern : Tast.extern = - { Tast.ename = "flan/dev-addr"; esym = "flan_dev_reg_addr"; - eparams = [ Types.Int Types.I64 ]; - eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); eloc = Loc.unknown } - -(* Renders the value [(Ptr ty)] holding [addr], in the program. - - **A pointer and not the pointee, and that is the design.** Rendering the - [ty] at that address directly would read the storage whatever the registry - said, which is the hex dump this project does not want to be. Rendering a - [(Ptr ty)] puts the walk through [render.ml]'s pointer arm, which is the - arm that asks first: live, and the pointee is rendered one level deeper; - dead, and the epitaph says what died there instead. So an address root and - a slot root reach the same two answers by the same path, and the permission - question is asked in exactly one place in the compiler. - - Built here rather than in [session.ml] because it is the inspector's - rooting mode and not the session's: a session renders what a *program* - holds — a frame's slot, a global — and an address handed in from outside is - neither of those. *) -let render_addr (s : Session.t) ~addr ~(ty : Types.t) - : (Session.change, string) result = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = s.Session.program.Tast.structs; - datas = s.Session.program.Tast.datas; - unions = s.Session.program.Tast.unions; - enums = - Hashtbl.fold (fun k v acc -> (k, v) :: acc) s.Session.env.Check.enums []; - emit = Session.dev_emitter; - ptrs = Some Session.dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let pty = Types.Ptr (Types.Mut, ty) in - let root = - { Tast.e = - Tast.Prim - (Tast.Cast pty, - [ { Tast.e = - Tast.Call - ("flan/dev-addr", - [ { Tast.e = Tast.Int (Int64.of_int addr, Types.I64); - ty = Types.Int Types.I64; loc } ]); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } ]); - ty = pty; loc } - in - match Render.render c 0 root with - | exception Loc.Error { Loc.dmsg = why; _ } -> Error why - | parts -> - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - s.Session.thunks <- s.Session.thunks + 1; - let name = Printf.sprintf "at/%d" s.Session.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: what is being shown - is storage this thunk reaches by address. *) - snames = Array.make (List.length !extra) None } - in - let program = - { s.Session.program with - Tast.fns = s.Session.program.Tast.fns @ [ thunk ]; - externs = s.Session.program.Tast.externs @ Session.externs @ [ addr_extern ] } - in - (* Through the session's own chooser, so that this thunk is compiled by - whichever backend built the process it is about to be loaded into. *) - let ir = Session.redefinition s ~call:name program ~fns:[ name ] in - Ok { Session.ir; x86 = s.Session.x86; names = []; fns = []; installs = true; stale = [] } - (* [(:op "at" :addr N :type "Enemy")] — point at any heap address. The inspector's third rooting mode, and the one that needs no frame. @@ -2995,21 +2989,20 @@ let inspect_addr t ~addr ~want_type = else match liveness t with | Gone -> error gone - (* The registry outlives the run, so the entry is still there — and that is - the trap. Rendering what is at the address means building a thunk and - having the program run it, and a parked program runs nothing; the answer - would be a five-second wait. *) + (* The registry outlives the run, so the entry is still there — but the + agent reads memory only for a stopped program, which is the moment + nothing is writing it, and a parked one has not stopped on anything. *) | Parked when not (parked_break t) -> parked "whether an address is still live is read from a stopped program, and \ a parked one has not stopped on anything" - (* The thunk this builds is delivered stopped-only, and a park with a - stopped thunk in it satisfies that check exactly as a running program's - break does: the agent asks its own [depth], which the break loop raised, - and knows nothing about runs. So this needs no special case beyond being - allowed through — and it wants one, because the registry outlived the - run and an address out of a leak report from the last run is a thing - somebody has in their hand precisely while the program is parked. *) + (* A park with a stopped thunk in it satisfies the agent's gate exactly as + a running program's break does: the agent asks its own [depth], which + the break loop raised, and knows nothing about runs. So this needs no + special case beyond being allowed through — and it wants one, because + the registry outlived the run and an address out of a leak report from + the last run is a thing somebody has in their hand precisely while the + program is parked. *) | Live | Parked -> match state t with | Running -> @@ -3074,21 +3067,19 @@ let inspect_addr t ~addr ~want_type = let live = match entry with Some e when e.rlive -> "t" | _ -> "nil" in - (match render_addr t.session ~addr ~ty with + (* As a [(Ptr ty)] holding the address, so the registry is asked + before a byte is read: live, and the pointee is shown; dead, + and what died there. See [Inspect.render_ptr]. The agent's + verbs are stopped-only, which is what holds the gate above. *) + let c = reader t in + (match one_stop t (fun () -> Inspect.render_ptr c ~addr ty) with | Error m -> error m - | exception Failure m -> error m - | Ok c -> - (* Stopped-only, and the only one of the three that is. The - gate above was read three round trips and a build ago; - this is what holds it. See [run_render_thunk]. *) - (match run_render_thunk ~stopped_only:true t ~tag:"a" ~c with - | Error m -> error m - | Ok v -> - ok - ([ Printf.sprintf ":addr %d" addr; - ":type " ^ Wire.quote (Types.to_string (Types.Ptr (Types.Mut, ty))); - ":value " ^ Wire.quote v; ":live " ^ live ] - @ told @ where)))))) + | Ok v -> + ok + ([ Printf.sprintf ":addr %d" addr; + ":type " ^ Wire.quote (Types.to_string (Types.Ptr (Types.Mut, ty))); + ":value " ^ Wire.quote v; ":live " ^ live ] + @ told @ where))))) (* [reg types] and [reg leaks] — the table grouped by type spelling. @@ -3221,23 +3212,18 @@ let reg_listing t ~verb ~note = membership in the union and the frame numbers beside an entry, is now a named refusal like every other. - Nothing is copied out of the program here either, and the mechanism is one - step simpler than [locals]: a global is reached by name rather than by - address, because [Emit.redefinition] writes a global the host already has as - [external] and the dynamic linker binds the thunk to the program's own - storage. So there is no [bound_slots] round trip and no not-yet-bound case — - a global's storage exists from the moment the process started. *) + The mechanism is one step simpler than [locals]: a global is found by its + symbol rather than through a frame, so there is no [bound_slots] round trip + and no not-yet-bound case — a global's storage exists from the moment the + process started. [Inspect] reads it there. *) let globals_op t = match liveness t with | Gone -> error gone - (* Refused for the mechanism and not for the policy, which is worth saying - because the storage really is readable: a global's memory exists from the - moment the process started and is exactly as the finished run left it, - which is the whole of what makes a re-run worth having. What does not - exist while parked is the renderer. A globals section is a thunk built - here, delivered, and run by the program at a frame boundary, the same as - [locals] and [inspect]; the stack that decides which globals to show went - with the run as well. *) + (* Refused because the section is the globals a stopped *stack* reaches, + and a parked program's stack went with the run. The storage itself is + readable — it is exactly as the finished run left it — and the agent's + reads are gated on a break rather than on a park only because a break is + the moment that is promised to hold still. *) | Parked when not (parked_break t) -> parked "a globals section is the globals a stopped stack reaches, and a parked \ @@ -3364,32 +3350,38 @@ let globals_op t = "no frame on this stack references a global; there is \ nothing here that is not already in the locals" ] else begin - let c, refused = Session.render_globals t.session ~globals:ordered in - match run_render_thunk t ~tag:"g" ~c with - | Error m -> error m - | Ok v -> - (* One line per global, name and type and value, tab separated — - safe because every string the renderer emits is escaped. The - frames are added back here, from the table above, because the - thunk knows nothing about the stack it was chosen for. *) - let by_name = Hashtbl.create 32 in + (* A global is found by its symbol: the executable's own, for one + the program was built with, or flan_dev.c's table for one it + introduced since — the two places a redefinition module finds + one. *) + let c = reader t in + let read () = + let entries = ref [] and refused = ref [] in List.iter (fun (g : Tast.global) -> - Hashtbl.replace by_name g.Tast.gname (where g)) + let v = + match agent_addr t ("global " ^ Mangle.sym g.Tast.gname) with + | Error m -> Error m + | Ok addr -> Inspect.render c ~addr g.Tast.gty + in + match v with + | Ok v -> + entries := + Wire.list + [ Wire.quote g.Tast.gname; + Wire.quote (Types.to_string g.Tast.gty); + Wire.quote v; where g ] + :: !entries + (* Named with its reason rather than left out: a global that + is missing and a global that could not be printed are + different facts. *) + | Error why -> refused := (g.Tast.gname, why) :: !refused) ordered; - let entries = - List.filter_map - (fun line -> - match String.split_on_char '\t' line with - | [ n; ty; value ] -> - Some - (Wire.list - [ Wire.quote n; Wire.quote ty; Wire.quote value; - (try Hashtbl.find by_name n - with Not_found -> Wire.list []) ]) - | _ -> None) - (String.split_on_char '\n' v) - in + Ok (List.rev !entries, List.rev !refused) + in + match one_stop t read with + | Error m -> error m + | Ok (entries, refused) -> ok [ ":globals " ^ Wire.list entries; ":refused " @@ -4262,7 +4254,7 @@ let watch_enable t ~on = (* [NAME VALUE] per line, after a header of [COUNT DROPPED]. - Tab is safe as the separator for [render_locals]'s reason: every string that + Tab is safe as the separator because every string that reaches a value goes through an emitter that escapes tab and newline, so neither can appear inside one. [OVERFLOW] is carried rather than dropped — a name that found no slot is a value that never appears, and a buffer that diff --git a/lib/inspect.ml b/lib/inspect.ml new file mode 100644 index 00000000..f4024985 --- /dev/null +++ b/lib/inspect.ml @@ -0,0 +1,432 @@ +(** The inspector's reader: a value rendered by reading a stopped program's + memory through the type layouts the compiler computed, with nothing + compiled. + + What it replaces is a thunk per inspection. A Flan value carries no header, + so only the compiler knows what the bytes at an address are, and the first + answer to that was to compile the knowledge into a module — [Render.render] + over the address, built, loaded, run on the stopped thread, read back. That + costs a build per question, and it means nothing on this side can *hold* a + value: the thunk is gone once it has printed. The layouts were never the + program's to know, though. [Emit.lay] is where both backends get every + offset and size, and the daemon owns the build, so it can read the bytes + itself and walk them — the only facts it needs from the program are where a + root is, what bytes are at an address, and the two things only the runtime + can answer: whether a pointer may be followed, and what a dyn word is. + Those are [mem] below, and the agent's [peek], [ptr] and [dyn] verbs. + + The text is [Render.render]'s, byte for byte, because the editor parses it + back (emacs/flan-inspect.el) and because a locals listing and an + inspection of the same slot must not read differently. That walk still + exists — [println] and an evaluated expression's value are rendered at + compile time — so this is a second walk over the same arms, and each arm + below names its twin's decisions rather than making its own. What cannot + drift is shared outright: which types are refused comes from running + [Render.render] itself over the type ([refusal]), and a struct's head from + [Render.head]. *) + +(* What the reader needs from the stopped program. [read] raises + [Unreadable] rather than returning garbage for an address that is not + mapped, which is the agent reading through process_vm_readv. *) +type ptr_state = Live | Dead of string | Unknown + +exception Unreadable of string + +type mem = { + read : int -> int -> string; (* address, length *) + ptr : int -> ptr_state; + dyn : int64 -> string; +} + +type ctx = { + md : Emit.m; + structs : Tast.structure list; + datas : Tast.data list; + unions : Tast.structure list; + enums : (string * (string * int64) list) list; + mem : mem; + (* Bytes already read, by aligned chunk. A struct's fields are neighbours, + and asking the agent once per scalar would be a round trip per leaf over + a socket in the two-process daemon. Sound for one walk because the + program is stopped for all of it. *) + cache : (int, string) Hashtbl.t; +} + +let make ~(program : Tast.program) ~enums ~mem = + { md = X86.layout_ctx ~checks:false ~dev:true program; + structs = program.Tast.structs; datas = program.Tast.datas; + unions = program.Tast.unions; enums; mem; cache = Hashtbl.create 16 } + +let chunk = 256 + +let read c addr len = + if len <= 0 then "" + else + let base = addr - (addr mod chunk) in + if addr + len <= base + chunk then begin + (* A chunk that crosses into an unmapped page fails as a whole, where the + bytes asked for alone may be fine: fall back to exactly those. *) + match Hashtbl.find_opt c.cache base with + | Some s -> String.sub s (addr - base) len + | None -> + (match c.mem.read base chunk with + | s -> Hashtbl.replace c.cache base s; String.sub s (addr - base) len + | exception Unreadable _ -> c.mem.read addr len) + end + else c.mem.read addr len + +let u8 c a = Char.code (read c a 1).[0] +let i8 c a = String.get_int8 (read c a 1) 0 +let i16 c a = String.get_int16_le (read c a 2) 0 +let u16 c a = String.get_uint16_le (read c a 2) 0 +let i32 c a = String.get_int32_le (read c a 4) 0 +let i64 c a = String.get_int64_le (read c a 8) 0 +let ptr c a = Int64.to_int (i64 c a) + +(* An integer of kind [k], widened to i64 the way the thunk's [Cast] widens + it: sign extension for a signed kind, zero extension otherwise. *) +let int c a (k : Types.ikind) : int64 = + match k with + | Types.I8 -> Int64.of_int (i8 c a) + | Types.U8 -> Int64.of_int (u8 c a) + | Types.I16 -> Int64.of_int (i16 c a) + | Types.U16 -> Int64.of_int (u16 c a) + | Types.I32 -> Int64.of_int32 (i32 c a) + | Types.U32 -> Int64.logand (Int64.of_int32 (i32 c a)) 0xFFFFFFFFL + | Types.I64 | Types.U64 -> i64 c a + +(* ── The text, as the runtime spells it ───────────────────────────────── *) + +(* The result buffer's size, and what a value that overran it becomes: cut + so that "..." still fits, then "..." (runtime/flan_dev.c, [RESULT_MAX] + and [truncate_value]). One cap per value, where the thunk had one per + module — a locals listing used to share 4096 bytes between every slot, + and the slots after the cut fell out of the reply without a word. *) +let cap = 4096 + +exception Full + +let put b s = + let room = cap - Buffer.length b in + if String.length s > room then begin + Buffer.add_string b (String.sub s 0 (max 0 room)); + raise Full + end + else Buffer.add_string b s + +(* runtime/flan_rt.c's [flan_f64_format]: an unsigned NaN, and C's %g, which + OCaml's Printf hands to the same printf. *) +let f64 x = if Float.is_nan x then "nan" else Printf.sprintf "%g" x + +(* runtime/flan_rt.c's [flan_escape_char], framed in quotes as + [flan_dev_emit_str] frames it. *) +let quoted s = + let b = Buffer.create (String.length s + 2) in + Buffer.add_char b '"'; + String.iter + (fun ch -> + match ch with + | '"' -> Buffer.add_string b "\\\"" + | '\\' -> Buffer.add_string b "\\\\" + | '\n' -> Buffer.add_string b "\\n" + | '\t' -> Buffer.add_string b "\\t" + | '\r' -> Buffer.add_string b "\\r" + | c when Char.code c < 0x20 -> Buffer.add_string b (Printf.sprintf "\\x%02x" (Char.code c)) + | c -> Buffer.add_char b c) + s; + Buffer.add_char b '"'; + Buffer.contents b + +(* runtime/flan_dev.c's [flan_dev_emit_u8_char]: the byte's spelling as + lib/reader.ml's [read_byte] takes it back, or nothing. *) +let u8_char x = + match x with + | 32 -> " (\\space)" + | 9 -> " (\\tab)" + | 10 -> " (\\newline)" + | 13 -> " (\\return)" + | 0 -> " (\\nul)" + | _ when x < 33 || x > 126 -> "" + | _ -> + (match Char.chr x with + | '(' | ')' | '[' | ']' | '{' | '}' | '"' | ';' | '`' | '~' | ',' -> "" + | ch -> Printf.sprintf " (\\%c)" ch) + +(* ── Which types are refused ──────────────────────────────────────────── *) + +(* The refusal [Render.render] would give for a value of [ty], or [None]. + Asked of the walk itself, over a placeholder it never evaluates, so the + rule — which arms exist, and that a field past the span cap or a level past + the depth cap is never looked at — has one statement. *) +let refusal c (ty : Types.t) : string option = + let loc = Loc.unknown in + let unit_ = { Tast.e = Tast.Unit; ty = Types.Unit; loc } in + let emit _ = unit_ in + let rc = + { Render.structs = c.structs; datas = c.datas; unions = c.unions; + enums = c.enums; + emit = { Render.ebytes = emit; estr = emit; ei64 = emit; eu64 = emit; + ef64 = emit; edyn = emit }; + ptrs = Some { Render.live = (fun _ -> { unit_ with ty = Types.Bool }); + bytechar = emit; epitaph = emit }; + alloc = (fun _ -> 0) } + in + match Render.render rc 0 { Tast.e = Tast.Local 0; ty; loc } with + | _ -> None + | exception Loc.Error { Loc.dmsg; _ } -> Some dmsg + +(* ── The walk ─────────────────────────────────────────────────────────── *) + +let find_struct c n = + List.find_opt (fun (s : Tast.structure) -> String.equal s.Tast.sname n) c.structs + +let find_data c n = + List.find_opt (fun (u : Tast.data) -> String.equal u.Tast.dname n) c.datas + +let size c ty = fst (Emit.lay c.md ty) + +let offsets c tys = let _, _, offs = Emit.lay_fields c.md tys in offs + +(* Where a data value's payload starts: the second member of [Emit.lay]'s + { i32 tag, [k x iA] }. *) +let payload_off c (u : Tast.data) = + let psize, palign = Emit.payload_lay c.md u in + if psize = 0 then 4 + else + List.nth + (offsets c + [ Types.Int Types.I32; + Types.Array (Int64.of_int (psize / palign), + Types.Int (Emit.int_kind (palign * 8))) ]) + 1 + +let case_offsets c (v : Tast.variant) = + offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) v.Tast.vfields) + +let option_off c t = List.nth (offsets c [ Types.Int Types.I8; t ]) 1 + +(* [Render.render]'s arms, in its order and with its text. *) +let rec walk c b depth addr (ty : Types.t) = + if depth > Render.max_depth then put b "..." + else + match ty with + | Types.Int Types.U64 -> put b (Printf.sprintf "%Lu" (i64 c addr)) + | Types.Int Types.U8 -> + let x = u8 c addr in + put b (string_of_int x); + put b (u8_char x) + | Types.Int k -> put b (Int64.to_string (int c addr k)) + | Types.Float Types.F32 -> put b (f64 (Int32.float_of_bits (i32 c addr))) + | Types.Float Types.F64 -> put b (f64 (Int64.float_of_bits (i64 c addr))) + (* An [i1] in memory is a byte, and a load keeps its low bit. *) + | Types.Bool -> put b (if u8 c addr land 1 <> 0 then "true" else "false") + | Types.Unit -> put b "()" + | Types.String | Types.Slice (_, Types.Int Types.U8) -> + let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in + (* Enough bytes to overrun the cap once quoted, and no more: a string of + a million bytes is shown as its first few thousand either way. *) + let n = max 0 (min n cap) in + put b (quoted (if n = 0 then "" else read c p n)) + (* The members are checked last-declared first, as the thunk's chain of + comparisons is nested, so a value two members share reads as the later. *) + | Types.Enum n -> + let members = try List.assoc n c.enums with Not_found -> [] in + let v = Int64.of_int32 (i32 c addr) in + (match List.find_opt (fun (_, m) -> Int64.equal m v) (List.rev members) with + | Some (name, _) -> put b (":" ^ name) + | None -> put b (Int64.to_string v)) + | Types.Ptr (_, t) -> pointer c b depth (ptr c addr) t + | Types.Alloc -> put b "" + | Types.Vec _ -> put b "" + | Types.Fn _ -> put b ("<" ^ Types.to_string ty ^ ">") + | Types.Option t -> + if i8 c addr <> 0 then begin + put b "(some "; + walk c b (depth + 1) (addr + option_off c t) t; + put b ")" + end + else put b "none" + | Types.Named n when find_data c n <> None -> + let u = Option.get (find_data c n) in + let tag = Int32.to_int (i32 c addr) in + (match List.nth_opt u.Tast.cases tag with + | Some v when tag >= 0 -> + let full = Render.case_name n v.Tast.vname in + if v.Tast.vfields = [] then put b full + else begin + let base = addr + payload_off c u in + let offs = case_offsets c v in + put b (Render.head full); + List.iteri + (fun i ((f : Tast.field), off) -> + if i < Render.max_span then begin + if i > 0 then put b " "; + put b ("." ^ f.Tast.fname ^ " "); + walk c b (depth + 1) (base + off) f.Tast.fty + end) + (List.combine v.Tast.vfields offs); + if List.length v.Tast.vfields > Render.max_span then put b " ..."; + put b "})" + end + | _ -> put b (Printf.sprintf "<%s tag %d>" n tag)) + | Types.Named n + when List.exists (fun (u : Tast.structure) -> String.equal u.Tast.sname n) + c.unions -> + put b ("<" ^ n ^ " union>") + | Types.Named n -> + (match find_struct c n with + | None -> put b ("<" ^ n ^ ">") + | Some st -> + let fields = st.Tast.fields in + let offs = offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) fields) in + put b (Render.head n); + List.iteri + (fun i ((f : Tast.field), off) -> + if i < Render.max_span then begin + if i > 0 then put b " "; + put b ("." ^ f.Tast.fname ^ " "); + walk c b (depth + 1) (addr + off) f.Tast.fty + end) + (List.combine fields offs); + if List.length fields > Render.max_span then put b " ..."; + put b "})") + | Types.Array (n, t) -> + let n = Int64.to_int n in + let shown = min n Render.max_span and sz = size c t in + put b "["; + for i = 0 to shown - 1 do + put b " "; + walk c b (depth + 1) (addr + (i * sz)) t + done; + if n > shown then put b " ..."; + put b "]" + (* No span cap, as the thunk's loop has none: the value's cap is what + stops a long slice. *) + | Types.Slice (_, t) -> + let p = ptr c addr and n = Int64.to_int (i64 c (addr + 8)) in + let sz = size c t in + put b "["; + for i = 0 to n - 1 do + put b " "; + walk c b (depth + 1) (p + (i * sz)) t + done; + put b "]" + | Types.Dyn -> put b (c.mem.dyn (i64 c addr)) + (* [refusal] turned these away before the walk began. *) + | t -> put b ("<" ^ Types.to_string t ^ ">") + +(* A pointer holding [p]: followed one level deeper if the registry says it + is live, what died there if it is dead, and its bare shape if the registry + never saw it — a stack local, a global, a pointer from C, or null. *) +and pointer c b depth p t = + match c.mem.ptr p with + | Live -> put b "" + | Dead why -> put b "" + | Unknown -> put b "" + +let finish f ty c = + match refusal c ty with + | Some why -> Error why + | None -> + let b = Buffer.create 64 in + (match f b with + | () -> Ok (Buffer.contents b) + | exception Full -> + let s = Buffer.contents b in + Ok (String.sub s 0 (min (String.length s) (cap - 3)) ^ "...") + | exception Unreadable why -> Error why + | exception Failure why -> Error why) + +(* The value of type [ty] at [addr], as [Render.render] would have printed + it, or the refusal. A value that could not be read — an address the agent + found unmapped — is an error too, named, rather than a partial rendering. *) +let render c ~addr (ty : Types.t) : (string, string) result = + finish (fun b -> walk c b 0 addr ty) ty c + +(* A [(Ptr ty)] holding [addr], which is how an address somebody has in hand + is shown: through the pointer arm, so the registry is asked before a byte + of it is read and a dead block names what died instead. *) +let render_ptr c ~addr (ty : Types.t) : (string, string) result = + finish (fun b -> pointer c b 0 addr ty) (Types.Ptr (Types.Mut, ty)) c + +(* ── Where a path ends ────────────────────────────────────────────────── *) + +(* The address a [Session.step_into] path reaches, and its type. + + The steps are still [Session.step_into]'s: it is the one statement of which + steps a type admits and how each is refused, and the thunk's addressing was + built on it. What it produces is an expression over a [Deref] of the root; + this computes where that expression's value lives instead of compiling it. + Two checks the compiled thunk made in the program are made here: an index + into a slice against the slice's length, and a data type's case against its + tag — a field of the case the value is not in is a payload that is not + there. *) +let rec place c (e : Tast.expr) : (int, string) result = + let ( let* ) = Result.bind in + match e.Tast.e with + | Tast.Deref { Tast.e = Tast.Int (a, _); _ } -> Ok (Int64.to_int a) + | Tast.Field (target, i) -> + let* a = place c target in + (match target.Tast.ty with + | Types.Option t -> Ok (if i = 0 then a else a + option_off c t) + | Types.Named n -> + (match find_struct c n with + | Some st -> + Ok (a + List.nth (offsets c (List.map (fun (f : Tast.field) -> f.Tast.fty) + st.Tast.fields)) i) + | None -> Error (n ^ " has no layout here")) + | t -> Error ("no field in " ^ Types.to_string t)) + | Tast.CaseField (target, case, i) -> + let* a = place c target in + (match target.Tast.ty with + | Types.Named n -> + (match find_data c n with + | None -> Error (n ^ " has no layout here") + | Some u -> + let rec index k = function + | [] -> None + | (v : Tast.variant) :: rest -> + if String.equal v.Tast.vname case then Some (k, v) else index (k + 1) rest + in + (match index 0 u.Tast.cases with + | None -> Error (n ^ " has no case called " ^ case) + | Some (k, v) -> + let tag = Int32.to_int (i32 c a) in + if tag <> k then + Error + (Printf.sprintf + "the value is not a %s — its tag says %s — so that case's \ + fields are not in it" + (Render.case_name n case) + (match List.nth_opt u.Tast.cases tag with + | Some w when tag >= 0 -> Render.case_name n w.Tast.vname + | _ -> string_of_int tag)) + else Ok (a + payload_off c u + List.nth (case_offsets c v) i))) + | t -> Error ("no case field in " ^ Types.to_string t)) + | Tast.Prim (Tast.At, [ target; { Tast.e = Tast.Int (i, _); _ } ]) -> + let* a = place c target in + let i = Int64.to_int i in + (match target.Tast.ty with + | Types.Array (_, t) -> Ok (a + (i * size c t)) + | Types.Slice (_, t) -> + let n = Int64.to_int (i64 c (a + 8)) in + if i >= n then + Error + (Printf.sprintf "%d is past the end of a slice of %d elements" i n) + else Ok (ptr c a + (i * size c t)) + | t -> Error ("no element in " ^ Types.to_string t)) + | _ -> Error "not a place the inspector can find" + +let place c e = + match place c e with + | r -> r + | exception Unreadable why -> Error why + +(* The root [step_into] walks from: the value of type [ty] at [addr]. *) +let root ~addr (ty : Types.t) : Tast.expr = + let loc = Loc.unknown in + { Tast.e = + Tast.Deref + { Tast.e = Tast.Int (Int64.of_int addr, Types.I64); + ty = Types.Ptr (Types.Mut, ty); loc }; + ty; loc } diff --git a/lib/render.ml b/lib/render.ml index c5cf9f6d..62ee5fcb 100644 --- a/lib/render.ml +++ b/lib/render.ml @@ -97,6 +97,12 @@ let max_span = 8 let fail = Loc.fail +(* How a struct's rendering opens, and what a data case is called in one. + Named here because lib/inspect.ml writes the same text by reading memory + instead of emitting calls, and the two must spell a value alike. *) +let head n = "(" ^ n ^ " {" +let case_name n v = n ^ "." ^ v + (* The refusal for a type the walk has no arm for, worded for the form that asked. [print]'s is the default. *) let print_refusal _loc t = @@ -256,7 +262,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis ty = Types.Int Types.I32; loc } ]); ty = Types.Bool; loc } in - let full = n ^ "." ^ v.Tast.vname in + let full = case_name n v.Tast.vname in let body = if v.Tast.vfields = [] then lit full else @@ -274,7 +280,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) fv) shown) in - do_ ((lit ("(" ^ full ^ " {") :: parts) + do_ ((lit (head full) :: parts) @ (if List.length v.Tast.vfields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) @@ -333,7 +339,7 @@ let rec render ?(refuse = print_refusal) c depth (e : Tast.expr) : Tast.expr lis @ render c (depth + 1) v) shown) in - [ do_ ((lit ("(" ^ n ^ " {") :: parts) + [ do_ ((lit (head n) :: parts) @ (if List.length fields > max_span then [ lit " ..." ] else []) @ [ lit "})" ]) ]) (* A fixed array's length is in its type, so it unrolls — capped, because diff --git a/lib/session.ml b/lib/session.ml index d79508bc..5abe33d9 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1352,19 +1352,13 @@ let externs : Tast.extern list = one emit_u64 "flan_dev_emit_u64"; one emit_f64 "flan_dev_emit_f64"; (* The address of a slot in a *stopped* frame, resolved by the agent - against the snapshot that break took. It is the one piece a locals + against the snapshot that break took. It is the one piece a write thunk cannot work out for itself: the compiler knows every slot's type and name, and nothing but the running program knows where the frame - is. See [render_locals]. *) + is. See [write_slot]. *) { Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot"; eparams = [ Types.Int Types.I64; Types.Int Types.I64 ]; eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); eloc = Loc.unknown }; - (* The condition the stopped program is holding, same contract: the agent - resolves it against the snapshot on top when the thunk runs, and NULL - when there is none. See [render_condition]. *) - { Tast.ename = "flan/dev-cond"; esym = "flan_agent_condition"; - eparams = []; eret = Types.Ptr (Types.Mut, (Types.Int Types.U8)); - eloc = Loc.unknown }; (* A typed restart's parameter, by the restart's index in the snapshot on top and a byte offset into its buffer, and the flag that says the buffer was written. See [arm_restart]. *) @@ -1512,235 +1506,24 @@ let shown_names (fn : Tast.fn) : string option array = | Some d -> if count d > 1 then raw.(i) else Some d) stripped -(* The second half of what a break loop can show, and it is the same primitive - as [C-x C-e] pointed somewhere else. - - Nothing marshals and nothing is read across the process boundary. A Flan - value carries no header, so the daemon could not make sense of bytes it - copied out even if it had them; what it has instead is the *type*, from - [Tast.fn.slots], and a name for it, from [snames] beside it. So it compiles - a thunk that renders those types at those addresses, in the program, and - reads back the text — exactly what an evaluated expression does, except - that the root is an address rather than an expression. That address is the - only thing that comes from the running program. - - [bound] is which slots the program says have been reached. It is not an - optimisation: an unbound slot's entry is null, and a thunk that rendered - one would dereference null on the game thread of a program that is already - stopped. So the refusal happens here, before any code is emitted for it. - - What comes back is one line per slot — name, type, value, tab separated. - Tab and newline are safe separators because every string the renderer emits - goes through [flan_dev_emit_str], which escapes both. - - Each slot is rendered from its address rather than copied into the thunk - first. A copy would be one [alloca] the size of the slot — 40KB for sand's - grid — and the walk only ever shows eight elements of it. The cost is one - call to [flan/dev-slot] per leaf the walk reaches instead of one per slot, - which the depth and span caps already bound. *) -let render_locals ?(origin = "") t ~frame ~(fn : Tast.fn) ~bound - : change * (string * string) list = - let loc = fn.Tast.floc in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs; - datas = t.program.Tast.datas; - unions = t.program.Tast.unions; - enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; - emit = dev_emitter; - ptrs = Some dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let refused = ref [] in - let refuse name why = refused := (name, why) :: !refused in - let one i ty name = - let idx n = - { Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; loc } - in - let address = - { Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx i ]); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ address ]); - ty = Types.Ptr (Types.Mut, ty); loc } - in - let v = { Tast.e = Tast.Deref typed; ty; loc } in - match Render.render c 0 v with - | parts -> - (* The slot *index* travels with the line, last, and it is what makes - [i] in the break buffer able to name this exact slot back to the - daemon. The name cannot: [check.ml]'s [fresh_slot] only ever - allocates, so (let [v 22] …) inside (let [v 11] …) is two slots both - called [v] and both listed here. Nor can the position in the list, - because a refused slot is not in it. See [render_slot]. *) - Some - ((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts) - @ [ lit ("\t" ^ string_of_int i ^ "\n") ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A type the structural printer has no arm for — a map, a function - value, a type variable. Named, with the reason, rather than left out - of the list: a local that is missing and a local that could not be - printed are different facts. *) - refuse name why; - None - in - let names = shown_names fn in - let body = - List.concat - ((List.filter_map - (fun i -> - let ty = fn.Tast.slots.(i) in - match names.(i) with - | None -> - (* A slot the compiler made up — hidden, not refused; see - [shown_names]. *) - None - | Some name when not (List.mem i bound) -> - refuse name - "not bound yet where the program stopped"; - None - | Some name -> one i ty name) - (List.init (Array.length fn.Tast.slots) (fun i -> i)))) - in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "locals/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: the locals being shown - are the *other* frame's, and this thunk reaches them by address. *) - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t ~call:name program ~fns:[ name ] - in - ignore origin; - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - -(* ── The fields of the condition a break is holding ────────────────── *) - -(* [render_locals] pointed at the condition instead of a frame. The break - loop stashes the pointer it was handed in the snapshot, the thunk reads it - back through [flan/dev-cond], and the type at that address is the struct - whose qualified name the agent reported as the condition — this end - compiled it, so the layout is its own to know. One line per field: - name, type, value, tab separated. - - The thunk carries no address of its own — [flan/dev-cond] resolves against - the snapshot on top when it runs — but the *type* it reads with was chosen - against a particular stop, so the caller delivers it at-stop: a program - that resumed and stopped again holds a different condition, and rendering - the old type over the new pointer is the misread the at-stop check - refuses. *) -let render_condition t ~(st : Tast.structure) : change * (string * string) list = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs; - datas = t.program.Tast.datas; - unions = t.program.Tast.unions; - enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; - emit = dev_emitter; - ptrs = Some dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let refused = ref [] in - let cty = Types.Named st.Tast.sname in - let address = - { Tast.e = Tast.Call ("flan/dev-cond", []); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, cty)), [ address ]); - ty = Types.Ptr (Types.Mut, cty); loc } - in - let root = { Tast.e = Tast.Deref typed; ty = cty; loc } in - let one i (f : Tast.field) = - let v = { Tast.e = Tast.Field (root, i); ty = f.Tast.fty; loc } in - match Render.render c 0 v with - | parts -> - Some - ((lit (f.Tast.fname ^ "\t" ^ Types.to_string f.Tast.fty ^ "\t") :: parts) - @ [ lit "\n" ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A field the structural printer has no arm for. Named with the - reason, so the buffer shows the field and says why its value is - not beside it. *) - refused := (f.Tast.fname, why) :: !refused; - None - in - let body = - List.concat - (List.filter_map Fun.id (List.mapi (fun i f -> one i f) st.Tast.fields)) - in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "condition/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = redefinition t ~call:name program ~fns:[ name ] in - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - (* ── One slot of a stopped frame, walked ───────────────────────────── *) (* The inspector's second rooting mode, and the whole of what it needed. - The inspector navigates by rewriting *expressions* — `(.pos b)' where the - last one was `b' — because a Flan value has no header and the thunk that - rendered it is [dlclose]d as soon as it returns, so nothing can be held on - this side the way CIDER holds a JVM object. The cost of that is the bug it - had: a name sent back to be evaluated is evaluated wherever the evaluator - stands, which on any frame but the innermost may resolve to a global, to a - different binding, or to nothing, with the listing above it still showing - the frame's own storage. + The inspector used to navigate by rewriting *expressions* — `(.pos b)' + where the last one was `b' — and a name sent back to be evaluated is + evaluated wherever the evaluator stands, which on any frame but the + innermost may resolve to a global, to a different binding, or to nothing, + with the listing above it still showing the frame's own storage. Rooting at the slot's address alone does not fix it — an address is not an expression, so the first step has nothing to build from. What makes this work is that the step does not have to be an expression either. A frame's address comes from the shadow stack and every slot's type comes from [Tast.fn.slots], so a step into a field is an address plus an offset with - that field's type, which is *exactly* the arithmetic [Render.render] does - for the locals listing. So this is [render_locals] with a path applied to - the root before the walk, and not a second walk. + that field's type. [slot_path] builds that as an expression over the + slot's value and [Inspect.place] works out where it lives, so the steps + and their refusals are stated once, here. What the path cannot do is the honest half. Every step is refused by name with its reason rather than guessed at: a field the type does not have, an @@ -1888,25 +1671,23 @@ let step_into t (v : Tast.expr) (s : step) : (Tast.expr, string) result = (Printf.sprintf "%s has no fields, so there is no .%s in it" (Types.to_string ty) spec)) -(* Renders slot [slot] of frame [frame], after walking [path] into it. The - thunk is [render_locals]'s, minus the loop over every slot: one root, one - line, and the reply carries the type the path ended at so the editor can - say what it is looking at. +(* Where slot [slot] of [fn] ends up after walking [path] into it, as an + expression over [root] — the value at the slot's address — together with + the label the reply names it by. [Dev.inspect] reads the value there + through [Inspect]; nothing is compiled. The caller has already established that the frame is the body this session holds — the slot fingerprint — and that the slot is bound. This function does not re-derive either; it is handed the [fn] that check passed. *) -let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path - : (change * string * string, string) result = - let loc = fn.Tast.floc in +let slot_path t ~(fn : Tast.fn) ~slot ~path ~(root : Types.t -> Tast.expr) + : (Tast.expr * string, string) result = let nslots_of_fn = Array.length fn.Tast.slots in if slot < 0 || slot >= nslots_of_fn then Error (Printf.sprintf "there is no slot %d in %s; it has %d" slot fn.Tast.name nslots_of_fn) else - let sname = (shown_names fn).(slot) in - match sname with + match (shown_names fn).(slot) with | None -> Error (Printf.sprintf @@ -1914,34 +1695,6 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path show it and there is nothing here to inspect" slot fn.Tast.name) | Some name -> - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs; - datas = t.program.Tast.datas; - unions = t.program.Tast.unions; - enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; - emit = dev_emitter; - ptrs = Some dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let idx n = - { Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64; - loc } - in - let ty = fn.Tast.slots.(slot) in - let address = - { Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx slot ]); - ty = Types.Ptr (Types.Mut, (Types.Int Types.U8)); loc } - in - let typed = - { Tast.e = Tast.Prim (Tast.Cast (Types.Ptr (Types.Mut, ty)), [ address ]); - ty = Types.Ptr (Types.Mut, ty); loc } - in - let root = { Tast.e = Tast.Deref typed; ty; loc } in let rec walk v = function | [] -> Ok v | s :: rest -> @@ -1949,65 +1702,9 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path | Error why -> Error why | Ok v' -> walk v' rest) in - (match walk root path with + (match walk (root fn.Tast.slots.(slot)) path with | Error why -> Error (name ^ path_text path ^ ": " ^ why) - | Ok v -> - (match Render.render c 0 v with - | exception Loc.Error { Loc.dmsg = why; _ } -> Error (name ^ path_text path ^ ": " ^ why) - | parts -> - (* Where the value lives, first and on a line of its own, when [v] - is a place in the stopped frame: its address is then the - storage the listing is reading. A data case's field is not a - place — [AddrOf] on it would answer the address of a copy — so - it has no address line. The caller splits the line off at the - first newline; a rendering has none, because [Render] quotes a - string's. *) - let parts = - if not (Emit.addr_is_place v) then parts - else - let addr = - { Tast.e = - Tast.Prim - (Tast.Cast (Types.Int Types.I64), - [ { Tast.e = Tast.Prim (Tast.AddrOf, [ v ]); - ty = Types.Ptr (Types.Mut, v.Tast.ty); loc } ]); - ty = Types.Int Types.I64; loc } - in - let newline = - { Tast.e = - Tast.Prim - (Tast.Bytes, - [ { Tast.e = Tast.Str "\n"; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - dev_emitter.Render.ei64 addr :: dev_emitter.Render.ebytes newline - :: parts - in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - t.thunks <- t.thunks + 1; - let tname = Printf.sprintf "inspect/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name = tname; params = []; ret = Types.Unit; - body = - (nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t - ~call:tname program ~fns:[ tname ] - in - ignore origin; - Ok - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, - name ^ path_text path, - Types.to_string v.Tast.ty))) + | Ok v -> Ok (v, name ^ path_text path)) (* ── Writing one of them back ──────────────────────────────────────── *) @@ -2022,7 +1719,7 @@ let render_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path for economy: the same root, the same [step_into], the same refusals for a field a type does not have. A write that addressed values its own way would be free to land somewhere the render above it never showed, which is the - whole class of bug [render_slot] exists to have closed. + whole class of bug [slot_path] exists to have closed. What is new is two things. The walk has to end at a *place* and not at a value, and the value being stored is an expression somebody typed, so it @@ -2117,7 +1814,7 @@ let writable_type (ty : Types.t) : (unit, string) result = save a page would be [(set msg "tuned")] left pointing at unmapped memory, which [emit.ml] spells out where it writes [flan_reload_transient]. - The caller has established the frame, as it has for [render_slot]. *) + The caller has established the frame, as it has for [slot_path]. *) let write_slot ?(origin = "") t ~frame ~(fn : Tast.fn) ~slot ~path ~(edits : (step list * string) list) : (change * string * string, string) result = @@ -2415,92 +2112,6 @@ let arm_restart ?(origin = "") t ~index ~(params : Types.t list) ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.map Types.to_string params) -(* ── The globals a stopped stack reaches ───────────────────────────── *) - -(* The other half of what a break loop can show, and in this language arguably - the more useful one: a game keeps most of its state in top-level [defonce]s, - and sand.flan holds its entire grid that way. - - Almost the same thunk as [render_locals] with a different root, and the - difference is the whole reason this is a second function rather than a - parameter. A local is reached by *address* — [flan/dev-slot] hands back - where the frame is, and only the stopped program knows that. A global is - reached by *name*: [Emit.redefinition] writes a global the host already has - as [external], so the loaded module binds to the program's own storage and - the dynamic linker does the work. Nothing has to be asked of the stopped - thread at all, which is also why there is no [bound] list here — a global's - storage exists from the moment the process started, so there is no - not-yet-bound case to refuse. - - [globals] is chosen by the caller and not here, because the choice is about - the *stack* and this function is about rendering. See [Dev.globals_op]. - - One line per global — name, type, value, tab separated — the same framing - [render_locals] uses, and safe for the same reason: every string the - renderer emits goes through [flan_dev_emit_str], which escapes both. *) -let render_globals ?(origin = "") t ~(globals : Tast.global list) - : change * (string * string) list = - let loc = Loc.unknown in - let extra = ref [] and nslots = ref 0 in - let c = - { Render.structs = t.program.Tast.structs; - datas = t.program.Tast.datas; - unions = t.program.Tast.unions; - enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums []; - emit = dev_emitter; - ptrs = Some dev_pointers; - alloc = (fun ty -> - let i = !nslots in - incr nslots; - extra := ty :: !extra; - i) } - in - let bytes_of str = - { Tast.e = - Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]); - ty = Types.Slice (Types.Mut, (Types.Int Types.U8)); loc } - in - let lit str = c.Render.emit.Render.ebytes (bytes_of str) in - let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in - let refused = ref [] in - let one (g : Tast.global) = - let v = { Tast.e = Tast.Global g.Tast.gname; ty = g.Tast.gty; loc } in - match Render.render c 0 v with - | parts -> - Some - ((lit (g.Tast.gname ^ "\t" ^ Types.to_string g.Tast.gty ^ "\t") :: parts) - @ [ lit "\n" ]) - | exception Loc.Error { Loc.dmsg = why; _ } -> - (* A type the structural printer has no arm for. Named with its reason - rather than left out, for [render_locals]'s reason: a global that is - missing and a global that could not be printed are different facts, - and a list that showed neither would be the same lie twice. *) - refused := (g.Tast.gname, why) :: !refused; - None - in - let body = List.concat (List.filter_map one globals) in - t.thunks <- t.thunks + 1; - let name = Printf.sprintf "globals/%d" t.thunks in - let thunk : Tast.fn = - { Tast.name; params = []; ret = Types.Unit; - body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ]; - fdefers = []; fenv = None; fparent = None; floc = loc; - slots = Array.of_list (List.rev !extra); - (* Every slot in here is the walk's own scratch: what is being shown is - the program's storage, which this thunk reaches by name. *) - snames = Array.make (List.length !extra) None } - in - let program = - { t.program with - Tast.fns = t.program.Tast.fns @ [ thunk ]; - externs = t.program.Tast.externs @ externs } - in - let ir = - redefinition t ~call:name program ~fns:[ name ] - in - ignore origin; - ({ ir; x86 = t.x86; names = []; fns = []; installs = true; stale = [] }, List.rev !refused) - (* [pause] is [C-u C-x C-e] — §9's "last expression" target. It is a flag and not a position, because there is only one form here and it is the whole of what was sent: the expression *is* the target. It is also why nothing here diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 245541a0..acb4b5ef 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -116,6 +116,15 @@ void *flan_dev_global(const char *name, uint64_t size, const void *init) { return e->cell; } +/* A global's storage by its symbol, for the daemon's inspector, or NULL for a + * name this table never interned — a global the host was built with, which the + * agent finds by symbol instead. It never interns: a lookup that allocated + * would hand back zeroed storage the program has never seen. */ +void *flan_dev_global_find(const char *name) { + entry *e = find(name); + return e == NULL ? NULL : e->cell; +} + /* ── The value of an evaluated expression ──────────────────────────── */ /* C-x C-e compiles a thunk that renders one expression and emits it here, a @@ -1671,26 +1680,39 @@ int32_t flan_dev_reg_live(const void *p) { * Returns 1 if anything was written, so that a caller can tell "the registry * has never heard of this address" — a stack local, which is by design not in * here — from "this is dead", which is the sentence worth printing. */ +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap); int32_t flan_dev_reg_emit(const void *p) { static char desc[192]; + int32_t n = flan_dev_reg_epitaph(p, desc, (int64_t)sizeof desc); + if (n <= 0) return 0; + flan_dev_emit((const uint8_t *)desc, n); + return 1; +} + +/* The epitaph's text, into [buf], and its length — 0 for an address that is + * live or that the table never saw. [flan_dev_reg_emit] above is this aimed at + * the result buffer; the agent's [ptr] verb is this aimed at a reply, for the + * daemon's inspector, which reads a stopped program's memory itself rather + * than building a thunk to render it. One sentence, so the two cannot word a + * dead pointer differently. */ +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap) { uintptr_t a = (uintptr_t)p; flan_reg_entry *e = flan_reg_on ? flan_reg_find(a) : NULL; int64_t off; char where[64]; int n; - if (e == NULL || e->died == 0) return 0; + if (e == NULL || e->died == 0 || cap <= 1) return 0; off = (int64_t)(a - e->base); where[0] = '\0'; if (e->elem > 0 && off % e->elem == 0 && off / e->elem > 0) snprintf(where, sizeof where, "[%lld] of ", (long long)(off / e->elem)); else if (off != 0) snprintf(where, sizeof where, "+%lld into ", (long long)off); - n = snprintf(desc, sizeof desc, " dead: was %s%.*s, freed at step %lld", + n = snprintf(buf, (size_t)cap, " dead: was %s%.*s, freed at step %lld", where, (int)e->typelen, e->type, (long long)e->died); if (n < 0) return 0; - if (n > (int)sizeof desc - 1) n = (int)sizeof desc - 1; - flan_dev_emit((const uint8_t *)desc, n); - return 1; + if (n > (int)cap - 1) n = (int)cap - 1; + return n; } /* How many blocks the table holds — everything, or only the live ones. For a @@ -1778,17 +1800,8 @@ int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, return 1; } -/* An address, as a number, handed back as a pointer. The one thing an - * address-rooted render thunk cannot do for itself: Flan has no integer-to- - * pointer cast, deliberately — a program that could make a pointer out of - * arithmetic is a program the type system stops describing — and the - * inspector is not a program. It is the same arrangement [flan_agent_frame_ - * slot] already has for a frame's slot, and for the same reason: the compiler - * knows the type, and something outside the language supplies the address. */ -void *flan_dev_reg_addr(int64_t a) { return (void *)(uintptr_t)a; } - -/* And back the other way, which is the half a *program* needs rather than the - * inspector. The address root above takes a number, and the things that hand +/* An address as a number, which is the half a *program* needs rather than + * the inspector. The address root takes a number, and the things that hand * out addresses as numbers all live outside the language — gdb, valgrind, a C * library's callback, a printf("%p") in somebody's shim. A Flan program that * wants to say one out loud has no cast for it, deliberately: pointer diff --git a/runtime/flan_dyn.c b/runtime/flan_dyn.c index ea488a33..14c2dba5 100644 --- a/runtime/flan_dyn.c +++ b/runtime/flan_dyn.c @@ -735,6 +735,11 @@ void flan_dyn_print(flan_dyn v) { render(flan_write_stdout, v, 0, 0); } void flan_dyn_emit_dev(flan_dyn v) { render(flan_dev_emit, v, 0, 1); } void flan_dyn_emit_watch(flan_dyn v) { render(flan_dev_watch_emit, v, 0, 1); } +/* And into whatever sink the caller hands over — the agent's, when the + * daemon's inspector reads a dyn word out of a stopped program's memory and + * wants its rendering as a reply rather than in the result buffer. */ +void flan_dyn_emit_to(dyn_sink w, flan_dyn v) { render(w, v, 0, 1); } + /* And into a condition's message, which flan_rt.c's sink bounds. */ void flan_msg_emit(const uint8_t *p, int64_t n); void flan_dyn_emit_msg(flan_dyn v) { render(flan_msg_emit, v, 0, 1); } diff --git a/test/programs/dev-parity.flan b/test/programs/dev-parity.flan new file mode 100644 index 00000000..1e449196 --- /dev/null +++ b/test/programs/dev-parity.flan @@ -0,0 +1,109 @@ +;;;; One global of every shape the inspector walks, for comparing two +;;;; renderings of each: the break loop's [globals], which reads the stopped +;;;; program's memory through lib/inspect.ml and compiles nothing, and an +;;;; evaluated expression naming the global, which is still rendered by a +;;;; compiled thunk through lib/render.ml. They must agree byte for byte — +;;;; the editor parses both back, and a value that read one way in the break +;;;; buffer and another at C-x C-e would be two answers to one question. +(import agent "vendor:agent") + +(defstruct Boom [why i32]) +(defstruct Point [x f32 y f32]) +(defstruct Wide [a i32 b i32 c i32 d i32 e i32 f i32 g i32 h i32 i i32 j i32]) +(defstruct In4 [v i32]) +(defstruct In3 [v In4]) +(defstruct In2 [v In3]) +(defstruct In1 [v In2]) +(defstruct In0 [v In1]) +(defstruct Enemy [hp i32 x i32]) +(defenum Colour [red 0 green 1 blue 2]) +(defdata Shape + [Empty + (Dot [x f64 y f64]) + (Rect [w i32 h i32])]) +(defunion W [p (Ptr i32) n u64]) + +(defonce small i8) +(defonce mid u16) +(defonce large u32) +(defonce huge u64) +(defonce neg i64) +(defonce ratio f32) +(defonce far f64) +(defonce odd f64) +(defonce yes bool) +(defonce byte u8) +(defonce text string) +(defonce colour Colour) +(defonce stray Colour) +(defonce some (Option Point)) +(defonce none (Option i32)) +(defonce wide Wide) +(defonce deep In0) +(defonce dot Shape) +(defonce empty Shape) +(defonce row [10 i32]) +(defonce words [u8]) +(defonce nums [i32]) +(defonce live (Ptr Enemy)) +(defonce dead (Ptr Enemy)) +(defonce nowhere (Ptr Enemy)) +(defonce un W) +(defonce anything dyn) + +;; The innermost frame names every global above, so the break loop's section +;; holds all of them; then it stops. Each is stored back to itself rather than +;; printed: a frame that prints is refused attribution today (TODO.org, "A +;; frame that prints is skipped from the globals section"), and this is about +;; the values. +(defn inner [] i64 + (set small small) (set mid mid) (set large large) (set huge huge) + (set neg neg) (set ratio ratio) (set far far) (set odd odd) (set yes yes) + (set byte byte) (set text text) (set colour colour) (set stray stray) + (set some some) (set none none) (set wide wide) (set deep deep) + (set dot dot) (set empty empty) (set row row) (set words words) + (set nums nums) (set live live) (set dead dead) (set nowhere nowhere) + (set un un) (set anything anything) + (error (Boom {.why 3})) + 0) + +(defn main [] i32 + (agent/start "/tmp/flan-dev-parity-fallback.sock") + (let [v (vec-new Enemy) + w (vec-new Enemy) + bytes (vec-new u8) + ints (vec-new i32)] + (push v (Enemy {.hp 41 .x 2})) + (push w (Enemy {.hp 7 .x 9})) + (push bytes 104) (push bytes 105) (push bytes 10) + (push ints 4) (push ints -5) (push ints 6) + (set live (addr (at v 0))) + (set dead (addr (at w 0))) + (free w) + (set words (slice bytes)) + (set nums (slice ints)) + (set small -5) + (set mid 65535) + (set large 4000000000) + (set huge (u64 -1)) + (set neg -9000000000) + (set ratio 1.25) + (set far 3.5e20) + (set odd (/ 0.0 0.0)) + (set yes true) + (set byte 97) + (set text "a\"b\\c\nd\te") + (set colour :blue) + (set some (Some (Point {.x 1.5 .y -2.5}))) + (set wide (Wide {.a 1 .b 2 .c 3 .d 4 .e 5 .f 6 .g 7 .h 8 .i 9 .j 10})) + (set deep (In0 {.v (In1 {.v (In2 {.v (In3 {.v (In4 {.v 5})})})})})) + (set dot (Shape.Dot {.x 0.5 .y 2})) + (set empty Shape.Empty) + (set (at row 0) 11) + (set (at row 9) 99) + (set un (W {.n 12})) + (set anything {:s "kept" :n 1}) + (print (inner)) (println "")) + (dotimes [i 4000] + (agent/wait 5)) + 0) diff --git a/test/test_dev.ml b/test/test_dev.ml index fa86db9c..cf615cff 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -6247,6 +6247,106 @@ let () = end; List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ isock; iout ]; + (* ── The inspector's reader against the compiled renderer ────────── *) + + (* The break loop reads a value out of the stopped program's memory + through lib/inspect.ml and compiles nothing; an evaluated expression is + still rendered by a compiled thunk through lib/render.ml. The two are + separate walks over the same arms, so this asks both about one global + of every shape and wants the same text — on both backends, because the + offsets the reader uses are [Emit.lay]'s and a backend that laid a + value out any other way would read differently here first. *) + List.iter + (fun backend -> + let psock = tmp ("parity" ^ backend ^ ".sock") + and pout = tmp ("parity" ^ backend ^ ".out") in + (try Sys.remove psock with Sys_error _ -> ()); + let pfd = + Unix.openfile pout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 + in + let ppid = + Unix.create_process flan + [| flan; "dev"; "programs/dev-parity.flan"; "-s"; psock; backend |] + Unix.stdin pfd Unix.stderr + in + Unix.close pfd; + if not (listening ~pid:ppid psock) then begin + fail "the %s parity daemon %s" backend !listen_why; + (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect psock in + let said r = Option.value ~default:"" (Wire.string_field r "message") in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + if not (await (fun () -> stopped (request c "(:op \"describe\")"))) then + fail "the %s parity program never stopped" backend + else begin + let r = request c "(:op \"globals\")" in + let rows = + match Wire.field r "globals" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List ({ Form.v = Form.Str n; _ } :: _ + :: { Form.v = Form.Str v; _ } :: _) -> + Some (n, v) + | _ -> None) + l + | _ -> [] + in + (* And nothing was built to answer it, which is the point: a + read used to be a module per request, named for its verb in + the session's directory. *) + let r2 = request c "(:op \"locals\" :frame 1)" in + let dir = + Filename.concat (Filename.get_temp_dir_name ()) + (Printf.sprintf "flan-dev-%d" ppid) + in + let built = + try + List.filter + (fun f -> + Filename.check_suffix f ".so" + && String.length f > 1 + && (f.[0] = 'g' || f.[0] = 'l') + && f.[1] >= '0' && f.[1] <= '9') + (Array.to_list (Sys.readdir dir)) + with Sys_error _ -> [] + in + if built <> [] then + fail "%s: reading globals and locals built %s" backend + (String.concat " " built); + if status r2 <> "ok" then fail "%s parity locals: %s" backend (said r2); + if status r <> "ok" then fail "%s parity globals: %s" backend (said r) + else if List.length rows <> 27 then + fail "%s parity: %d globals came back, not 27: %s" backend + (List.length rows) (String.concat " " (List.map fst rows)) + else + List.iter + (fun (n, v) -> + let e = + request c + (Printf.sprintf "(:op \"eval-expr\" :code %S)" n) + in + match Wire.string_field e "value" with + | Some ev when ev = v -> () + | got -> + fail "%s: %s reads %S in the break loop and %S evaluated" + backend n v (Option.value ~default:(said e) got)) + rows + end; + ignore (request c "(:op \"close\")"); + (try Unix.close c with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ()) + end; + List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ psock; pout ]) + [ "--llvm"; "--x86" ]; + (* ── What a half-finished assignment looks like from the break ────── *) (* A condition signalled from inside the value being assigned stops the diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 47aae148..2092b10c 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -37,6 +37,10 @@ * with nc. */ +/* For process_vm_readv, the one call [peek] reads through. */ +#if defined(__linux__) && !defined(_GNU_SOURCE) +#define _GNU_SOURCE +#endif #include #include #include @@ -52,6 +56,7 @@ #include #include #if defined(__linux__) +#include #include #endif @@ -115,6 +120,18 @@ int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, int64_t *typelens, int64_t cap, int64_t *unread); int flan_dev_reg_enabled(void); int flan_dev_reg_overflowed(void); +/* The inspector's two questions about a pointer, asked here by the daemon + * rather than from inside a compiled thunk: whether it may be followed, and + * what died at it. And a global the program introduced after it started, + * which has storage in flan_dev.c's table and no symbol. */ +int32_t flan_dev_reg_live(const void *p); +int32_t flan_dev_reg_epitaph(const void *p, char *buf, int64_t cap); +void *flan_dev_global_find(const char *name); +/* A dyn word's rendering, into a sink of the caller's. Weak: flan_dyn.c is + * linked only into a program that uses a dyn operation, and a program with no + * dyn value has nothing to ask it about. */ +void flan_dyn_emit_to(void (*w)(const uint8_t *, int64_t), uint64_t v) + __attribute__((weak)); void flan_free_temp(void); void *flan_temp_scratch_begin(void); void flan_temp_scratch_end(void *prev); @@ -680,12 +697,11 @@ void *flan_agent_frame_slot(int64_t frame, int64_t slot) { return flan_dev_frame_slot(s->fframe[frame], (int32_t)slot); } -/* The condition this break holds, for the render thunk the daemon builds to - * show its fields. Same contract as [flan_agent_frame_slot]: called on the - * stopped game thread, resolved against the snapshot on top *when the thunk - * runs*, NULL for a break that carries none — and the daemon delivers the - * thunk at-stop, so a resume between the asking and the running drops it - * rather than rendering one break's type over another break's pointer. */ +/* The condition this break holds, for the daemon's [cond-at] to show its + * fields: resolved against the snapshot on top, NULL for a break that carries + * none. The daemon checks the stop generation either side of its read, so a + * resume in between is refused rather than one break's type being read over + * another break's pointer. */ void *flan_agent_condition(void) { snapshot *s = snap_top(); return s == NULL ? NULL : s->cond; @@ -1479,6 +1495,19 @@ static void reply_unarmed(sink *o, snapshot *s, int32_t i) { static pthread_mutex_t request_lock = PTHREAD_MUTEX_INITIALIZER; +/* Where [dyn]'s rendering collects. Static, because [request_lock] makes + * that verb one caller at a time, and the renderer's sink is a bare function + * with nowhere to carry a pointer. Longer than any rendering the daemon keeps: + * it cuts every value at the result buffer's size. */ +static char dyn_text[8192]; +static size_t dyn_text_len; +static void dyn_text_put(const uint8_t *p, int64_t n) { + size_t k = n < 0 ? 0 : (size_t)n; + if (k > sizeof dyn_text - dyn_text_len) k = sizeof dyn_text - dyn_text_len; + memcpy(dyn_text + dyn_text_len, p, k); + dyn_text_len += k; +} + static void handle_line(char *line, sink *o) { /* The one verb that is not a module: read back the value of the last * expression evaluated, with the counter that says whether it is a new @@ -1837,7 +1866,7 @@ static void handle_line(char *line, sink *o) { * a C identifier-ish string the program passed — and the value cannot * contain a raw tab or newline, because everything that reaches it goes * through an emitter that escapes both. So no framing is needed beyond - * this, which is the same bet render_locals makes on the same grounds. + * this, which is the same bet the locals reader makes on the same grounds. * * A header first: the count actually written, and how many names were * whether any name ever found no slot, so an overflow is reported rather @@ -1910,6 +1939,154 @@ static void handle_line(char *line, sink *o) { if (k > 0) emit(o, hdr, (size_t)k); return; } + /* ── Reading a stopped program's memory ───────────────────────────── + * + * The daemon's inspector reads values itself, through the type layouts it + * compiled, instead of building a thunk per inspection for the program to + * run. These verbs are everything it needs from this side: where a root is + * ([slot], [cond-at], [global]), the bytes at an address ([peek]), the + * registry's answer about a pointer ([ptr]), and a dyn word's rendering + * ([dyn]), which only the runtime can give because the tag is its to read. + * + * Stopped only, all of them. What makes reading another thread's memory + * sound is that the thread is not writing it, and a break is the moment + * that is promised. */ + if (strncmp(line, "slot ", 5) == 0 || strcmp(line, "cond-at") == 0 + || strncmp(line, "global ", 7) == 0 || strncmp(line, "peek ", 5) == 0 + || strncmp(line, "ptr ", 4) == 0 || strncmp(line, "dyn ", 4) == 0) { + if (!(atomic_load(&depth) > 0)) { + reply(o, "err not stopped: a running program's memory is being written " + "as it is read\n"); + return; + } + } + /* "slot F I" — the address of slot I of frame F, against the snapshot on + * top, which is what [flan_agent_frame_slot] answers a thunk. Null for a + * slot not yet bound, and that is refused rather than answered. */ + if (strncmp(line, "slot ", 5) == 0) { + char *end = NULL, *end2 = NULL; + long long f = strtoll(line + 5, &end, 10); + long long i = end != line + 5 ? strtoll(end, &end2, 10) : 0; + void *p; + char b[48]; + if (end == line + 5 || end2 == end) { + reply(o, "err slot wants a frame and a slot index\n"); + return; + } + p = flan_agent_frame_slot((int64_t)f, (int64_t)i); + if (p == NULL) { reply(o, "err no such slot, or it is not bound yet\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "cond-at" — where the condition this break holds is. [-] for none. */ + if (strcmp(line, "cond-at") == 0) { + void *p = flan_agent_condition(); + char b[48]; + if (p == NULL) { reply(o, "-\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "global SYM" — a global's storage, by its mangled symbol. A global the + * program introduced after it started lives in flan_dev.c's table and has + * no symbol; one it was built with is a symbol of the executable, which a + * redefinition module already binds to by name, so it is exported. */ + if (strncmp(line, "global ", 7) == 0) { + const char *name = line + 7; + void *p = flan_dev_global_find(name); + char b[48]; + if (p == NULL) { + void *self = dlopen(NULL, RTLD_LAZY); + if (self != NULL) p = dlsym(self, name); + } + if (p == NULL) { reply(o, "err no global by that symbol\n"); return; } + snprintf(b, sizeof b, "ok %llu\n", (unsigned long long)(uintptr_t)p); + reply(o, b); + return; + } + /* "peek ADDR LEN" — LEN bytes at ADDR, as hex. + * + * Through process_vm_readv on this process rather than a memcpy, so that an + * address that is not mapped is an [err] and not a fault: a slice whose + * storage has gone reads as garbage, and a fault here would take the + * program — and in one process, the daemon — down with it. */ + if (strncmp(line, "peek ", 5) == 0) { + char *end = NULL, *end2 = NULL; + unsigned long long a = strtoull(line + 5, &end, 0); + long long n = end != line + 5 ? strtoll(end, &end2, 10) : 0; + unsigned char *buf; + static const char hex[] = "0123456789abcdef"; + if (end == line + 5 || end2 == end || n < 0 || n > 65536) { + reply(o, "err peek wants an address and a length of at most 65536\n"); + return; + } + if (a == 0) { reply(o, "err unreadable\n"); return; } + buf = malloc(n > 0 ? (size_t)n : 1); + if (buf == NULL) { reply(o, "err out of memory\n"); return; } +#if defined(__linux__) + { + struct iovec local = { buf, (size_t)n }; + struct iovec remote = { (void *)(uintptr_t)a, (size_t)n }; + if (n > 0 + && process_vm_readv(getpid(), &local, 1, &remote, 1, 0) != (ssize_t)n) { + free(buf); + reply(o, "err unreadable\n"); + return; + } + } +#else + memcpy(buf, (const void *)(uintptr_t)a, (size_t)n); +#endif + reply(o, "ok "); + for (long long k = 0; k < n; k++) { + char two[2] = { hex[buf[k] >> 4], hex[buf[k] & 15] }; + emit(o, two, 2); + } + reply(o, "\n"); + free(buf); + return; + } + /* "ptr ADDR" — may this pointer be followed: [live], [dead] and what died + * there, or [none] for an address the registry never saw. The renderer's + * [reg-live] and [reg-emit], asked from here. */ + if (strncmp(line, "ptr ", 4) == 0) { + char *end = NULL; + unsigned long long a = strtoull(line + 4, &end, 0); + char desc[192]; + int32_t n; + const void *p = (const void *)(uintptr_t)a; + if (end == line + 4) { reply(o, "err ptr wants an address\n"); return; } + if (flan_dev_reg_live(p)) { reply(o, "live\n"); return; } + n = flan_dev_reg_epitaph(p, desc, (int64_t)sizeof desc); + if (n <= 0) { reply(o, "none\n"); return; } + reply(o, "dead"); + emit(o, desc, (size_t)n); + reply(o, "\n"); + return; + } + /* "dyn WORD" — the rendering of one dyn value, as hex. The walk that takes + * a dyn apart is the runtime's, so the daemon hands it the word. */ + if (strncmp(line, "dyn ", 4) == 0) { + char *end = NULL; + unsigned long long w = strtoull(line + 4, &end, 0); + static const char hex[] = "0123456789abcdef"; + if (end == line + 4) { reply(o, "err dyn wants a word\n"); return; } + if (flan_dyn_emit_to == NULL) { + reply(o, "err this program has no dyn runtime linked\n"); + return; + } + dyn_text_len = 0; + flan_dyn_emit_to(dyn_text_put, (uint64_t)w); + reply(o, "ok "); + for (size_t k = 0; k < dyn_text_len; k++) { + unsigned char c = (unsigned char)dyn_text[k]; + char two[2] = { hex[c >> 4], hex[c & 15] }; + emit(o, two, 2); + } + reply(o, "\n"); + return; + } if (strcmp(line, "result") == 0) { uint64_t gen = 0, len = 0; uint64_t cap = flan_dev_result_cap();