JosephFerano/flan
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Merge branch 'worktree-agent-ac5ad16091bc3a40e' into dev-loop

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-13 15:33:52 +07:00
commit 861f591bb0
11 changed files with 1421 additions and 51 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

75
BUILT.md
View File

@ -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

43
NEXT.md
View File

@ -488,46 +488,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 (`<ptr dead: was Enemy, freed at step 15>`). 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
`<ptr>`.
`<ptr>` — 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

61
emacs/MANUAL.md
View File

@ -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).
---

75
emacs/flan-dev.el
View File

@ -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

77
emacs/flan-inspect.el
View File

@ -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
@ -353,8 +367,16 @@ root, which is the older and the more limited of the two."
('trunc
"truncated: the walk stopped at its depth bound of 4. Inspect the field that holds it, which re-roots the walk")
('opaque
(format "%s: the walk had no structure for this type, so there are no fields to show"
(plist-get node :text)))
;; A *followed* pointer lands here rather than on the `ptr' arm above,
;; because that arm matches the bare word. Saying "no structure for this
;; type" of it would be false and unhelpful at once: it has structure, it
;; is right there, and the reason you cannot step in is that the step
;; would start from the pointee — the deref the registry blessed once and
;; is not being asked about again.
(if (string-prefix-p "<ptr " (or (plist-get node :text) ""))
"a pointer the registry let the renderer follow: the pointee is already drawn, one level deeper. Stepping in would step from it, which is a second deref nobody has asked about — root at it with `M-x flan-inspect-address' instead"
(format "%s: the walk had no structure for this type, so there are no fields to show"
(plist-get node :text))))
('atom (format "%s is an atom; it has no fields" (plist-get node :text)))
(_ "not something this inspector knows how to enter")))
@ -362,7 +384,7 @@ root, which is the older and the more limited of the two."
(defvar-local flan-inspect--root nil
"What this buffer's walk starts from.
Either `(:expr EXPR)\=' or `(:slot FRAME SLOT NAME)\='.")
One of `(:expr EXPR)\=', `(:slot FRAME SLOT NAME)\=' or `(:addr N TYPE)\='.")
(defvar-local flan-inspect--path nil
"The steps walked from `flan-inspect--root\=', outermost first.
Together with the root this is the whole of where the buffer is. It is a
@ -561,6 +583,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 +646,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

116
emacs/test-flan-cider.el
View File

@ -208,6 +208,122 @@
(string-match-p "\\.name +\"all\"\n" text))))
;;; The address root, and the registry listings
(message "\nthe address root")
;; The rooting mode with no frame in it. What is asserted here is the *wire*:
;; the buffer sends `at' with the address, sends `:type' only when one was
;; named, and refuses a path rather than dropping it. What the daemon does
;; with that is test_dev.ml's business, over a real program.
(let* ((sent nil)
(flan-inspect-request-function
(lambda (form) (setq sent form) '(:status "ok" :value "<ptr (Enemy {.hp 41 .x 2})>"
:type "(Ptr Enemy)" :live t :recorded "Enemy")))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion
(flan-inspect--show (list :addr 4096 nil) nil))
(buffer-string))))
(test-flan--check "an address root asks the daemon for `at'"
(equal (plist-get sent :op) "at"))
(test-flan--check "with the address"
(equal (plist-get sent :addr) 4096))
;; Absent and not empty: leaving it out is what makes the registry answer
;; for the type, which is the whole of what the address root buys.
(test-flan--check "and no :type when none was named"
(null (plist-get sent :type)))
(test-flan--check "the address is named in hex at the top"
(string-match-p "#x1000" text))))
(let* ((sent nil)
(flan-inspect-request-function
(lambda (form) (setq sent form) '(:status "ok" :value "<ptr 41>" :type "(Ptr i32)")))
(flan-inspect-buffer " *test-inspect*"))
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
(let ((text (with-current-buffer
(save-window-excursion
(flan-inspect--show (list :addr 4096 "i32") nil))
(buffer-string))))
(test-flan--check "a named type is sent as :type"
(equal (plist-get sent :type) "i32"))
(test-flan--check "and shown beside the address"
(string-match-p "#x1000 as i32" text))))
;; A path is refused rather than dropped. A path with a step silently gone
;; would render a different value and say nothing, which is the failure the
;; whole buffer is built to avoid.
(let ((flan-inspect-request-function
(lambda (_) '(:status "ok" :value "<ptr 41>"))))
(test-flan--check "an address root refuses a path"
(eq 'caught
(condition-case nil
(flan-inspect--value (list :addr 4096 nil) '((:field "x")))
(user-error 'caught)))))
;; And a followed pointer is refused for the true reason rather than for "no
;; structure": it has structure, it is drawn, and the step would be a second
;; deref nobody asked about.
(test-flan--check "a followed pointer says why it cannot be entered"
(string-match-p
"second deref"
(flan-inspect-refusal
(flan-inspect-parse "<ptr (Enemy {.hp 41 .x 2})>"))))
(message "\nthe registry listings")
(let* ((sent nil)
(flan-dev--request-stub
(lambda (form)
(setq sent form)
'(:status "ok"
:types (("Enemy" 2 64) ("i32" 1 16))
:blocks 3 :bytes 80 :overflow nil
:note "every block the registry recorded"))))
(cl-letf (((symbol-function 'flan-dev--request) flan-dev--request-stub)
((symbol-function 'display-buffer) #'ignore))
(let ((flan-allocations-buffer " *test-allocations*"))
(flan-allocations)
(test-flan--check "the breakdown asks for `allocations'"
(equal (plist-get sent :op) "allocations"))
(let ((text (with-current-buffer " *test-allocations*" (buffer-string))))
(test-flan--check "and lists each type with its blocks and bytes"
(string-match-p "2 +64 +Enemy" text))
(test-flan--check "with a total under it"
(string-match-p "3 +80 +in 2 types" text)))
(flan-leaks)
(test-flan--check "the leak report asks for `leaks'"
(equal (plist-get sent :op) "leaks"))
(kill-buffer " *test-allocations*"))))
;; An overflowed table has blocks in the program that are in nobody's row, so
;; every number under it is a floor. Said before the numbers, because a reader
;; who missed it would quote them as counts.
(cl-letf (((symbol-function 'flan-dev--request)
(lambda (_) '(:status "ok" :types (("Enemy" 1 32)) :blocks 1 :bytes 32
:overflow t)))
((symbol-function 'display-buffer) #'ignore))
(let ((flan-allocations-buffer " *test-allocations*"))
(flan-allocations)
(let ((text (with-current-buffer " *test-allocations*" (buffer-string))))
(test-flan--check "an overflowed table is said to be a floor"
(string-match-p "floors, not counts" text)))
(kill-buffer " *test-allocations*")))
;; And a release build, which records nothing and says so. The refusal comes
;; back as an ordinary error status and reaches the person, rather than an
;; empty listing that reads like a program holding nothing.
(cl-letf (((symbol-function 'flan-dev--request)
(lambda (_) '(:status "error"
:message "the allocation registry is off; this is not a dev build")))
((symbol-function 'display-buffer) #'ignore))
(test-flan--check "a build with no registry refuses rather than showing nothing"
(eq 'caught
(condition-case nil (flan-leaks) (user-error 'caught)))))
;;; The inspector buffer
(message "\nthe inspector buffer")

402
lib/dev.ml
View File

@ -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:"<registry>" 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

153
runtime/flan_dev.c
View File

@ -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");
}

27
test/programs/dev-ptr.flan
View File

@ -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)

309
test/test_dev.ml
View File

@ -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 [<ptr>]; this is what having somebody to ask buys. *)
(match find "live" with
| Some ("live", "(Ptr Enemy)", "<ptr (Enemy {.hp 41 .x 2})>") -> ()
| 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 = "<ptr dead: was Enemy, freed at step " in
if not (starts v pre && String.length v > 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 \"<t>\")" 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 <> "<ptr (Enemy {.hp 41 .x 2})>" 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) "<ptr dead: was Enemy, freed at step ")
then fail "the address root rendered %s at a dead address" (value r);
if flag r "live" then fail "a freed address came back live"
end;
(* A named :type wins over the recorded one and is not checked
against it — overriding is the point of being able to say it —
but the disagreement is never silent: [:recorded] is carried
whenever the table had a name. *)
let r =
ask (Printf.sprintf "(:op \"at\" :addr %d :type \"i32\")" live)
in
if status r <> "ok" then
fail "reading a live address as a named type: %s" (message r)
else begin
if value r <> "<ptr 41>" 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 <> "<ptr 2>" 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;

134
vendor/agent/flan_agent.c vendored
View File

@ -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,121 @@ 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 };
/* Allocated here and freed before the reply is finished, not declared as
* static arrays. 256 rows of four words is 8KB, and static would put that
* 8KB in the BSS of every build this package is linked into — including a
* release build of a game that imports the agent, which never writes a
* row. That is flan_dev.c's own argument against a fixed table, at a
* thirty-second of the size, and it is the same rule: a release build
* carries a null pointer and the declarations.
*
* Allocating is legal here for [watch]'s reason and no other: this runs
* on the listener thread, or on the compiler thread in a merged build.
* The table the game thread writes is a fixed static in flan_dev.c
* precisely so that *it* allocates nothing. */
int64_t *counts = malloc(REG_ROWS * sizeof *counts);
int64_t *bytes = malloc(REG_ROWS * sizeof *bytes);
int64_t *typelens = malloc(REG_ROWS * sizeof *typelens);
const char **types = malloc(REG_ROWS * sizeof *types);
int64_t n, i;
int live_only = line[4] == 'l';
if (counts == NULL || bytes == NULL || typelens == NULL || types == NULL) {
free(counts); free(bytes); free(typelens); free(types);
reply(o, "err out of memory reading the allocation registry\n");
return;
}
if (!flan_dev_reg_enabled()) {
free(counts); free(bytes); free(typelens); free(types);
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");
}
free(counts); free(bytes); free(typelens); free(types);
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