diff --git a/BUILT.md b/BUILT.md index e7a617c..304dd2e 100644 --- a/BUILT.md +++ b/BUILT.md @@ -4802,9 +4802,78 @@ the heap tier, the arena tier and the pool tier; a release build answers 0 to ev the two expectations *is* the assertion, and writing it as one program means nobody can change what a dev build does without the release row noticing. -The inspector's pointer arm is **not** covered. `test/programs/dev-ptr.flan` is the program, its header carries the -two lines above, and they were read off a running session by hand — the `test_dev.ml` case that would drive it belongs -to another lane's file. `NEXT.md` says so rather than letting the verification read as automated. +`test/programs/dev-ptr.flan` covers the inspector's pointer arm, and it is driven now rather than read by hand. Its +header still carries the two lines a session answers with; `test_dev.ml`'s *"a pointer the registry knows about"* case +asserts the live one whole and the dead one **around** its step number, which is the registry's event counter and +moves if anything allocates ahead of that program. It also asserts that no address appears in the epitaph — an +assertion that would otherwise depend on where the heap landed, which is the point of leaving one out. + +## An address you have in your hand + +The table above is the *recording* side. This is what reads it, and it is three things that turned out to be one +thing: pointing at a bare address, a breakdown by type, and what is still held. + +### The recorded name, back to a type + +The table records a **string**, and it has to. The note is built in `check.ml` at the allocation site, where the +concrete element type exists, and what crosses into the runtime is bytes — an ABI carrying a type would be an ABI that +had to agree with the checker's representation of one, which is the coupling the whole no-header-no-tag-word design +refuses. + +What closes it is that the string is not a *description*. It is `Types.to_string` of the type, which is the **source +spelling** — `check.ml`'s `reg_note` says so, as the reason the name is worth printing at all — so the round trip is +the language's own reader, its own `Parse.texpr`, and the session's own `Check.resolve`. `Enemy` resolves against the +structs this session holds; `(Vec i32)` rebuilds through `Tapp`; `[3 i32]` through `Tarray`. **No table of spellings +is written down anywhere**, so nothing can fall behind `Types.to_string`. + +And it is allowed to **fail**, which matters more than it looks. Not every recorded name is a type: `flan_rt.c` notes +a pool's slot headers as `"pool slots"`, because after a `free-all` an address landing in them must not come back as +an element. That string is not Flan source and must not become one, so a name that does not resolve is refused with +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. + +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. + +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, +because rendering the element type there shows one element's tail as another's head, which is a plausible-looking +answer and therefore the worst kind; and a running program, because live-or-dead is exactly what a running program is +changing. A named `:type` overrides all of the first two — overriding is the point of being able to say it — and the +reply carries `:recorded` whenever the table had a name, so the disagreement is never silent. + +**No `:path`.** A path steps from the pointee, and the pointee is what the registry has only just been asked to bless. +The whole answer here is the branch. + +### One walk, two questions, and what "at exit" means + +`flan_dev_reg_by_type` is the group-by, and there is one of it: a leak report **is** a breakdown with the dead left +out, and two walks would drift. Formatting is in the agent and ordering is in the daemon — biggest first, by bytes, +because a breakdown in table order is a list of everything and answers nothing. + +**"At exit" is not a hook, and the honest reason is that a game is killed.** A program stopped by a signal runs no +`atexit` handler, no destructor, nothing — so no code written inside the program could report anything about the run +that matters most. The authoritative reader is therefore `(:op "leaks")`, which reads the same table over the agent +socket and can be asked at any moment, including the one before the kill. `flan-dev.el` does not ask on teardown +either: that would put a request on a path that runs every time the editor closes, for an answer nobody asked for. + +The hook exists for the other program — the one that returns from `main` — and it is two decisions: + +- **Registered by `atexit` from inside `flan_dev_reg_enable`**, not a file-scope `__attribute__((destructor))`. This + file is compiled into *every* build, so a destructor would run in a release build too, and that is exactly the third + place a release build is not free. Registered where it is, a release binary still carries a null pointer, a zero + flag and the declarations. +- **Off unless `FLAN_DEV_LEAKS` is set.** The acceptance table reads `programs/registry.flan`'s output with stderr + folded in, so a report nobody asked for is a report that changes what a dev build prints. ## A restart is not a transaction Written down in three places rather than fixed, because it is a property and not a defect. If a frame mutates a global diff --git a/NEXT.md b/NEXT.md index 4eeb59e..890d516 100644 --- a/NEXT.md +++ b/NEXT.md @@ -461,46 +461,31 @@ re-applied. This matters more here than in most Lisps because the intended use is a **game loop**, where the author's plan is to skip a frame and carry on rather than die — exactly the case where a non-idempotent mutation bites. -## ~~Queued: a dev-build allocation registry~~ — **landed, in part; three of the six remain** -## Queued: a dev-build allocation registry — address to type +## ~~Queued: a dev-build allocation registry~~ — **landed; one item left, and it is not a registry item** -Built. The table is in `runtime/flan_dev.c`, the note is emitted by `check.ml` and dropped by `emit.ml` in a release -build, and the inspector reads it. `BUILT.md`'s *"An address answers with a type"* is the account of it; what follows -is only what is **not** there, so that the gap is a queue entry rather than a discovery. +Items 1 to 5 are built and the test is written. `BUILT.md`'s *"An address answers with a type"* is the account of the +table, the note and the inspector's pointer arm; *"An address you have in your hand"* is the account of the reader — +the address root, the breakdown, the leak report, and what "at exit" turned out to mean. -**Landed:** items 1 and 2 — the inspector follows a live `(Ptr T)` and renders the pointee, and names what died at a -dead one (``). The dead-marking covers the heap `free`, a heap resize's old -block, an arena `free-all` and `arena-destroy`. - -**Left, and in this order:** - -- **Item 3, point at any heap address.** The lookup is there and answers for any address; nothing exposes it as an - editor op. It wants a verb beside `inspect` that takes an address and a type rather than a frame and a slot, and the - registry's own answer for the type when none is given — which needs the recorded name resolved back to a - `Types.t`, and the table records a string. -- **Item 4, a breakdown by type**, and **item 5, leak attribution at exit.** Both are a walk over the table and a - group-by; `flan_dev_reg_count` is the whole of what exists. Neither is hard and neither has a reader yet, which is - why they were left rather than half-built. -- **The memcheck half of item 6.** The registry now knows an arena's `free-all` killed everything in the region, so a - later read through a pointer into it is *answerable*. Memcheck still says nothing, because nothing told it: the - pages stay mapped and `free-all` is an integer going to zero inside one allocation. Closing that is - `VALGRIND_MAKE_MEM_UNDEFINED` in `flan_arena_proc`, which `test/test_valgrind.ml` already names. **The two must not - be blurred** — the registry answer and the memcheck answer are different tools reaching different people. -- **A test that drives the inspector's pointer arm.** `test/programs/dev-ptr.flan` is the program and its header has - the two lines a session answers with; they were read off a running session **by hand**. The case belongs beside the - other `locals`/`inspect` cases in `test_dev.ml`, which was another lane's file. `programs/registry.flan` covers the - table itself from the acceptance table, in a dev build and a release one. +**Left:** **the memcheck half of item 6, and nothing else.** The registry knows an arena's `free-all` killed +everything in the region, so a later read through a pointer into it is *answerable*. Memcheck still says nothing, +because nothing told it: the pages stay mapped and `free-all` is an integer going to zero inside one allocation. +Closing that is `VALGRIND_MAKE_MEM_UNDEFINED` in `flan_arena_proc`, which `test/test_valgrind.ml` already names. +**The two must not be blurred** — the registry answer and the memcheck answer are different tools reaching different +people, and building one is not progress on the other. **What it does not cover, and does not need to:** stack locals and globals, which the shadow stack and the static type table already answer by name. A stack address is deliberately not in the table, and a pointer to one still renders -``. +`` — the address root refuses such an address by name rather than rendering bytes at it. **Note on classes:** `defclass` instances will carry shape metadata by design, so they get identification for free and do not need the registry. This is for plain structs, `Vec`, `Map` and pool storage. **On cost, as built.** One insert per allocation, always on in a dev build, no opt-out — the author's instruction, followed literally. Nothing was built per-region, no range recording, no per-allocator opt-out. Revisit only if a real -program shows a problem, and `BUILT.md` names the two places a release build is not quite free. +program shows a problem, and `BUILT.md` still names **two** places a release build is not quite free: the readers +added since are functions nothing in a release build calls, and the exit report is registered by `atexit` from inside +`flan_dev_reg_enable` rather than by a file-scope destructor, precisely so that it is not a third. ## Picked up first, 2026-09-13 diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index c7613c1..6cd04f1 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -230,9 +230,9 @@ is harmless, but the expression itself need not be: if you inspect `(spawn-enemy)`, you spawn one per keystroke. That is why there is no auto-refresh and why `g` is a key you press rather than a timer. -### Two ways to root a walk +### Three ways to root a walk -There are two, they are not equally capable, and the top line of the buffer +There are three, they are not equally capable, and the top line of the buffer says which one you are on. **An expression** — `C-c C-i`, and `i` on a global line in the break buffer. @@ -250,8 +250,33 @@ program, and it is refused — by name, with the reason — once the program resumes or if the frame's body was redefined since the frame was entered. It cannot start from an expression at all. -Neither subsumes the other, which is why both are here. The one you get is -chosen for you by the line you press `i` on. +**An address** — `M-x flan-inspect-address`. A number, `#x7f…` or decimal, of +the kind a debugger, a valgrind report or a C shim's `printf` hands you. There +is no frame in it and no expression: what it shows is the `(Ptr T)` at that +address, followed if the storage is still live and an epitaph naming what died +there if it is not. + +**The type is optional, and leaving it out is the point.** A dev build records +the type at every allocation — the allocator's caller knew it, and a Flan value +carries no header, so that is the only moment anything could — and this command +is the one place that recorded name is read back and turned into a type again. +Naming a type overrides it, for reading half a struct or an element the table +recorded under a container's name; the reply still carries what the allocator +wrote down, so you are never shown one type while the program believes another. + +It needs a **stopped** program, for a reason of its own: whether an address is +still live is exactly what a running program is changing. And it takes **no +path** — `RET` does not go into it — because the whole answer is the pointer +arm's branch, and stepping in would step from the pointee, which is the deref +the registry has only just been asked to bless. + +An address the registry has never seen is refused by name rather than +rendered. That is a stack local, a global, or a pointer from C; the first two +are answered by name in the stack and globals sections already. + +None of the three subsumes the others, which is why all three are here. The +one you get is chosen for you by the line you press `i` on, or by starting an +address root by hand. **`l` never crosses between them**, and that is structural rather than a rule someone has to remember. Every entry on the buffer's stack carries its own @@ -259,6 +284,28 @@ root; `RET` only ever lengthens the path under the root already in hand; and starting a new root starts an empty stack. So a stack with both kinds in it cannot be built, and `l` has nothing to cross into. +### Where the memory went — `M-x flan-allocations` and `M-x flan-leaks` + +The same registry, read as a table rather than at one address. **`M-x +flan-allocations`** is every block it recorded, live and dead both, grouped by +the type the allocator's caller named and ordered biggest first by bytes. The +dead are in it on purpose: in a long-running program they are the bulk of it, +and they are what says where the allocation *went* rather than only where it +stayed. + +**`M-x flan-leaks`** is the same walk with the dead left out — what the program +is still holding. + +**"Still holding" means at the moment you ask, and there is no exit report to +wait for.** A program killed by a signal, which is how a program under this +editor usually ends, runs no exit handler at all, so nothing written inside it +could report anything. Asking is the answer, and you can ask at any time +including just before you quit. A program that returns from `main` on its own +can print the same breakdown to stderr by being run with `FLAN_DEV_LEAKS` set +— off by default, because a dev build's output belongs to the program. + +Both are dev-build only. A release build records nothing and says so. + ### The watch buffer — values while the program runs Everything above is for a program you have stopped, or one you interrupt with a @@ -535,8 +582,10 @@ Use `C-c C-g` if you need frames. | `M-.` / `M-,` | where a name is written / back | Commands with no key: `M-x flan-dev` (start a program), `M-x flan-dev-quit` -(stop it), `M-x flan-watch` (the watch buffer), `M-x flan-watch-stop`, and -`M-x flan-watch-ghost-mode` (the same values inline). +(stop it), `M-x flan-watch` (the watch buffer), `M-x flan-watch-stop`, +`M-x flan-watch-ghost-mode` (the same values inline), +`M-x flan-inspect-address` (what is at an address), and `M-x flan-allocations` +/ `M-x flan-leaks` (where the memory went, and what is still held). --- diff --git a/emacs/flan-dev.el b/emacs/flan-dev.el index 4c91f22..d128a05 100644 --- a/emacs/flan-dev.el +++ b/emacs/flan-dev.el @@ -1657,5 +1657,80 @@ that the IR half is findable by name rather than only by a modifier." nil t)))) (flan-disassemble name t)) +;;; What the program is made of, and what it is still holding + +;; Two readings of one table. A dev build records the type at every +;; allocation — the allocator's caller knew it, and a Flan value carries no +;; header, so that is the only moment anything could — and this is that table +;; grouped by the name it wrote down. +;; +;; Biggest first, by bytes. Read in table order it is a list of everything +;; and answers nothing; read biggest-first it answers "where did the memory +;; go", which is the only reason either command exists. + +(defcustom flan-allocations-buffer "*flan-allocations*" + "Where the allocation breakdown and the leak report are shown." + :type 'string) + +(defun flan-allocations--show (op title) + "Ask the daemon for OP and show its rows under TITLE." + (let ((r (flan-dev--request (list :op op)))) + (unless (equal (plist-get r :status) "ok") + (user-error "flan: %s" (or (plist-get r :message) "refused"))) + (let ((rows (plist-get r :types)) + (blocks (plist-get r :blocks)) + (bytes (plist-get r :bytes))) + (with-current-buffer (get-buffer-create flan-allocations-buffer) + (let ((inhibit-read-only t)) + (erase-buffer) + (special-mode) + (insert (propertize (format "%s\n" title) 'face 'bold)) + (insert (propertize (format "%s\n\n" (or (plist-get r :note) "")) + 'face 'font-lock-comment-face)) + ;; An overflowed table has blocks in the program that are in + ;; nobody's row, so every number below it is a floor. Said before + ;; the numbers, not after them, because a reader who missed it would + ;; quote them as counts. + (when (plist-get r :overflow) + (insert (propertize + "the registry overflowed: these are floors, not counts\n\n" + 'face 'warning))) + (if (null rows) + (insert "nothing recorded\n") + (insert (propertize (format "%8s %12s %s\n" "blocks" "bytes" "type") + 'face 'shadow)) + (dolist (row rows) + (insert (format "%8d %12d %s\n" (nth 1 row) (nth 2 row) + (nth 0 row)))) + (insert (propertize + (format "\n%8s %12s in %d type%s\n" (or blocks 0) + (or bytes 0) (length rows) + (if (= (length rows) 1) "" "s")) + 'face 'shadow)))) + (goto-char (point-min))) + (display-buffer flan-allocations-buffer)))) + +;;;###autoload +(defun flan-allocations () + "Every block the allocation registry recorded, grouped by type. +Live and dead both: in a long-running program the dead are the bulk of it, and +they are what says where the allocation went rather than only where it +stayed. A dev build only — a release build records nothing, and says so." + (interactive) + (flan-allocations--show "allocations" "Allocations, by type")) + +;;;###autoload +(defun flan-leaks () + "What the allocation registry is still holding live, grouped by type. + +The same walk with the dead left out, and \"still holding\" means at the moment +you ask. There is no exit report to wait for: a program killed by a signal — +which is how a program under this editor usually ends — runs no handler at +all, so this command, asked whenever you like and including just before you +quit, is what answers for one. A program that returns from main on its own +can print the same breakdown to stderr under FLAN_DEV_LEAKS." + (interactive) + (flan-allocations--show "leaks" "Still held, by type")) + (provide 'flan-dev) ;;; flan-dev.el ends here diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index 1475c28..c1989bd 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -297,10 +297,19 @@ whatever the value came from." ;;; A root, and the path walked from it -;; A root is `(:expr EXPR)' or `(:slot FRAME SLOT NAME)'. The path is a list -;; of steps applied to it in order, and the pair is the whole of this buffer's -;; position — which is why a stack entry carries both and `l' cannot cross -;; between two kinds of root by accident. +;; A root is `(:expr EXPR)', `(:slot FRAME SLOT NAME)' or `(:addr N TYPE)'. +;; The path is a list of steps applied to it in order, and the pair is the +;; whole of this buffer's position — which is why a stack entry carries both +;; and `l' cannot cross between two kinds of root by accident. +;; +;; The third one has no frame in it. An expression root is evaluated wherever +;; the evaluator stands and a slot root is a frame and an index; an address +;; root is a number somebody has in their hand, out of a debugger or a +;; valgrind report, and the daemon asks the allocation registry what is there. +;; It takes no path: what it renders is a `(Ptr T)', so the whole answer is +;; the pointer arm's branch — followed if the storage is live, an epitaph if +;; it is not — and stepping in would be stepping from the pointee, which is +;; the deref the registry has only just been asked to bless. (defun flan-inspect--root-label (root path) "How ROOT walked by PATH is named at the top of the buffer and in the trail." @@ -316,6 +325,11 @@ whatever the value came from." (`(:some) ".some") (_ ""))) path ""))) + ;; The address in hex, because that is the spelling every tool that hands + ;; one out uses, and the type only when it was *named*: an unnamed one is + ;; the registry's own answer and the reply's own `:type' line says it. + (`(:addr ,addr ,ty) + (if ty (format "#x%x as %s" addr ty) (format "#x%x" addr))) (_ "?"))) ;;; Why a thing cannot be entered @@ -561,6 +575,17 @@ root exists to fix." (when path (list :path (mapcar #'flan-inspect-wire-step path)))))) + (`(:addr ,addr ,ty) + (when path + ;; Refused rather than dropped. A path with a step silently + ;; gone would render a *different* value and say nothing, + ;; which is the failure this whole buffer is built to avoid. + (user-error + "flan: an address root has no path; it renders the pointer, \ +and whether that may be followed is the answer")) + (funcall flan-inspect-request-function + (append (list :op "at" :addr addr) + (when ty (list :type ty))))) (_ (user-error "flan: %S is not a root this inspector knows" root))))) (unless (equal (plist-get r :status) "ok") (user-error "flan: %s" (or (plist-get r :message) "refused"))) @@ -613,6 +638,36 @@ the listing picks one out. The index is what `locals\=' puts on every line for this." (flan-inspect--show (list :slot frame slot name) nil nil)) +(defvar flan-inspect-address-history nil + "Addresses `flan-inspect-address\=' has been given, most recent first.") + +;;;###autoload +(defun flan-inspect-address (addr &optional type) + "Show what is at ADDR in the stopped program, as TYPE. + +The address root. ADDR is a number — `#x7f…\=', or decimal — of the kind a +debugger, a valgrind report or a C shim\='s printf hands you, and which nothing +inside Flan will make for you: there is no integer-to-pointer cast in the +language, deliberately. + +TYPE is optional, and leaving it out is the interesting half. A dev build +records the type at every allocation, so the registry already knows what was +put there and the daemon resolves that recorded name back to a type. Naming +one instead overrides it — for reading half a struct, or an element the table +recorded under a container\='s name — and the reply still carries what the +allocator wrote down, so the disagreement is never silent. + +Refused while the program is running: whether an address is still live is +exactly what a running program is changing." + (interactive + (list (read-number "Address: " + (car (mapcar #'string-to-number + flan-inspect-address-history))) + (let ((s (read-string "As type (empty for what was recorded): "))) + (and (not (string-empty-p s)) s)))) + (add-to-history 'flan-inspect-address-history (number-to-string addr)) + (flan-inspect--show (list :addr addr type) nil nil)) + (defun flan-inspect-into () "Go into the field or element at point. Extends the path under the root this buffer already has; it never replaces the diff --git a/lib/dev.ml b/lib/dev.ml index 52207ba..10e4b9c 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -1032,6 +1032,372 @@ let inspect t ~frame ~slot ~path = ":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ])) +(* ── The allocation registry, read from this end ───────────────────── *) + +(* [BUILT.md]'s "An address answers with a type" is what the table is and why. + What follows is the reader: three verbs that ask the agent for what is + recorded, and one of them turns a recorded *name* back into a type. + + Nothing here is emitted and nothing here is in a release build. A release + binary's table is a null pointer, so every one of these comes back with the + agent saying the registry is off — which is an answer, and is the same + answer [programs/registry.flan]'s release row asserts. *) + +type reg_entry = + { rlive : bool; + roff : int; (* how far into the block the address lands *) + rbytes : int; (* the block's extent *) + relem : int; (* one element, or 0 where the block is not an array *) + rseq : int; (* when it was recorded *) + rdied : int; (* when it was released, or 0 while it is live *) + rtype : string } (* the Flan spelling the compiler wrote beside the call *) + +(* [reg at ADDR] answers one of three things and they are three different + facts: a row, "never heard of it", or "there is no table". Kept apart here + rather than collapsed into an option, because an address the registry never + saw is a stack local or a pointer from C — a perfectly good address with no + entry — and a release build is a build that records nothing about any + address at all. A caller that could not tell them apart would report the + second as the first. *) +let reg_at t ~addr : (reg_entry option, string) result = + match request t (Printf.sprintf "reg at %d" addr) with + | exception Unix.Unix_error (e, _, _) -> + Error ("cannot reach the program: " ^ Unix.error_message e) + | text -> + let line = String.trim (List.hd (String.split_on_char '\n' text)) in + if line = "none" then Ok None + else if String.length line > 4 && String.sub line 0 4 = "err " then + Error (String.sub line 4 (String.length line - 4)) + else + (* "ok LIVE OFF BYTES ELEM SEQ DIED\tTYPE". The type is last and behind + a tab because a spelling holds spaces — "(Vec i32)" — and nothing + else on the line does. *) + (match String.index_opt line '\t' with + | None -> Error ("the program answered " ^ line) + | Some tab -> + let head = String.sub line 0 tab + and ty = String.sub line (tab + 1) (String.length line - tab - 1) in + (match String.split_on_char ' ' head with + | [ "ok"; live; off; bytes; elem; seq; died ] -> + (match List.map int_of_string_opt [ live; off; bytes; elem; seq; died ] with + | [ Some live; Some off; Some bytes; Some elem; Some seq; Some died ] -> + Ok (Some { rlive = live <> 0; roff = off; rbytes = bytes; + relem = elem; rseq = seq; rdied = died; rtype = ty }) + | _ -> Error ("the program answered " ^ line)) + | _ -> Error ("the program answered " ^ line))) + +(* The recorded name, back to a [Types.t]. + + This is the one thing item 3 needed that nothing else in the registry did, + and the whole of the difficulty is that **the table records a string**. It + has to: the note is built in [check.ml] at the allocation site, where the + concrete type exists, and what crosses into the runtime is bytes — an + [ABI] that carried a type would be an ABI that had to agree with the + checker's representation of one, which is the coupling the whole + no-header-no-tag-word design refuses. + + What closes it is that the string is not a description. It is + [Types.to_string] of the type, which is the *source spelling* — that is + said in [check.ml]'s [reg_note] as the reason the name is worth printing at + all — so the round trip is the language's own reader, the language's own + type-expression parser, and the session's own resolver. `Enemy' resolves + against the structs this session holds, `(Vec i32)' rebuilds through + [Tapp], `[3 i32]' through [Tarray]. No table of spellings is written down + anywhere, so nothing can fall behind [Types.to_string]. + + And it is allowed to fail, which matters more than it looks. Not every + recorded name is a type: [flan_rt.c] notes a pool's slot headers as + "pool slots", because after a free-all an address landing in them must not + come back as an element. That string is not Flan source and must not + become one — so a name that does not resolve is refused with the name + quoted, and never defaulted to bytes. *) +let type_of_spelling t spelling : (Types.t, string) result = + let refuse why = + Error + (Printf.sprintf "%s is not a type this session can resolve: %s" + (Wire.quote spelling) why) + in + match Reader.read_all ~file:"" spelling with + | exception Loc.Error { Loc.dmsg = why; _ } -> refuse why + | [] -> refuse "there is nothing in it" + | _ :: _ :: _ -> refuse "it is more than one form" + | [ f ] -> + (match Check.resolve t.session.Session.env (Parse.texpr f) with + | 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.Int Types.U8) } + +(* 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; + 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 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.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 = []; 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 + let ir = + Emit.redefinition ~dev:true ~debug:s.Session.debug ~known:(Session.known s) + ~call:name program ~fns:[ name ] + in + Ok { Session.ir; names = []; fns = []; installs = true } + +(* [(:op "at" :addr N :type "Enemy")] — point at any heap address. + + The inspector's third rooting mode, and the one that needs no frame. + [locals] and [inspect] root at a frame and a slot, which is the address the + shadow stack knows and the type [Tast.fn.slots] knows. This roots at an + address somebody has in their hand — out of a C debugger, out of a printed + [Ptr], out of a leak report — and there is no frame to read a type off. + + **So the type comes from the registry when it is not given**, which is what + the table was carrying a string for all along and what nothing had yet + read. See [type_of_spelling] for how the string becomes a [Types.t] and why + it is allowed to refuse. + + **A given [:type] wins over the recorded one**, and is not checked against + it. Overriding is the point of being able to say it: a pointer into the + middle of a block, a struct the registry recorded under a container's + spelling, a reinterpretation someone is doing on purpose. What is *not* + silent is the disagreement — the reply carries [:recorded] whenever the + table had a name, so a client showing one type while the allocator wrote + down another can say so. + + **Refused while running**, the same as [inspect] and for a related reason + rather than the same one: there is no frame here to be redefined under us, + but there is a table, and live-or-dead is exactly the thing a running + program is changing. An answer read off a program mid-frame is an answer + about a moment that has already gone. + + **Refused at an address the block does not divide.** When the entry records + an element size and the offset is not a multiple of it, the address is + inside an element rather than at one, and rendering the element type there + would read one element's tail as another's head — a plausible-looking + answer, which is the worst kind. Said with the offset, so the reader can + see how far off it is, and overridable by naming a [:type] the way any + other reinterpretation is. + + **No [:path].** A path steps from the pointee, and the pointee is what the + registry has only just been asked to bless: the whole answer here is the + pointer arm's branch. Somebody who wants to walk from what they found + reaches it the way the break buffer already does — the value is rendered, + and stepping into it is a different root. *) +let inspect_addr t ~addr ~want_type = + if addr <= 0 then error "an address is a positive number" + else if not (alive t) then error "the program exited; restart flan dev" + else + match state t with + | Running -> + error + "the program is running; whether an address is still live is exactly \ + what a running program is changing, so it is read from a stopped one" + | Unreachable m -> error ("cannot ask the program about that address: " ^ m) + | Stopped _ -> + (match reg_at t ~addr with + | Error m -> error m + | Ok entry -> + let recorded = Option.map (fun e -> e.rtype) entry in + let chosen = + match want_type with + | Some spelling -> type_of_spelling t spelling + | None -> + (match entry with + | Some e -> type_of_spelling t e.rtype + | None -> + Error + "the registry has never seen that address and no :type was \ + given, so there is nothing to say what is there — a stack \ + local, a global or a pointer from C is deliberately not in \ + the table, and the shadow stack answers for the first two \ + by name") + in + (match chosen with + | Error m -> error m + | Ok ty -> + let misaligned = + match (want_type, entry) with + | None, Some e when e.relem > 0 && e.roff mod e.relem <> 0 -> + Some e + | _ -> None + in + (match misaligned with + | Some e -> + error + (Printf.sprintf + "that address is %d bytes into a block of %s, whose \ + elements are %d bytes: it is inside an element rather \ + than at one, and reading %s there would show one \ + element's tail as another's head. Name a :type to read \ + it anyway." + e.roff e.rtype e.relem e.rtype) + | None -> + let told = + match recorded with + | None -> [ ":recorded nil" ] + | Some r -> [ ":recorded " ^ Wire.quote r ] + in + let where = + match entry with + | None -> [] + | Some e -> + [ Printf.sprintf ":offset %d" e.roff; + Printf.sprintf ":bytes %d" e.rbytes; + Printf.sprintf ":elem %d" e.relem; + Printf.sprintf ":step %d" e.rseq; + Printf.sprintf ":freed %d" e.rdied ] + in + let live = + match entry with Some e when e.rlive -> "t" | _ -> "nil" + in + (match render_addr t.session ~addr ~ty with + | Error m -> error m + | exception Failure m -> error m + | Ok c -> + (match run_render_thunk 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 ty)); + ":value " ^ Wire.quote v; ":live " ^ live ] + @ told @ where)))))) + +(* [reg types] and [reg leaks] — the table grouped by type spelling. + + The walk and the group-by are one function in [flan_dev.c], because a leak + report is a breakdown with the dead left out and two walks would drift. + What this end adds is the order: biggest first, by bytes. A breakdown read + in table order is a list of everything and tells you nothing; a breakdown + read biggest-first is the answer to "where did the memory go", which is the + only reason either verb exists. + + [:overflow] is carried rather than swallowed. A table that filled has + blocks in the program that are in nobody's row, so every number below it is + a floor and not a count, and a reader that could not tell would quote them + as counts. *) +let reg_rows t ~verb = + match request t verb with + | exception Unix.Unix_error (e, _, _) -> + Error ("cannot reach the program: " ^ Unix.error_message e) + | text -> + (match String.split_on_char '\n' text with + | [] -> Error "the program answered nothing" + | hdr :: rest -> + let hdr = String.trim hdr in + if String.length hdr > 4 && String.sub hdr 0 4 = "err " then + Error (String.sub hdr 4 (String.length hdr - 4)) + else + (match String.split_on_char ' ' hdr with + | [ n; over ] when int_of_string_opt n <> None -> + let rows = + List.filter_map + (fun line -> + match String.index_opt line '\t' with + | None -> None + | Some tab -> + let ty = + String.sub line (tab + 1) (String.length line - tab - 1) + in + (match + List.map int_of_string_opt + (String.split_on_char ' ' (String.sub line 0 tab)) + with + | [ Some count; Some bytes ] -> Some (ty, count, bytes) + | _ -> None)) + rest + in + let rows = + List.stable_sort (fun (_, _, a) (_, _, b) -> compare b a) rows + in + Ok (rows, over <> "0") + | _ -> Error ("the program answered " ^ hdr))) + +let reg_listing t ~verb ~note = + match reg_rows t ~verb with + | Error m -> error m + | Ok (rows, overflow) -> + let blocks = List.fold_left (fun a (_, c, _) -> a + c) 0 rows + and bytes = List.fold_left (fun a (_, _, b) -> a + b) 0 rows in + ok + [ ":types " + ^ Wire.list + (List.map + (fun (ty, c, b) -> + Wire.list [ Wire.quote ty; string_of_int c; string_of_int b ]) + rows); + Printf.sprintf ":blocks %d" blocks; + Printf.sprintf ":bytes %d" bytes; + (if overflow then ":overflow t" else ":overflow nil"); + ":note " ^ Wire.quote note ] + (* [(:op "globals")] — the globals the stopped stack reaches, in one section. Locals were the half the shadow stack was built for; these are arguably the @@ -1786,6 +2152,42 @@ let handle t req = (* No :frame, and that is the point: the section is the stack's, not a frame's. See [globals_op]. *) | Some "globals" -> globals_op t + (* [(:op "at" :addr N)] and an optional [:type]. The rooting mode with no + frame in it: an address somebody has in their hand, and the registry's + own answer for what is there when none is named. See [inspect_addr]. *) + | Some "at" -> + (match Wire.int_field req "addr" with + | None -> + error + "at needs :addr, the address to point at; it is the one thing this \ + verb cannot work out for itself" + | Some addr -> inspect_addr t ~addr ~want_type:(Wire.string_field req "type")) + (* What this program is made of, by type. Everything the table holds, live + and dead both — the dead are the bulk of it in a long-running program and + they are what says where the allocation went, not only where it stayed. *) + | Some "allocations" -> + reg_listing t ~verb:"reg types" + ~note: + "every block the registry recorded, live and dead, grouped by the \ + type the allocator's caller named" + (* And what is still held. + + "At exit" is the question this answers and it needs saying plainly, + because the obvious reading does not survive contact with a game. A + program killed by a signal — which is how a program under this editor + usually ends — runs no handler at all, so nothing written inside it could + report anything. There are therefore two readers and they are not + alternatives: this verb, which reads the same table over the agent socket + and can be asked at any moment, including the last one before the kill; + and an atexit hook in [flan_dev.c] for the program that returns from main + on its own, which is off unless FLAN_DEV_LEAKS is set, because a dev + build's output is read by the acceptance table. *) + | Some "leaks" -> + reg_listing t ~verb:"reg leaks" + ~note: + "what the registry still holds live at the moment it was asked; a \ + program that is killed runs no exit handler, so this verb and not a \ + hook is what answers for one" | Some "layout" -> (match Wire.string_field req "type" with | Some ty -> layout t ~ty diff --git a/runtime/flan_dev.c b/runtime/flan_dev.c index 4a7ddb3..5ed1704 100644 --- a/runtime/flan_dev.c +++ b/runtime/flan_dev.c @@ -1055,6 +1055,8 @@ static int flan_reg_full; /* something found no slot */ * second version of the allocator gated on a build flag is worse than a * branch. That is a real cost and not zero; BUILT.md says so rather than * repeating the claim that a release build carries nothing. */ +static void flan_reg_report(void); /* the exit report, at the bottom */ + void flan_dev_reg_enable(void) { if (flan_reg_on) return; flan_reg = (flan_reg_entry *)calloc(FLAN_REG_CAP, sizeof *flan_reg); @@ -1063,6 +1065,12 @@ void flan_dev_reg_enable(void) { which is what a release build answers too. */ if (flan_reg == NULL) return; flan_reg_on = 1; + /* Here and not at file scope: a destructor attribute would run in every + build, since this file is linked into every build, and that would be a + third place a release build is not free. Registered from inside the one + function only a dev build's constructor calls, a release binary still + carries a null pointer, a zero flag and the declarations. */ + if (getenv("FLAN_DEV_LEAKS") != NULL) atexit(flan_reg_report); } int flan_dev_reg_enabled(void) { return flan_reg_on; } @@ -1259,3 +1267,148 @@ int64_t flan_dev_reg_count(int32_t live_only) { return n; } + +/* ── Reading the table back ─────────────────────────────────────────── + * + * Three accessors and no formatter. Everything above this point is on the + * writer's side — a game loop — and everything below is read by a person + * pressing a key, so the shape that matters here is "hand back what is + * recorded" rather than "hand back a sentence". The agent turns these into + * protocol lines and the daemon turns those into an editor reply; the one + * piece of text this file still writes is the exit report at the bottom, + * which has nowhere else to go. + */ + +/* What the table records for the address [p], live or dead. The containment + * lookup, exposed: [flan_dev_reg_live] answers the renderer's yes/no and + * [flan_dev_reg_emit] writes the epitaph, and neither hands back the *name*, + * which is what a reader that wants to point at a bare address needs — it has + * no (Ptr T) to read the type off, so the table's own answer is the only + * answer there is. + * + * [off] is how far into the block [p] lands, and it is not decoration: with + * [elem] it is what says whether the address is an element boundary or the + * middle of one. A caller that renders a T at an offset that is not a + * multiple of [elem] would be reading one element's tail as another's head, + * so it is given the two numbers rather than a flag it cannot check. */ +int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, + int64_t *off, int64_t *bytes, int64_t *elem, + int64_t *seq, int64_t *died) { + flan_reg_entry *e = flan_reg_on ? flan_reg_find((uintptr_t)p) : NULL; + if (e == NULL) return 0; + if (type) *type = e->type; + if (typelen) *typelen = e->typelen; + if (off) *off = (int64_t)((uintptr_t)p - e->base); + if (bytes) *bytes = e->bytes; + if (elem) *elem = e->elem; + if (seq) *seq = e->seq; + if (died) *died = e->died; + 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 + * 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 + * arithmetic out of an integer is the thing the type system stops describing. + * So the conversion is a C function, named and visible, and the language + * still has no operator for it. */ +int64_t flan_dev_reg_number(const void *p) { return (int64_t)(uintptr_t)p; } + +/* The table, by type spelling: one row per distinct name, with how many + * blocks carry it and how many bytes they hold. [live_only] is the whole + * difference between "what is this program made of" and "what is still held", + * which is why there is one walk here and not two — a leak report is a + * breakdown with the dead left out, and writing it twice would let the two + * drift. + * + * Caller-owned buffers, and the return is how many distinct types there were + * rather than how many were written: a caller whose buffers were too small is + * told so by the number coming back larger than [cap], which is the same + * contract the watch table's count has. + * + * The grouping is O(rows x types) on string compare. The table is 4096 slots + * and the reader is a person, so this is the side the cost belongs on — the + * same judgement [flan_reg_find] is written down for. Compared by *content* + * and not by pointer: the name is a literal the compiler emitted beside a + * call site, and two modules that both allocate an Enemy emit two of them. */ +int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, + int64_t *bytes, const char **types, + int64_t *typelens, int64_t cap) { + int64_t i, n = 0; + if (!flan_reg_on) return 0; + for (i = 0; i < FLAN_REG_CAP; i++) { + flan_reg_entry *e = &flan_reg[i]; + int64_t j; + int found = 0; + if (e->base == 0) continue; + if (live_only && e->died != 0) continue; + for (j = 0; j < n && j < cap; j++) { + if (typelens[j] != e->typelen) continue; + if (memcmp(types[j], e->type, (size_t)e->typelen) != 0) continue; + counts[j]++; + bytes[j] += e->bytes; + found = 1; + break; + } + if (found) continue; + if (n < cap) { + types[n] = e->type; + typelens[n] = e->typelen; + counts[n] = 1; + bytes[n] = e->bytes; + } + n++; + } + return n; +} + +/* ── What is still held when the program returns ────────────────────── + * + * Registered by [flan_dev_reg_enable] and therefore only in a dev build, + * which is the point: a file-scope destructor would run in *every* build, + * because this file is compiled into every build, and that would be a third + * place a release build is not free. BUILT.md names two and only two. + * + * Off unless FLAN_DEV_LEAKS is set, and that is not timidity. The acceptance + * table reads programs/registry.flan's output with stderr folded in, so a + * report nobody asked for is a report that changes what a dev build prints. + * + * And it says "at exit" honestly. This runs when main returns or something + * calls exit(). A program killed with a signal — which is how a game under + * the editor usually ends — runs no handler at all, and no hook written here + * could change that. The answer for that program is the daemon's own verb, + * which reads the same table over the agent socket and can be asked at any + * moment, including the one before the kill. This hook is for the program + * that finishes on its own. */ +static void flan_reg_report(void) { + enum { ROWS = 128 }; + int64_t counts[ROWS], bytes[ROWS], typelens[ROWS]; + const char *types[ROWS]; + int64_t n, i, blocks = 0, held = 0; + n = flan_dev_reg_by_type(1, counts, bytes, types, typelens, ROWS); + if (n == 0) return; + for (i = 0; i < n && i < ROWS; i++) { blocks += counts[i]; held += bytes[i]; } + fprintf(stderr, "flan: %lld block%s still held at exit, %lld bytes\n", + (long long)blocks, blocks == 1 ? "" : "s", (long long)held); + for (i = 0; i < n && i < ROWS; i++) + fprintf(stderr, "flan: %6lld %10lld %.*s\n", (long long)counts[i], + (long long)bytes[i], (int)typelens[i], types[i]); + if (n > ROWS) + fprintf(stderr, "flan: and %lld more type%s than this report holds\n", + (long long)(n - ROWS), n - ROWS == 1 ? "" : "s"); + if (flan_reg_full) + fprintf(stderr, + "flan: the table overflowed, so this is a floor and not a " + "count\n"); +} diff --git a/test/programs/dev-ptr.flan b/test/programs/dev-ptr.flan index b316a46..c6783e9 100644 --- a/test/programs/dev-ptr.flan +++ b/test/programs/dev-ptr.flan @@ -7,13 +7,12 @@ ;;;; ;;;; N is the registry's own event counter and is no part of the claim: it ;;;; moves if anything allocates or frees ahead of this program's two Vecs. -;;;; A test that asserts these lines should match around it, not on it. +;;;; `test_dev.ml' matches around it and never on it. ;;;; -;;;; Both lines are what `(:op "locals" :frame 1)` answers with today, and -;;;; both were read off a running session by hand. **No test drives this -;;;; program yet**: the case belongs beside the other `locals` and `inspect` -;;;; cases in test_dev.ml, which is another lane's file. NEXT.md says so -;;;; rather than letting the verification read as automated. +;;;; Both lines are what `(:op "locals" :frame 1)` answers with, and the +;;;; `a pointer the registry knows about' case in test_dev.ml is what drives +;;;; them. They were read off a running session by hand once; they are not +;;;; read by hand any more. ;;;; ;;;; Why a Vec rather than a struct on the stack: a stack address is not in ;;;; the registry by design — the shadow stack already answers for a local by @@ -24,6 +23,20 @@ (defstruct Boom [why i32]) (defstruct Enemy [hp i32 x i32]) +;;; The address root — `(:op "at" :addr N)' — takes a number, and the things +;;; that hand out addresses as numbers all live outside the language: a +;;; debugger, valgrind, a C shim's printf. A Flan program has no cast for it +;;; on purpose — pointer arithmetic out of an integer is what the type system +;;; stops describing — so saying one out loud is a declare-c. +(declare-c ptr-num [p (Ptr Enemy)] i64 "flan_dev_reg_number") + +;;; Where the two addresses are left for a reader to find. Globals rather than +;;; a printed line because a global is reachable by name from `C-x C-e' while +;;; the program is stopped, and a local is not: the test asks the session for +;;; them the way a person at the break loop would. +(defvar live-addr i64) +(defvar dead-addr i64) + (defn deeper [] i64 (restart-case (do (error (Boom {.why 7})) 1) @@ -37,6 +50,8 @@ (let [live (addr (at v 0)) dead (addr (at w 0))] (free w) + (set live-addr (ptr-num live)) + (set dead-addr (ptr-num dead)) (deeper)))) (defvar ticks i64) diff --git a/test/test_dev.ml b/test/test_dev.ml index cce1cbd..7ed5f32 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -1348,6 +1348,315 @@ let () = end end; + (* ── A pointer the registry knows about ───────────────────────── *) + + (* The inspector's pointer arm, and the address root beside it. + + [programs/dev-ptr.flan] carried the two lines a session answers with in + its own header and said, in the header, that they had been read off a + running session **by hand**. This is the case that makes that stop + being true. Nothing else drives it: [programs/registry.flan] asserts + the *table* from the acceptance side — live or not, in a dev build and + a release one — and says nothing about what an inspector renders. + + The claim has two halves and they are what the registry bought. A + pointer into live Vec storage is *followed*, one level deeper, and its + pointee rendered by the same walk as anything else. A pointer into + storage that has been freed is not followed, and names what died there + instead. Both pointers have the same static type, so nothing but the + table can tell them apart — which is the whole argument of "permission, + not identification". *) + let psock = tmp "ptr.sock" and pout = tmp "ptr.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-ptr.flan"; "-s"; psock |] + Unix.stdin pfd Unix.stderr + in + Unix.close pfd; + if not (listening ~pid:ppid psock) then begin + fail "the pointer daemon %s" !listen_why; + (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()) + end + else begin + let c = connect psock in + let ask sexp = Wire.parse (Wire.send c sexp; Wire.recv c) in + let stopped r = + match Wire.field r "stopped" with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let value r = Option.value ~default:"" (Wire.string_field r "value") in + let message r = + Option.value ~default:(status r) (Wire.string_field r "message") + in + let flag r key = + match Wire.field r key with + | Some { Form.v = Form.Sym "t"; _ } -> true + | _ -> false + in + let starts s pre = + String.length s >= String.length pre + && String.equal (String.sub s 0 (String.length pre)) pre + in + let contains hay needle = + let n = String.length needle in + let rec go i = + i + n <= String.length hay + && (String.equal (String.sub hay i n) needle || go (i + 1)) + in + go 0 + in + if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then + fail "the pointer program never stopped" + else begin + let entries r = + match Wire.field r "locals" 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 ty; _ }; + { Form.v = Form.Str v; _ }; _ ] -> Some (n, ty, v) + | _ -> None) + l + | _ -> [] + in + let listing = ask "(:op \"locals\" :frame 1)" in + if status listing <> "ok" then + fail "locals of the frame holding the two pointers: %s" + (message listing) + else begin + let got = entries listing in + let find n = List.find_opt (fun (m, _, _) -> String.equal m n) got in + (* The live half, asserted whole. A pointer with nobody to ask + renders []; this is what having somebody to ask buys. *) + (match find "live" with + | Some ("live", "(Ptr Enemy)", "") -> () + | Some (_, ty, v) -> + fail "a live pointer into Vec storage rendered %s : %s" v ty + | None -> + fail "the frame holding the two pointers listed no `live': %s" + (String.concat ", " (List.map (fun (n, _, _) -> n) got))); + (* And the dead half, asserted *around* the step number and never on + it. The step is the registry's own event counter: it moves if + anything allocates or frees ahead of this program's two Vecs, and + the program's header says so. What is being claimed is that the + pointer was not followed and that what died is named. *) + (match find "dead" with + | None -> fail "the frame holding the two pointers listed no `dead'" + | Some (_, ty, v) -> + if ty <> "(Ptr Enemy)" then + fail "the dead pointer's type is %s, not (Ptr Enemy)" ty; + let pre = " String.length pre + && v.[String.length v - 1] = '>') + then fail "a pointer into freed Vec storage rendered %s" v + else + let n = + String.sub v (String.length pre) + (String.length v - String.length pre - 1) + in + if int_of_string_opt n = None then + fail "the epitaph's step is %S, which is not a number" n; + (* No address in it, and that is deliberate rather than an + omission: an address is not stable across two runs, so + printing one would make this very assertion depend on where + the heap landed. *) + if contains v "0x" then + fail "the epitaph carried an address: %s" v) + end; + + (* ── The address root ─────────────────────────────────────── *) + + (* [(:op "at" :addr N)] is the rooting mode with no frame in it. The + two addresses are left in globals by the program, which is how a + person at a break loop reaches them too — a global is evaluable by + name while stopped and a local is not. *) + let addr name = + let r = + ask (Printf.sprintf "(:op \"eval-expr\" :code %S :file \"\")" name) + in + if status r <> "ok" then None else int_of_string_opt (value r) + in + (match (addr "live-addr", addr "dead-addr") with + | Some live, Some dead when live > 0 && dead > 0 -> + (* The type is not given, so the answer for it is the registry's + own — the recorded *string*, resolved back to a type by the + session. That resolution is the whole of what item 3 needed and + it is what this line is really asserting: nothing but the table + said `Enemy' here. *) + let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" live) in + if status r <> "ok" then fail "pointing at a live address: %s" (message r) + else begin + if value r <> "" then + fail "the address root rendered %s at a live address" (value r); + if Option.value ~default:"" (Wire.string_field r "type") + <> "(Ptr Enemy)" + then + fail "the address root resolved the recorded name to %s" + (Option.value ~default:"" (Wire.string_field r "type")); + if not (flag r "live") then + fail "a live address came back not live"; + if Option.value ~default:"" (Wire.string_field r "recorded") + <> "Enemy" + then fail "the reply did not carry what the table recorded" + end; + (* And the dead one, by the same route and with the same type, + which is the point: the static type cannot tell these apart. *) + let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" dead) in + if status r <> "ok" then fail "pointing at a dead address: %s" (message r) + else begin + if not (starts (value r) " "ok" then + fail "reading a live address as a named type: %s" (message r) + else begin + if value r <> "" then + fail "a named :type did not win over the recorded one: %s" + (value r); + if Option.value ~default:"" (Wire.string_field r "recorded") + <> "Enemy" + then fail "an overridden read did not say what was recorded" + end; + (* An address inside an element rather than at one. Rendering the + element type there would show one element's tail as another's + head — a plausible-looking answer, which is the worst kind — so + it is refused with the offset, and a named :type reads it + anyway. *) + let r = ask (Printf.sprintf "(:op \"at\" :addr %d)" (live + 1)) in + if status r <> "error" then + fail "an address inside an element answered anyway: %s" (value r) + else if not (contains (message r) "inside an element") then + fail "a misaligned address was refused without saying why: %s" + (message r); + let r = + ask (Printf.sprintf "(:op \"at\" :addr %d :type \"i32\")" (live + 4)) + in + if status r <> "ok" then + fail "a named :type did not reach the second half of an element: %s" + (message r) + else if value r <> "" then + fail "reading the second i32 of an Enemy gave %s" (value r) + | _ -> + fail "the program did not leave its two addresses in globals"); + (* An address the registry has never seen is a fact and not a failure + — a stack local, a global, or a pointer from C — and with no + [:type] there is nothing to say what is there. Refused by name, + rather than answered with bytes. *) + let r = ask "(:op \"at\" :addr 12345)" in + if status r <> "error" then + fail "an address the registry never saw was rendered anyway: %s" + (value r) + else if not (contains (message r) "never seen") then + fail "an unknown address was refused without saying why: %s" (message r); + + (* ── The breakdown, and what is still held ─────────────────── *) + + (* Both are one walk over the table in [flan_dev.c] with the dead + left out of the second, and the difference between the two answers + is the assertion: this program freed one of its two Enemy blocks, + so the breakdown has both and the leak report has one. Counting + only the rows would pass with the walk stubbed out; counting the + difference cannot. *) + let enemy r = + match Wire.field r "types" with + | Some { Form.v = Form.List l; _ } -> + List.fold_left + (fun acc (e : Form.t) -> + match e.Form.v with + | Form.List + [ { Form.v = Form.Str "Enemy"; _ }; + { Form.v = Form.Int n; _ }; { Form.v = Form.Int b; _ } ] -> + Some (Int64.to_int n, Int64.to_int b) + | _ -> acc) + None l + | _ -> None + in + let all = ask "(:op \"allocations\")" in + let live = ask "(:op \"leaks\")" in + if status all <> "ok" then fail "the breakdown by type: %s" (message all) + else if status live <> "ok" then fail "the leak report: %s" (message live) + else begin + (match (enemy all, enemy live) with + | Some (2, _), Some (1, _) -> () + | got, held -> + let say = function + | None -> "no row" + | Some (n, b) -> Printf.sprintf "%d blocks, %d bytes" n b + in + fail + "the table should hold two Enemy blocks with one of them freed; \ + the breakdown says %s and the leak report says %s" (say got) + (say held)); + (* Ordered biggest first, by bytes. A breakdown read in table order + is a list of everything and answers nothing; biggest-first is the + answer to "where did the memory go", which is the only reason + either verb exists. *) + let bytes r = + match Wire.field r "types" with + | Some { Form.v = Form.List l; _ } -> + List.filter_map + (fun (e : Form.t) -> + match e.Form.v with + | Form.List [ _; _; { Form.v = Form.Int b; _ } ] -> + Some (Int64.to_int b) + | _ -> None) + l + | _ -> [] + in + let rec descending = function + | a :: (b :: _ as rest) -> a >= b && descending rest + | _ -> true + in + if not (descending (bytes all)) then + fail "the breakdown is not ordered biggest first"; + (* And a leak report is a subset of the breakdown, always: nothing + can be live that was never recorded. *) + let sum r = List.fold_left ( + ) 0 (bytes r) in + if sum live > sum all then + fail "the leak report holds more bytes than the whole table does" + end + end; + (* And a running program is refused. There is no frame here to be + redefined under us — the registry is a table and not a stack — but + live-or-dead is exactly what a running program is changing, so an + answer read mid-frame is an answer about a moment that has gone. *) + let r = ask "(:op \"restart\" :name \"carry-on\")" in + if status r <> "ok" then + fail "resuming the pointer program: %s" (message r); + if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then + fail "the pointer program never resumed" + else begin + let r = ask "(:op \"at\" :addr 4096)" in + if status r <> "error" then + fail "a running program answered the address root" + end; + ignore (ask "(:op \"close\")"); + Unix.close c; + if not + (await ~ms:5000 (fun () -> + match Unix.waitpid [ Unix.WNOHANG ] ppid with + | 0, _ -> false + | _ -> true + | exception Unix.Unix_error _ -> true)) + then begin + (try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ()); + (try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ()) + end + end; + (* ── The globals a stopped stack reaches ───────────────────────── *) (* The other half of what a break loop can show. Locals are one frame's; diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 82e5604..e676e52 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -93,6 +93,25 @@ int flan_dev_watch_read(uint32_t i, char *nd, uint64_t ncap, uint64_t flan_dev_watch_name_cap(void); uint64_t flan_dev_watch_val_cap(void); +/* The allocation registry, read the same way and on the same thread. The + * renderer's two questions — is this address live, and what died here — are + * asked from inside a compiled thunk and never come through this file; these + * three are the *reader's* side, which has no (Ptr T) to read a type off and + * so has to ask the table what it recorded. + * + * Formatting lives here rather than in flan_dev.c for the reason [watch] and + * [result] already have: this runs on the listener thread, where allocating + * and snprintf are legal, and what the game thread writes stays a fixed + * table nobody has to format to fill. */ +int32_t flan_dev_reg_at(const void *p, const char **type, int64_t *typelen, + int64_t *off, int64_t *bytes, int64_t *elem, + int64_t *seq, int64_t *died); +int64_t flan_dev_reg_by_type(int32_t live_only, int64_t *counts, + int64_t *bytes, const char **types, + int64_t *typelens, int64_t cap); +int flan_dev_reg_enabled(void); +int flan_dev_reg_overflowed(void); + /* A ring the listener writes and the game thread reads. One producer, one * consumer, so two atomics and no lock — the game thread must never block on * the loader. @@ -975,6 +994,104 @@ static void handle_line(char *line, sink *o) { free(v); return; } + /* "reg at ADDR" — what the allocation registry records for one address. + * + * The reader's side of the table, and the one question the renderer's own + * two cannot answer. Inside a thunk the type at the far end of a pointer is + * already static — (Ptr Enemy) says Enemy — so [reg-live] and [reg-emit] + * only ever needed permission. Somebody pointing at a bare address has no + * (Ptr T) to read a type off, and the recorded name is the whole of what + * there is to go on. + * + * Answered while the program is running as well as while it is stopped: + * this reads a table, not a stack, and nothing here walks a chain another + * thread is pushing. Whether the *answer* holds still long enough to be + * worth acting on is the caller's judgement, and the daemon makes it. + * + * ADDR is read with base 0, so both 0x-hex and decimal arrive; an editor + * that has an address as text has it in one of those two spellings. */ + if (strncmp(line, "reg at ", 7) == 0) { + const char *type = NULL; + int64_t typelen = 0, off = 0, bytes = 0, elem = 0, seq = 0, died = 0; + char *end = NULL; + unsigned long long a; + if (!flan_dev_reg_enabled()) { + reply(o, "err the allocation registry is off; this is not a dev build\n"); + return; + } + a = strtoull(line + 7, &end, 0); + if (end == line + 7 || a == 0) { + reply(o, "err reg at wants an address\n"); + return; + } + if (!flan_dev_reg_at((const void *)(uintptr_t)a, &type, &typelen, &off, + &bytes, &elem, &seq, &died)) { + /* Never heard of it, which is a fact and not a failure: a stack local, + * a global, or a pointer from C. The daemon says which of those it + * might be; this says only that the table has nothing. */ + reply(o, "none\n"); + return; + } + { + char hdr[128]; + int k = snprintf(hdr, sizeof hdr, "ok %d %lld %lld %lld %lld %lld\t", + died == 0 ? 1 : 0, (long long)off, (long long)bytes, + (long long)elem, (long long)seq, (long long)died); + if (k > 0) emit(o, hdr, (size_t)k); + /* Last, and after a tab, because a type spelling holds spaces — + * "(Vec i32)" — and nothing else on the line does. It cannot hold a tab + * or a newline: it is Types.to_string of a type the programmer wrote. */ + if (typelen > 0) emit(o, type, (size_t)typelen); + reply(o, "\n"); + } + return; + } + /* "reg types" — the whole table grouped by type spelling; "reg leaks" — the + * same walk with the dead left out. + * + * One verb would have done with a flag, and two exist because the two + * questions are asked at different moments and read differently: a + * breakdown is "what is this program made of", a leak report is "what is + * still held". The *walk* is one function in flan_dev.c for exactly that + * reason — two of them would drift. + * + * A header first, like [watch]: how many rows follow, and whether the table + * ever overflowed. The second is not decoration — an overflowed table has + * blocks in the program that are in nobody's row, so every number below is + * a floor, and a reader that could not tell would quote them as counts. */ + if (strcmp(line, "reg types") == 0 || strcmp(line, "reg leaks") == 0) { + enum { REG_ROWS = 256 }; + /* Static rather than on the stack: 256 rows of four words is 8KB, and + * this thread's stack is whatever pthread gave it. Safe because + * [request_lock] is held — one request at a time, whoever asked, which is + * the same guarantee the ring's single producer rests on. */ + static int64_t counts[REG_ROWS], bytes[REG_ROWS], typelens[REG_ROWS]; + static const char *types[REG_ROWS]; + int64_t n, i; + int live_only = line[4] == 'l'; + if (!flan_dev_reg_enabled()) { + reply(o, "err the allocation registry is off; this is not a dev build\n"); + return; + } + n = flan_dev_reg_by_type(live_only ? 1 : 0, counts, bytes, types, typelens, + REG_ROWS); + { + char hdr[64]; + int k = snprintf(hdr, sizeof hdr, "%lld %d\n", + (long long)(n < REG_ROWS ? n : REG_ROWS), + flan_dev_reg_overflowed()); + if (k > 0) emit(o, hdr, (size_t)k); + } + for (i = 0; i < n && i < REG_ROWS; i++) { + char row[64]; + int k = snprintf(row, sizeof row, "%lld %lld\t", (long long)counts[i], + (long long)bytes[i]); + if (k > 0) emit(o, row, (size_t)k); + if (typelens[i] > 0) emit(o, types[i], (size_t)typelens[i]); + reply(o, "\n"); + } + return; + } /* Before the dlopen, not after it: a module there is no room to queue is * one there is no point relocating, and refusing here means no handle is * taken for it at all. Only one producer runs at a time, so room seen now is