Two ways to root an inspector walk, and a frame's slot is one of them
This commit is contained in:
commit
f61bda2bef
76
BUILT.md
76
BUILT.md
@ -2769,3 +2769,79 @@ is a wire format — `emacs/flan-inspect.el` parses it back and hard-codes the c
|
||||
moving the printer alone would break struct inspection in the dev loop without breaking any test that says so. The
|
||||
printer moves when its reader does, in the Emacs lane. It is the one place the old spelling is still correct, and
|
||||
the reason is worth keeping: **a format with two ends only changes at both.**
|
||||
|
||||
**Since written: the printer moved, and both ends moved together.** `render.ml` prints `(V {.x 1.5 .y 0})` now and
|
||||
`emacs/flan-inspect.el` reads the dot, which is the "moves when its reader does" the paragraph above was waiting on.
|
||||
The reader tells `...` from a field label by one character of lookahead, because both begin with a dot and a field
|
||||
name never starts with a second one.
|
||||
|
||||
## Two ways to root a walk, and why neither subsumes the other
|
||||
|
||||
`i` in the break buffer sent a local's **name** to be evaluated. An expression is evaluated where the evaluator
|
||||
stands, so on the innermost frame that lands in the right frame by luck; on any other it may resolve to a global, to
|
||||
another binding of the same name, or to nothing — with the locals listing right above it showing the frame's own
|
||||
storage and nothing saying the two disagree. The display was right and the inspector was not, which is the worst
|
||||
arrangement of the two.
|
||||
|
||||
**The obvious fix was tried and rejected, and the rejection was half wrong.** Rooting the walk at the slot's address
|
||||
does not work on its own: an address is not an expression, so the first `RET` has nothing to build the next expression
|
||||
from and navigation dies at step one. What that argument assumed is that the *step* has to be an expression too, and
|
||||
the shadow stack is what stopped that being true. The daemon holds the frame's address and every slot's type, so
|
||||
stepping into a field is an address plus an offset with that field's type — which is exactly the arithmetic
|
||||
`Render.render` already does for the locals listing. So `Session.render_slot` is `render_locals` with a path applied
|
||||
to the root before the walk and one line out instead of one per slot. No second walk was written and no backend
|
||||
change was needed.
|
||||
|
||||
The verb is `(:op "inspect" :frame N :slot I :path (...))`. A path step is a string for a struct field, an integer for
|
||||
an array or slice element, and the symbol `some` for an option's payload; a union case's field is spelled
|
||||
`Union.case.field`, because the payload's offset depends on which case the value is in and only the renderer knows
|
||||
which case it currently holds — it wrote the head `(Union.case {…})`. Guessing the case from a field name two cases
|
||||
share would read one case's layout over another's payload. Every step that does not fit the type in hand is refused
|
||||
by name with its reason. A pointer is still never followed; that is the renderer's rule and not this mode's.
|
||||
|
||||
**The slot travels by index, not by name.** `check.ml`'s `fresh_slot` only ever allocates, so `(let [v 22] …)` inside
|
||||
`(let [v 11] …)` is two slots both called `v` and both are in the listing; and a refused slot is not in the listing at
|
||||
all, so its position there is not an identifier either. `locals` therefore puts the slot index on each entry as a
|
||||
fourth element, and that is what the break buffer hands back.
|
||||
|
||||
**The frame checks are the listing's, by construction.** `Dev.stopped_frame` is one function and `locals`, `globals`
|
||||
and `inspect` all go through it: alive, stopped, the frame exists, it is the program's and not a `C-x C-e` thunk's,
|
||||
its body is one this session holds, the slot count matches, and `Emit.slot_fingerprint` matches. An inspector with its
|
||||
own copy of those conditions would be free to read a frame whose body was redefined since it was entered, which is
|
||||
precisely the stale-slot answer the listing refuses. `inspect` adds one refusal of its own, for the listing's reason:
|
||||
an unbound slot is a null address and a thunk that read it would fault on the game thread of a program that is already
|
||||
stopped.
|
||||
|
||||
### What each root cannot do that the other can
|
||||
|
||||
Both are wanted and the buffer says which it is on.
|
||||
|
||||
**The expression root** works on a **running** program and starts from anything you can write, a call included. It
|
||||
cannot name a frame — that is the bug — and it cannot reach an option's payload, because the compiler gets at that as
|
||||
field 1 and nothing in the surface language does.
|
||||
|
||||
**The slot root** is exact to one frame and one slot, and it reaches an option's payload and a union case's fields,
|
||||
which have offsets but no accessor form to write. It needs a **stopped** program, it is refused when the frame's body
|
||||
was redefined since it was entered — the same fingerprint the listing is refused by — and it cannot root at an
|
||||
expression at all, so `g` after the program resumes is refused rather than quietly answered from somewhere else.
|
||||
|
||||
A refusal someone can read is the point of the second one existing. The failure being fixed was not "no answer", it
|
||||
was a confident answer from the wrong place.
|
||||
|
||||
### `l` does not cross between them, structurally
|
||||
|
||||
A stack entry in `flan-inspect.el` is `(ROOT PATH . POINT)`. `RET` only ever appends a step to the path under the root
|
||||
the buffer already has, and every new root — `flan-inspect`, `flan-inspect-slot` — starts with an empty stack. A stack
|
||||
with two kinds of root in it therefore cannot be constructed, so the question of what `l` should do when it crosses
|
||||
one does not arise. That stays true if a third rooting mode is added, which is why it is worth having as structure
|
||||
rather than as a rule in a comment.
|
||||
|
||||
The Emacs state is a root plus a path rather than a retained value for the same reason the expression stack was:
|
||||
nothing on this side can hold a Flan value. A value has no header, the thunk that rendered it is `dlclose`d the moment
|
||||
it returns, and there is no heap to retain it in. So every step and every `g` is a fresh request, which is what keeps
|
||||
the view from ever being stale — and it is also why `g` is a key someone presses rather than a timer, since an
|
||||
expression root with an effect in it would fire once a second for ever.
|
||||
|
||||
**One wire detail worth recording.** An empty `:path` is sent by omission. Emacs prints an empty list as `nil`, which
|
||||
is a symbol on the wire and would be read as a step, so there is no way for a client in that language to spell `()`.
|
||||
The daemon reads a missing `:path` — and `nil` — as the slot itself.
|
||||
|
||||
39
DISCUSS.md
39
DISCUSS.md
@ -8,42 +8,11 @@ Settled decisions live in `NEXT.md`. Reasons for what already exists live in `BU
|
||||
|
||||
---
|
||||
|
||||
## 1. `i`, the inspector, and the frame it cannot see
|
||||
## 1. `i`, the inspector, and the frame it cannot see — answered and built
|
||||
|
||||
Two things got conflated here and they should be separated.
|
||||
|
||||
**What the inspector already does.** Most of what was asked for is built. `flan-inspect` opens its own buffer, lays a
|
||||
value's fields one per line, `RET` walks into one, `l` comes back, `g` re-reads. The renderer bounds its walk at depth 4
|
||||
and span 8, and entering a field renders *that field* from depth 0 — so the elision moves with you rather than
|
||||
truncating permanently. It is CIDER's inspector adapted, and the file says what the adaptation changed.
|
||||
|
||||
**What is actually missing** is detail on the leaves: a number shows in decimal only, with no hex and no binary, and a
|
||||
pointer does not show its address. Purely additive, small, and worth doing.
|
||||
|
||||
**The real problem, and it is sharper than "a bug".** The locals listing renders from each frame's own slot addresses,
|
||||
so it is frame-accurate. The inspector is built on a stack of **expressions** — going into a field means sending a
|
||||
different expression (`(.pos b)` where the last was `b`), and `l` works by popping back to the previous one. That design
|
||||
is forced: a Flan value has no header, the thunk that rendered it is `dlclose`d as soon as it returns, and there is no
|
||||
heap to retain anything in, so nothing can be held server-side the way CIDER holds a JVM object.
|
||||
|
||||
The consequence is that `i` evaluates a name wherever the evaluator stands, **not in the frame being looked at**. On the
|
||||
innermost frame that happens to be right. On any other it may resolve to a global, to a different binding, or fail —
|
||||
with nothing saying so.
|
||||
|
||||
**An earlier suggestion in this conversation — "root the inspector at the slot's address" — does not work**, and the
|
||||
reason is worth keeping: an address is not an expression, so the first `RET` has nothing to build the next expression
|
||||
from and navigation dies at step one. Recorded because it is the obvious fix and it is wrong.
|
||||
|
||||
So the options are genuinely three, and none is free:
|
||||
|
||||
1. **Teach the program to evaluate an expression relative to a frame.** The most useful and the most work: the frame's
|
||||
slots would have to be in scope for a compiled thunk, which means the daemon building a thunk whose free names bind
|
||||
to that frame's addresses. It would also fix `C-x C-e` while stopped, which has the same blindness.
|
||||
2. **Give the inspector a second rooting mode** — an address root that can still walk, by carrying a type alongside the
|
||||
address and stepping to a field's address rather than to a sub-expression. Navigation then works, but the two modes
|
||||
have different capabilities and `l` has to cross between them.
|
||||
3. **Refuse `i` outside the innermost frame**, honestly and by name. Cheapest, and it gives up the feature exactly where
|
||||
it is most wanted, since the innermost frame is the one already fully visible.
|
||||
Answered, and built as option 2. `BUILT.md`'s "Two ways to root a walk, and why neither subsumes the other" is where
|
||||
it lives now, including the correction to what this entry said about rooting at an address. The number is kept because
|
||||
other files cite these by number; nothing here is open.
|
||||
|
||||
## 2. Annotating the IR and the disassembly with the source
|
||||
|
||||
|
||||
15
NEXT.md
15
NEXT.md
@ -710,16 +710,11 @@ op that compiles on first use and a cheap re-invoke per tick.
|
||||
The author also raised **ghost text** as an alternative or addition to a dedicated buffer — values shown inline at the
|
||||
code they belong to. Not designed; the buffer is the port, ghost text is a further question.
|
||||
|
||||
**The inspector gets a second way to start: an address and a type.** Closes the hole in `DISCUSS.md` item 1, where `i`
|
||||
on a local in any frame but the innermost evaluates a name wherever the evaluator stands rather than in that frame, and
|
||||
may silently inspect something else.
|
||||
|
||||
The inspector navigates by rewriting *expressions* — `(.pos b)` where the last was `b` — and `l` pops back. That is
|
||||
why the obvious fix, rooting it at the slot's address, was rejected: an address is not an expression, so the first
|
||||
`RET` has nothing to build from. **The shadow stack changed this.** The daemon now has a frame's address and every
|
||||
slot's type, so the second rooting mode is cheap: start from an address plus a type, and stepping into a field is
|
||||
address-plus-offset with the field's type. `Render.render` already does exactly that arithmetic for locals, and
|
||||
navigation keeps working, which was the objection.
|
||||
~~**The inspector gets a second way to start: an address and a type.**~~ **Built.** See `BUILT.md`, "Two ways to root
|
||||
a walk, and why neither subsumes the other". It went in as a frame and a slot *index* rather than an address and a
|
||||
type — the daemon holds both and an index is the thing the listing can hand back, while an address is not something an
|
||||
editor should be holding. The one prediction that did not survive contact: `l` crossing between the two modes was
|
||||
listed as a cost and is not one, because a stack entry carries its own root and a mixed stack cannot be built.
|
||||
|
||||
**Structural typing requires identical layout — same fields, same types, same order.** Settled by the author, and it
|
||||
makes the feature simple rather than hard: structural compatibility becomes "the same memory", which costs nothing at
|
||||
|
||||
@ -145,7 +145,7 @@ Keys in that buffer:
|
||||
| `TAB` / `n` | next restart |
|
||||
| `S-TAB` / `p` | previous |
|
||||
| `f` | fold a stack frame open or closed |
|
||||
| `i` | inspect a local variable |
|
||||
| `i` | inspect the local or global at point |
|
||||
| `a` | abort |
|
||||
| `g` | read the program again |
|
||||
| `q` | close the buffer |
|
||||
@ -198,11 +198,40 @@ Two things worth knowing, because they are unlike other inspectors.
|
||||
**The view is never stale.** Every step reads the program as it is *now*. Most
|
||||
inspectors show you the object as it was when you opened it.
|
||||
|
||||
**The root expression runs again on every step.** Going into a field sends a new
|
||||
expression — `(.pos b)` where the last one was `b`. Appending a field name is
|
||||
harmless, but the root 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.
|
||||
**The root runs again on every step.** Going into a field sends a new request,
|
||||
not a lookup in something remembered. Appending a field name to an expression
|
||||
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
|
||||
|
||||
There are two, 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.
|
||||
It works on a **running** program and starts from anything you can write,
|
||||
including a call. It cannot name a frame: an expression is evaluated where the
|
||||
evaluator stands, so a local's name reaches that local only when its frame is
|
||||
the innermost one. And it cannot reach an option's payload, because nothing in
|
||||
the language names it.
|
||||
|
||||
**A frame and a slot** — `i` on a local line in the break buffer. It is exact
|
||||
to one frame and one slot, so the value you get is the one the listing above it
|
||||
drew. It reaches an **option's payload** and a **union case's fields**, which
|
||||
have offsets but no accessor form to write. In exchange it needs a **stopped**
|
||||
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.
|
||||
|
||||
**`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
|
||||
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.
|
||||
|
||||
---
|
||||
|
||||
@ -463,8 +492,14 @@ does" — at no cost in duplication. And the order is **by the innermost frame
|
||||
that touches it**, because a deep stack makes the union large and proximity to
|
||||
the error is what puts the likely culprit on top.
|
||||
|
||||
`i` works on a global line exactly as it does on a local: a global's name is an
|
||||
expression, so the inspector can be pointed at it with nothing new.
|
||||
`i` works on a global line, and it roots differently there than on a local —
|
||||
which is the fix rather than an inconsistency. A global really is reached by
|
||||
name: the thunk the daemon loads binds to the program's own storage through the
|
||||
dynamic linker, so the name means the same thing wherever it is evaluated. A
|
||||
local is storage in one frame, and its name evaluated anywhere else may find a
|
||||
global, another binding of the same name, or nothing. So a local goes in by
|
||||
frame and slot index — the same two facts the listing was drawn from — and a
|
||||
global by name. See "Two ways to root a walk" above for what each can reach.
|
||||
|
||||
Two things are said rather than left out. A global whose type the structural
|
||||
printer has no arm for is refused by name with the reason. And a frame the
|
||||
|
||||
@ -47,6 +47,7 @@
|
||||
|
||||
(declare-function flan-dev--request "flan-dev" (form))
|
||||
(declare-function flan-inspect "flan-inspect" (expr))
|
||||
(declare-function flan-inspect-slot "flan-inspect" (frame slot name))
|
||||
|
||||
(defgroup flan-cnr nil
|
||||
"The conditions and restarts buffer."
|
||||
@ -257,9 +258,19 @@ its use, because it is a fact about the prelude.")
|
||||
(insert (format " %s %s = %s\n"
|
||||
(propertize (nth 1 l) 'face 'font-lock-type-face)
|
||||
(nth 0 l) (nth 2 l)))
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-inspect (nth 0 l)
|
||||
'mouse-face 'highlight)))))))))))
|
||||
;; The slot's *index*, which is the fourth element the
|
||||
;; `locals\=' reply now puts on each line, and not its name.
|
||||
;; A name does not identify a slot: two slots of one frame
|
||||
;; can share one, and a refused slot is absent from this
|
||||
;; list, so the position in it is not an identifier
|
||||
;; either. Sending the name is precisely the old bug —
|
||||
;; the name was evaluated as an expression wherever the
|
||||
;; evaluator stood, which is the right frame only when
|
||||
;; this is the innermost one.
|
||||
(add-text-properties
|
||||
start (point)
|
||||
(list 'flan-cnr-inspect (list :slot i (nth 3 l) (nth 0 l))
|
||||
'mouse-face 'highlight)))))))))))
|
||||
(insert "\n"))
|
||||
|
||||
(defun flan-cnr--insert-globals (state)
|
||||
@ -307,7 +318,7 @@ puts the likely culprit on top."
|
||||
;; global exactly as it reaches a local: a global *is* an
|
||||
;; expression in the source, which is what the inspector needs.
|
||||
(add-text-properties start (point)
|
||||
(list 'flan-cnr-inspect (nth 0 g)
|
||||
(list 'flan-cnr-inspect (list :expr (nth 0 g))
|
||||
'mouse-face 'highlight)))))
|
||||
(dolist (r refused)
|
||||
(insert (format " %s%s\n"
|
||||
@ -430,10 +441,19 @@ puts the likely culprit on top."
|
||||
(forward-line (1- line)))))
|
||||
|
||||
(defun flan-cnr-inspect ()
|
||||
"Open the inspector on the thing at point."
|
||||
"Open the inspector on the thing at point.
|
||||
|
||||
A local and a global reach it by different roots, and that is the fix rather
|
||||
than an inconsistency. A global is reached by *name*: the loaded thunk binds
|
||||
to the program's own storage through the dynamic linker, so its name is an
|
||||
expression that means the same thing wherever it is evaluated. A local is
|
||||
not — it is storage in one frame, and its name evaluated anywhere else may
|
||||
find a global, another binding of the same name, or nothing. So a local goes
|
||||
in by frame and slot index, which is what the listing above it is already
|
||||
drawn from."
|
||||
(interactive)
|
||||
(let ((expr (get-text-property (point) 'flan-cnr-inspect)))
|
||||
(unless expr
|
||||
(let ((root (get-text-property (point) 'flan-cnr-inspect)))
|
||||
(unless root
|
||||
;; Two different misses, and saying the wrong one sends someone looking
|
||||
;; for a missing feature when they are one keystroke away. Being *on* a
|
||||
;; frame is the common case — the frame line is what the eye lands on —
|
||||
@ -443,7 +463,10 @@ puts the likely culprit on top."
|
||||
"flan: this is the frame's own line; TAB opens it, then i on a local"
|
||||
"flan: point is not on a local or a global — TAB opens a frame, i inspects a local in it or a global below")))
|
||||
(require 'flan-inspect)
|
||||
(flan-inspect expr)))
|
||||
(pcase root
|
||||
(`(:slot ,frame ,slot ,name) (flan-inspect-slot frame slot name))
|
||||
(`(:expr ,expr) (flan-inspect expr))
|
||||
(_ (user-error "flan: this line carries no root the inspector knows")))))
|
||||
|
||||
(defun flan-cnr-refresh ()
|
||||
"Ask the program again what it is offering."
|
||||
|
||||
@ -33,6 +33,47 @@
|
||||
;; (lib/session.ml). A field past either bound comes back as `...' and no
|
||||
;; amount of squinting at the echo area recovers it. Re-rooting the walk at
|
||||
;; that field renders it from depth 0 — the bound moves with you.
|
||||
;;
|
||||
;;; Two ways to root a walk, and why there had to be a second
|
||||
;;
|
||||
;; Everything above describes the *expression* root, and it has one hole: an
|
||||
;; expression is evaluated where the evaluator stands. `i' on a local in the
|
||||
;; break buffer used to send that local's name, and on the innermost frame
|
||||
;; that lands in the right frame by luck. On any other it may resolve to a
|
||||
;; global, to another binding of the same name, or to nothing — with the
|
||||
;; locals listing right above it showing the frame's own storage, because that
|
||||
;; listing renders from each frame's slot addresses and is frame-accurate.
|
||||
;; The display was right and this buffer was not.
|
||||
;;
|
||||
;; Rooting at the slot's address alone does not fix it, and that was tried:
|
||||
;; an address is not an expression, so the first RET has nothing to build
|
||||
;; from. What the shadow stack changed is that the *step* does not have to be
|
||||
;; an expression either. The daemon has the frame's address and every slot's
|
||||
;; type, so going into a field is an address plus an offset with that field's
|
||||
;; type — the arithmetic `Render.render' already does for the listing. So
|
||||
;; there is a second rooting mode here, `flan-inspect-slot', and the daemon
|
||||
;; verb behind it is `(:op "inspect" :frame N :slot I :path (...))'.
|
||||
;;
|
||||
;; The two roots are not equally capable and the buffer says which it is on:
|
||||
;;
|
||||
;; the expression root works on a *running* program and roots at anything
|
||||
;; you can write, a call included. It cannot reach an option's payload,
|
||||
;; because Flan has no accessor form that does, and it cannot say which
|
||||
;; frame it means;
|
||||
;;
|
||||
;; the slot root names one frame and one slot, so it is exact, and it
|
||||
;; reaches an option's payload and a union case's fields, which have offsets
|
||||
;; but no accessor. It needs a stopped program, it is refused if the
|
||||
;; frame's body was redefined since it was entered — the same slot
|
||||
;; fingerprint the listing is refused by — and it cannot root at an
|
||||
;; expression, so `g' after the program resumes is refused rather than
|
||||
;; quietly answered from somewhere else.
|
||||
;;
|
||||
;; `l' never crosses between them, and that is structural rather than a rule:
|
||||
;; a stack entry carries its own root, RET only ever extends the path under
|
||||
;; the root it already has, and every new root — `flan-inspect',
|
||||
;; `flan-inspect-slot' — starts with an empty stack. So a mixed stack cannot
|
||||
;; be built, and that stays true if a third rooting mode is ever added.
|
||||
|
||||
;;; Code:
|
||||
|
||||
@ -219,27 +260,88 @@ reply without a daemon behind them, and so that this file names
|
||||
;; work without a handle to retain.
|
||||
|
||||
(defun flan-inspect-step-expr (expr step)
|
||||
"The Flan expression reaching STEP inside EXPR."
|
||||
"The Flan expression reaching STEP inside EXPR.
|
||||
A `:field' step may carry the type it was read out of, for the slot root's
|
||||
benefit; here it is ignored, because an accessor is written the same way
|
||||
whatever the value came from."
|
||||
(pcase step
|
||||
(`(:field ,name) (format "(.%s %s)" name expr))
|
||||
(`(:field ,name . ,_) (format "(.%s %s)" name expr))
|
||||
(`(:index ,i) (format "(at %s %d)" expr i))
|
||||
(_ expr)))
|
||||
|
||||
;;; Where a field is, said as an offset
|
||||
|
||||
;; The slot root's version of the same step, and it is not source: the daemon
|
||||
;; is walking a type, so a field is its name and an element is its number.
|
||||
;; Two cases need more than the name.
|
||||
;;
|
||||
;; A union's payload sits at an offset that depends on which case the value
|
||||
;; is in, and only the renderer knows which case it currently is — it wrote
|
||||
;; `(Union.case {.f …})'. So the type travels with the step and the wire
|
||||
;; spelling is `Union.case.f'. Guessing the case from a field name two
|
||||
;; cases share would read one case's layout over another's payload.
|
||||
;;
|
||||
;; An option's payload has no name at all; it is the symbol `some'.
|
||||
|
||||
(defun flan-inspect-wire-step (step)
|
||||
"STEP as the `inspect' op spells it."
|
||||
(pcase step
|
||||
(`(:field ,name ,type)
|
||||
(if (and (stringp type) (string-match-p "\\." type))
|
||||
(concat type "." name)
|
||||
name))
|
||||
(`(:field ,name) name)
|
||||
(`(:index ,i) i)
|
||||
(`(:some) 'some)
|
||||
(_ (format "%s" step))))
|
||||
|
||||
;;; 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.
|
||||
|
||||
(defun flan-inspect--root-label (root path)
|
||||
"How ROOT walked by PATH is named at the top of the buffer and in the trail."
|
||||
(pcase root
|
||||
(`(:expr ,expr)
|
||||
(seq-reduce #'flan-inspect-step-expr path expr))
|
||||
(`(:slot ,frame ,_slot ,name)
|
||||
(concat (format "%s [frame %d]" name frame)
|
||||
(mapconcat (lambda (s)
|
||||
(pcase s
|
||||
(`(:field ,f . ,_) (concat "." f))
|
||||
(`(:index ,i) (format "[%d]" i))
|
||||
(`(:some) ".some")
|
||||
(_ "")))
|
||||
path "")))
|
||||
(_ "?")))
|
||||
|
||||
;;; Why a thing cannot be entered
|
||||
|
||||
;; Every refusal is by name and carries its reason, because the alternative —
|
||||
;; RET doing nothing on some lines and something on others — is a UI that
|
||||
;; teaches you nothing about the language.
|
||||
|
||||
(defun flan-inspect-refusal (node)
|
||||
"Why NODE cannot be inspected, or nil if it can."
|
||||
(defun flan-inspect-refusal (node &optional root)
|
||||
"Why NODE cannot be inspected, or nil if it can.
|
||||
ROOT is the root the walk is on, because two of these are refusals of the
|
||||
*expression* root rather than of the value. Omitted means the expression
|
||||
root, which is the older and the more limited of the two."
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (and (null (plist-get node :children))
|
||||
"a struct with no fields the renderer could reach"))
|
||||
('seq (and (null (plist-get node :children))
|
||||
"an empty sequence: there is no element to go into"))
|
||||
('option
|
||||
"an option's payload: Flan has no accessor form that reaches it, so there is no expression to send")
|
||||
;; The one place the two roots differ in the slot root's favour, and it
|
||||
;; is worth saying which it is rather than refusing flatly: the payload
|
||||
;; is field 1 and the compiler reaches it there, so an address root steps
|
||||
;; into it by offset. Nothing in the surface language does, so an
|
||||
;; expression root has nothing to send.
|
||||
(and (not (eq (car-safe root) :slot))
|
||||
"an option's payload: Flan has no accessor form that reaches it, so there is no expression to send. `i' on a local in the break buffer roots at the slot's address instead, and that root can step into it"))
|
||||
('ptr
|
||||
;; And its address is not here either. `Render.render' (lib/render.ml)
|
||||
;; writes the bare word `<ptr>' for every pointer, on purpose: it is the
|
||||
@ -258,10 +360,25 @@ reply without a daemon behind them, and so that this file names
|
||||
|
||||
;;; Drawing it
|
||||
|
||||
(defvar-local flan-inspect--root nil
|
||||
"What this buffer's walk starts from.
|
||||
Either `(:expr EXPR)\=' or `(:slot FRAME SLOT NAME)\='.")
|
||||
(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
|
||||
path rather than a remembered value because nothing here can retain a Flan
|
||||
value: every step is a fresh request, which is what keeps the view current.")
|
||||
(defvar-local flan-inspect--stack nil
|
||||
"Where we have been: a list of (EXPR . POINT), innermost last-pushed first.")
|
||||
(defvar-local flan-inspect--expr nil "The expression this buffer is showing.")
|
||||
(defvar-local flan-inspect--node nil "Its parsed value.")
|
||||
"Where we have been: a list of (ROOT PATH . POINT), last-pushed first.
|
||||
Each entry carries its own root, which is what makes `l\=' unable to cross
|
||||
between two kinds of root: it can only ever restore a pair that was pushed
|
||||
whole.")
|
||||
(defvar-local flan-inspect--node nil "The parsed value being shown.")
|
||||
(defvar-local flan-inspect--type nil
|
||||
"The type the daemon said the walk ended at, or nil if it did not say.
|
||||
Only the slot root answers with one — it is walking a type, so it knows. An
|
||||
expression root gets back a rendering and nothing else, and the rendering of
|
||||
an atom does not carry its type.")
|
||||
|
||||
(defun flan-inspect--label (child)
|
||||
"How CHILD is named in the list: `0.' for an element, `.x' for a field.
|
||||
@ -334,18 +451,27 @@ stated honestly — every Flan integer is rendered through i64."
|
||||
('option (format "(some …)"))
|
||||
(_ (plist-get node :text))))
|
||||
|
||||
(defun flan-inspect--render (expr node stack)
|
||||
"Draw NODE, reached by EXPR, with STACK behind it."
|
||||
(defun flan-inspect--render (root path node stack &optional declared)
|
||||
"Draw NODE, reached by ROOT walked by PATH, with STACK behind it.
|
||||
DECLARED is the type the daemon named, when it named one."
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert (propertize expr 'face 'font-lock-function-name-face) "\n")
|
||||
(insert (propertize (flan-inspect--root-label root path)
|
||||
'face 'font-lock-function-name-face)
|
||||
"\n")
|
||||
;; The declared type wins over the one read back out of the rendering,
|
||||
;; because it is the better fact and only one root can supply it: the slot
|
||||
;; root is walking `Tast.fn.slots\=' and knows `i64\=' where the rendering says
|
||||
;; only `7\='. An expression root has nothing but the rendering.
|
||||
(insert (propertize
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (format "a %s\n" (plist-get node :type)))
|
||||
('seq (format "%s\n" (plist-get node :text)))
|
||||
('option "an option\n")
|
||||
('ptr "a pointer — never followed\n")
|
||||
(_ (format "%s\n" (plist-get node :text))))
|
||||
(if declared
|
||||
(format "%s\n" declared)
|
||||
(pcase (plist-get node :kind)
|
||||
('struct (format "a %s\n" (plist-get node :type)))
|
||||
('seq (format "%s\n" (plist-get node :text)))
|
||||
('option "an option\n")
|
||||
('ptr "a pointer — never followed\n")
|
||||
(_ (format "%s\n" (plist-get node :text)))))
|
||||
'face 'font-lock-type-face))
|
||||
;; The other bases, under the value rather than beside it: this is the line
|
||||
;; someone opened the inspector on a number *for*, and it is long.
|
||||
@ -357,7 +483,12 @@ stated honestly — every Flan integer is rendered through i64."
|
||||
(when stack
|
||||
(insert (propertize
|
||||
(concat " via "
|
||||
(string-join (reverse (mapcar #'car stack)) " > ")
|
||||
(string-join
|
||||
(reverse (mapcar (lambda (e)
|
||||
(flan-inspect--root-label
|
||||
(car e) (cadr e)))
|
||||
stack))
|
||||
" > ")
|
||||
" > here\n")
|
||||
'face 'shadow)))
|
||||
(insert "\n")
|
||||
@ -395,7 +526,8 @@ stated honestly — every Flan integer is rendered through i64."
|
||||
'face 'font-lock-warning-face))))
|
||||
(t
|
||||
(insert (propertize
|
||||
(format "Nothing to go into: %s\n" (flan-inspect-refusal node))
|
||||
(format "Nothing to go into: %s\n"
|
||||
(flan-inspect-refusal node root))
|
||||
'face 'font-lock-comment-face)))))
|
||||
(insert "\n")
|
||||
(insert (propertize
|
||||
@ -405,70 +537,154 @@ stated honestly — every Flan integer is rendered through i64."
|
||||
|
||||
;;; The commands
|
||||
|
||||
(defun flan-inspect--value (expr)
|
||||
"Ask the program for EXPR's value, rendered. Signals if it refuses."
|
||||
(let ((r (funcall flan-inspect-request-function
|
||||
(list :op "eval-expr" :code expr :file "<inspect>"))))
|
||||
(defun flan-inspect--value (root path)
|
||||
"Ask the program what ROOT walked by PATH holds.
|
||||
Returns (RENDERED . TYPE), TYPE nil when the reply did not name one. Signals
|
||||
if the program refuses — and it is allowed to: a slot root over a frame whose
|
||||
body was redefined is refused by the same fingerprint the locals listing is
|
||||
refused by, and answering from somewhere else instead is the bug this second
|
||||
root exists to fix."
|
||||
(let ((r (pcase root
|
||||
(`(:expr ,_)
|
||||
(funcall flan-inspect-request-function
|
||||
(list :op "eval-expr"
|
||||
:code (flan-inspect--root-label root path)
|
||||
:file "<inspect>")))
|
||||
(`(:slot ,frame ,slot ,_name)
|
||||
(funcall flan-inspect-request-function
|
||||
;; `:path\=' is omitted rather than sent empty, because
|
||||
;; Emacs cannot print an empty list as anything but
|
||||
;; `nil\=', which is a symbol on the wire and not a list.
|
||||
;; A missing `:path\=' is the slot itself, which is what
|
||||
;; an empty path means.
|
||||
(append (list :op "inspect" :frame frame :slot slot)
|
||||
(when path
|
||||
(list :path
|
||||
(mapcar #'flan-inspect-wire-step path))))))
|
||||
(_ (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")))
|
||||
(or (plist-get r :value)
|
||||
(user-error "flan: the program answered without a value for %s" expr))))
|
||||
(cons (or (plist-get r :value)
|
||||
(user-error "flan: the program answered without a value for %s"
|
||||
(flan-inspect--root-label root path)))
|
||||
(plist-get r :type))))
|
||||
|
||||
(defun flan-inspect--show (expr &optional stack)
|
||||
"Render EXPR in the inspector buffer, with STACK behind it."
|
||||
(let ((value (flan-inspect--value expr))
|
||||
(defun flan-inspect--show (root path &optional stack)
|
||||
"Render ROOT walked by PATH in the inspector buffer, with STACK behind it."
|
||||
(let ((answer (flan-inspect--value root path))
|
||||
(buf (get-buffer-create flan-inspect-buffer)))
|
||||
(with-current-buffer buf
|
||||
(unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
|
||||
(setq flan-inspect--expr expr)
|
||||
(setq flan-inspect--node (flan-inspect-parse value))
|
||||
(setq flan-inspect--root root)
|
||||
(setq flan-inspect--path path)
|
||||
(setq flan-inspect--node (flan-inspect-parse (car answer)))
|
||||
(setq flan-inspect--type (cdr answer))
|
||||
(setq flan-inspect--stack stack)
|
||||
(flan-inspect--render expr flan-inspect--node stack))
|
||||
(flan-inspect--render root path flan-inspect--node stack
|
||||
flan-inspect--type))
|
||||
(display-buffer buf)
|
||||
buf))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-inspect (expr)
|
||||
"Inspect the value of EXPR in the running program.
|
||||
Interactively, the expression before point, or one you type."
|
||||
Interactively, the expression before point, or one you type.
|
||||
|
||||
This is the expression root: EXPR is evaluated where the evaluator stands, so
|
||||
it works on a running program but cannot say which frame it means. `i\=' in the
|
||||
break buffer uses `flan-inspect-slot\=' for a local, for exactly that reason."
|
||||
(interactive
|
||||
(list (read-string "Inspect: "
|
||||
(ignore-errors
|
||||
(buffer-substring-no-properties
|
||||
(save-excursion (backward-sexp) (point)) (point))))))
|
||||
(flan-inspect--show expr nil))
|
||||
;; A new root, and therefore an empty stack. That is the whole of why `l\='
|
||||
;; cannot walk out of one root into another: there is never an entry from a
|
||||
;; different root left underneath it.
|
||||
(flan-inspect--show (list :expr expr) nil nil))
|
||||
|
||||
;;;###autoload
|
||||
(defun flan-inspect-slot (frame slot name)
|
||||
"Inspect slot SLOT of stopped FRAME, which is called NAME.
|
||||
The slot root. SLOT is an index and not a name, because a name is not an
|
||||
identifier: two slots of one frame can share one, and a slot the daemon
|
||||
refused is not in the listing at all, so neither the name nor the position in
|
||||
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))
|
||||
|
||||
(defun flan-inspect-into ()
|
||||
"Go into the field or element at point."
|
||||
"Go into the field or element at point.
|
||||
Extends the path under the root this buffer already has; it never replaces the
|
||||
root, which is what makes a mixed stack unconstructible."
|
||||
(interactive)
|
||||
(let ((step (get-text-property (point) 'flan-inspect-step))
|
||||
(node (get-text-property (point) 'flan-inspect-node)))
|
||||
(unless step (user-error "flan: nothing to inspect on this line"))
|
||||
(let ((why (flan-inspect-refusal node)))
|
||||
(let ((why (flan-inspect-refusal node flan-inspect--root)))
|
||||
(when why (user-error "flan: %s" why)))
|
||||
(let ((expr (flan-inspect-step-expr flan-inspect--expr step))
|
||||
(stack (cons (cons flan-inspect--expr (point)) flan-inspect--stack)))
|
||||
(flan-inspect--show expr stack))))
|
||||
;; A union case's field, under an expression root. This is a refusal of
|
||||
;; the *parent* and not of the value at point, which is why it is here and
|
||||
;; not in `flan-inspect-refusal\=': a struct field that happens to hold a
|
||||
;; union is reached by an ordinary accessor and must stay enterable; it is
|
||||
;; a field *of the union itself* that has no accessor. `(match ...)\=' is
|
||||
;; how a union is opened in the language, and it binds names rather than
|
||||
;; producing a value to send, so there is nothing to build here. The
|
||||
;; renderer wrote the head as `Union.case\=', which is the one type spelling
|
||||
;; with a dot in it — a package qualifies with a slash.
|
||||
(let ((ty (plist-get flan-inspect--node :type)))
|
||||
(when (and (not (eq (car-safe flan-inspect--root) :slot))
|
||||
(stringp ty)
|
||||
(string-match-p "\\." ty))
|
||||
(user-error
|
||||
"flan: %s"
|
||||
(concat "a union case's field: it is reached by (match ...) in the "
|
||||
"language, not by an accessor, so there is no expression to "
|
||||
"send. `i' on a local in the break buffer roots at the frame's "
|
||||
"slot instead, and that root steps into it by offset"))))
|
||||
;; The line carries the step that names the field; what the wire needs
|
||||
;; beyond the name is the type it is a field *of*, and that is this
|
||||
;; buffer's own node — the parent of the one at point. A union's payload
|
||||
;; sits at an offset that depends on the case, so `Union.case\=' has to
|
||||
;; travel with the name. An option's payload has no name at all and is
|
||||
;; the symbol `some\='.
|
||||
(let* ((step (if (eq (plist-get flan-inspect--node :kind) 'option)
|
||||
(list :some)
|
||||
(pcase step
|
||||
(`(:field ,name)
|
||||
(list :field name (plist-get flan-inspect--node :type)))
|
||||
(_ step))))
|
||||
(path (append flan-inspect--path (list step)))
|
||||
(stack (cons (cons flan-inspect--root
|
||||
(cons flan-inspect--path (point)))
|
||||
flan-inspect--stack)))
|
||||
(flan-inspect--show flan-inspect--root path stack))))
|
||||
|
||||
(defun flan-inspect-pop ()
|
||||
"Back to the value you came from, at the line you left."
|
||||
"Back to the value you came from, at the line you left.
|
||||
The entry restored carries its own root, so this cannot land on a root other
|
||||
than the one it was pushed under."
|
||||
(interactive)
|
||||
(unless flan-inspect--stack
|
||||
(user-error "flan: this is the root; there is nothing behind it"))
|
||||
(let* ((top (car flan-inspect--stack))
|
||||
(rest (cdr flan-inspect--stack)))
|
||||
(flan-inspect--show (car top) rest)
|
||||
(flan-inspect--show (car top) (cadr top) rest)
|
||||
(with-current-buffer flan-inspect-buffer
|
||||
(goto-char (min (cdr top) (point-max))))))
|
||||
(goto-char (min (cddr top) (point-max))))))
|
||||
|
||||
(defun flan-inspect-refresh ()
|
||||
"Read the same expression again.
|
||||
Deliberately a key rather than a timer: the expression runs in the program,
|
||||
and a root with an effect in it would fire once a second forever."
|
||||
"Read the same root and path again.
|
||||
Deliberately a key rather than a timer: an expression root runs in the
|
||||
program, and a root with an effect in it would fire once a second forever. A
|
||||
slot root has no effect to repeat, but it can be refused — the program may
|
||||
have resumed, or the frame's body may have been redefined — and a refusal
|
||||
someone asked for reads very differently from one a timer produced."
|
||||
(interactive)
|
||||
(unless flan-inspect--expr (user-error "flan: nothing is being inspected"))
|
||||
(unless flan-inspect--root (user-error "flan: nothing is being inspected"))
|
||||
(let ((p (point)))
|
||||
(flan-inspect--show flan-inspect--expr flan-inspect--stack)
|
||||
(flan-inspect--show flan-inspect--root flan-inspect--path
|
||||
flan-inspect--stack)
|
||||
(with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))
|
||||
|
||||
(defun flan-inspect--fields ()
|
||||
|
||||
@ -213,12 +213,15 @@
|
||||
(message "\nthe inspector buffer")
|
||||
|
||||
(defun test-flan--inspect (expr rendered)
|
||||
"Draw EXPR's RENDERED value in a temp buffer and return it, live."
|
||||
"Draw EXPR's RENDERED value in a temp buffer and return it, live.
|
||||
The expression root, which is what most of the block below is about: the
|
||||
rooting the buffer has always had, and the one that still works on a running
|
||||
program."
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (_) (list :status "ok" :value rendered)))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion (flan-inspect--show expr nil))))
|
||||
(save-window-excursion (flan-inspect--show (list :expr expr) nil))))
|
||||
|
||||
(let* ((buf (test-flan--inspect
|
||||
"b" "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))
|
||||
@ -284,7 +287,7 @@
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(flan-inspect--show "b" nil)
|
||||
(flan-inspect--show '(:expr "b") nil)
|
||||
(with-current-buffer " *test-inspect*"
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) (flan-inspect-next) ; :pos
|
||||
@ -329,6 +332,211 @@
|
||||
(string-match-p "span bound of 8" text)))
|
||||
|
||||
|
||||
;;; The slot root
|
||||
|
||||
(message "\nthe slot root: a frame and a slot index")
|
||||
|
||||
;; The other rooting mode, and the reason it exists: an expression is
|
||||
;; evaluated where the evaluator stands, so a local's *name* names the right
|
||||
;; storage only on the innermost frame. This root names the frame.
|
||||
|
||||
(defvar test-flan--asked nil
|
||||
"Every request the last slot-root fixture sent, newest first.")
|
||||
|
||||
(defun test-flan--slot (frame slot name replies body)
|
||||
"Open the slot root on FRAME/SLOT/NAME and run BODY in its buffer.
|
||||
REPLIES answers each request. BODY runs *inside* the binding of
|
||||
`flan-inspect-request-function', which is not optional here: RET and `l' are
|
||||
further requests, so a helper that returned the buffer and let the binding
|
||||
unwind would send the next one to a daemon that is not there."
|
||||
(setq test-flan--asked nil)
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (push form test-flan--asked) (funcall replies form)))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(with-current-buffer (flan-inspect-slot frame slot name)
|
||||
(funcall body)))))
|
||||
|
||||
;; The header names the frame, which is the whole of what the expression root
|
||||
;; could not say, and the type comes from the reply rather than being read
|
||||
;; back out of the rendering — a rendering of `7' does not carry `i64'.
|
||||
(test-flan--slot
|
||||
1 3 "b"
|
||||
(lambda (_) (list :status "ok" :type "Blob"
|
||||
:value "(Blob {.id 7 .pos (V {.x 1.5 .y 0})})"))
|
||||
(lambda ()
|
||||
(let ((text (buffer-string)))
|
||||
(test-flan--check "the slot root names the frame in the header"
|
||||
(string-match-p "\\`b \\[frame 1\\]\n" text))
|
||||
(test-flan--check "and the daemon's type is what is shown"
|
||||
(string-match-p "\nBlob\n" text)))
|
||||
(test-flan--check "it asks the inspect op, not eval-expr"
|
||||
(equal (plist-get (car test-flan--asked) :op) "inspect"))
|
||||
(test-flan--check "with the frame and the slot index it was given"
|
||||
(and (= 1 (plist-get (car test-flan--asked) :frame))
|
||||
(= 3 (plist-get (car test-flan--asked) :slot))))
|
||||
;; An empty path is sent by *omission*: Emacs prints an empty list as
|
||||
;; `nil', which is a symbol on the wire and would be refused as a step.
|
||||
(test-flan--check "and no :path at all for the slot itself"
|
||||
(null (plist-get (car test-flan--asked) :path)))))
|
||||
|
||||
;; Going in extends the path. The root does not change, and that is what
|
||||
;; makes `l' unable to cross: every entry on the stack was pushed with the
|
||||
;; root it belongs to, so `l' can only ever restore a pair it built.
|
||||
(test-flan--slot
|
||||
1 3 "b"
|
||||
(lambda (form)
|
||||
(if (equal (plist-get form :path) '("pos"))
|
||||
(list :status "ok" :type "V" :value "(V {.x 1.5 .y 0})")
|
||||
(list :status "ok" :type "Blob"
|
||||
:value "(Blob {.id 7 .pos (V {.x 1.5 .y 0})})")))
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) (flan-inspect-next) ; .pos
|
||||
(flan-inspect-into)
|
||||
(test-flan--check "RET sends a path step, not an expression"
|
||||
(equal (plist-get (car test-flan--asked) :path) '("pos")))
|
||||
(test-flan--check "the header walks with it"
|
||||
(string-match-p "\\`b \\[frame 1\\]\\.pos\n" (buffer-string)))
|
||||
(test-flan--check "with the frame's own root behind it in the trail"
|
||||
(string-match-p "via b \\[frame 1\\] > here" (buffer-string)))
|
||||
(flan-inspect-pop)
|
||||
(test-flan--check "l shortens the path back to the root"
|
||||
(null (plist-get (car test-flan--asked) :path)))
|
||||
(test-flan--check "and the root never changed under it"
|
||||
(seq-every-p (lambda (f) (equal (plist-get f :op) "inspect"))
|
||||
test-flan--asked))
|
||||
(test-flan--check "so nothing was ever evaluated as an expression"
|
||||
(not (seq-some (lambda (f) (plist-get f :code))
|
||||
test-flan--asked)))
|
||||
(test-flan--check "and popping at the root refuses, as for an expression"
|
||||
(string-match-p
|
||||
"nothing behind it"
|
||||
(or (test-flan--caught #'flan-inspect-pop) "")))))
|
||||
|
||||
;; An option's payload: the one thing the slot root reaches and the expression
|
||||
;; root cannot, because Flan has no accessor form that names it. So the
|
||||
;; refusal is the *root's* and not the value's, and it has to be asked with
|
||||
;; the root in hand.
|
||||
(test-flan--check "an expression root refuses an option's payload"
|
||||
(string-match-p
|
||||
"no accessor form"
|
||||
(or (flan-inspect-refusal (flan-inspect-parse "(some 3)")
|
||||
'(:expr "o"))
|
||||
"")))
|
||||
(test-flan--check "a slot root does not"
|
||||
(null (flan-inspect-refusal (flan-inspect-parse "(some 3)")
|
||||
'(:slot 0 1 "o"))))
|
||||
|
||||
(test-flan--slot
|
||||
0 2 "o"
|
||||
(lambda (form)
|
||||
(if (plist-get form :path)
|
||||
(list :status "ok" :type "V" :value "(V {.x 1 .y 2})")
|
||||
(list :status "ok" :type "(Option V)" :value "(some (V {.x 1 .y 2}))")))
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(flan-inspect-into)
|
||||
;; The payload has no name, so the step is the symbol `some' and not a
|
||||
;; field called "some".
|
||||
(test-flan--check "RET into an option sends the symbol some"
|
||||
(equal (plist-get (car test-flan--asked) :path) '(some)))
|
||||
(test-flan--check "and the trail says so"
|
||||
(string-match-p "\\`o \\[frame 0\\]\\.some\n" (buffer-string)))))
|
||||
|
||||
;; A union case's field. The payload sits at an offset that depends on which
|
||||
;; case the value is in, and only the renderer knows which it currently holds
|
||||
;; — it wrote the head `Shape.circle'. So the case travels with the name.
|
||||
(test-flan--check "a union field carries its case on the wire"
|
||||
(equal (flan-inspect-wire-step '(:field "r" "Shape.circle"))
|
||||
"Shape.circle.r"))
|
||||
(test-flan--check "a struct field does not"
|
||||
(equal (flan-inspect-wire-step '(:field "x" "V")) "x"))
|
||||
(test-flan--check "an element is its number"
|
||||
(equal (flan-inspect-wire-step '(:index 2)) 2))
|
||||
|
||||
|
||||
;; And the other half of that pair: under an *expression* root there is no
|
||||
;; accessor to send, so RET refuses there rather than sending `(.at s)' for
|
||||
;; the checker to reject. A union's fields are reached by `(match ...)' in
|
||||
;; the language, which binds names rather than producing a value. It is a
|
||||
;; refusal of the parent, not of the value at point — a struct field that
|
||||
;; merely *holds* a union is an ordinary accessor and stays enterable.
|
||||
(let ((buf (test-flan--inspect "s" "(Shape.circle {.at (V {.x 1 .y 2})})")))
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(test-flan--check "an expression root refuses a union case's field"
|
||||
(string-match-p
|
||||
"reached by (match"
|
||||
(or (test-flan--caught #'flan-inspect-into) "")))))
|
||||
|
||||
(let ((asked nil))
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (push (plist-get form :code) asked)
|
||||
(list :status "ok"
|
||||
:value "(Cell {.id 1 .s (Shape.circle {.at (V {.x 1 .y 2})})})")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(when (get-buffer " *test-inspect*") (kill-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(flan-inspect--show '(:expr "c") nil)
|
||||
(with-current-buffer " *test-inspect*"
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) (flan-inspect-next) ; .s, which holds the union
|
||||
(test-flan--check "but a struct field that merely holds one is enterable"
|
||||
(progn (flan-inspect-into) (equal (car asked) "(.s c)")))))))
|
||||
|
||||
(test-flan--slot
|
||||
0 1 "s"
|
||||
(lambda (form)
|
||||
(if (plist-get form :path)
|
||||
(list :status "ok" :type "V" :value "(V {.x 1 .y 2})")
|
||||
(list :status "ok" :type "Shape"
|
||||
:value "(Shape.circle {.at (V {.x 1 .y 2})})")))
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(flan-inspect-into)
|
||||
(test-flan--check "RET into a union field names the case it is in"
|
||||
(equal (plist-get (car test-flan--asked) :path)
|
||||
'("Shape.circle.at")))))
|
||||
|
||||
;; The daemon is allowed to refuse — a program that resumed, or a frame whose
|
||||
;; body was redefined since it was entered — and the refusal has to reach the
|
||||
;; person rather than being answered from somewhere else. Being answered from
|
||||
;; somewhere else is the bug this root exists to fix, so it is asserted.
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (_)
|
||||
(list :status "error"
|
||||
:message "look's body was redefined since that frame was entered")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(test-flan--check "a refused slot root says why, and shows nothing"
|
||||
(string-match-p
|
||||
"redefined"
|
||||
(or (test-flan--caught
|
||||
(lambda () (flan-inspect-slot 0 1 "p")))
|
||||
""))))
|
||||
|
||||
;; And the structural claim about `l' from the other side: a new root always
|
||||
;; starts a fresh stack, so there is never an entry of another kind left
|
||||
;; underneath for `l' to land on.
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (if (equal (plist-get form :op) "inspect")
|
||||
(list :status "ok" :type "i32" :value "7")
|
||||
(list :status "ok" :value "9"))))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(flan-inspect-slot 1 3 "b")
|
||||
(flan-inspect "g")
|
||||
(with-current-buffer " *test-inspect*"
|
||||
(test-flan--check "a new root drops the stack it did not build"
|
||||
(null flan-inspect--stack))
|
||||
(test-flan--check "and l has nothing to cross back into"
|
||||
(string-match-p
|
||||
"nothing behind it"
|
||||
(or (test-flan--caught #'flan-inspect-pop) ""))))))
|
||||
|
||||
|
||||
;;; Restarts: which of them can be taken
|
||||
@ -458,8 +666,11 @@
|
||||
:restarts '("retry")
|
||||
:stack (list (list :fn "sim/settle" :loc "sand.flan:42:3"
|
||||
:fetched t
|
||||
:locals '(("i" "i32" "7")
|
||||
("b" "Blob" "(Blob {.id 7})")))
|
||||
;; Four elements now: the fourth is
|
||||
;; the slot's index, which is what `i'
|
||||
;; hands to the inspector.
|
||||
:locals '(("i" "i32" "7" 0)
|
||||
("b" "Blob" "(Blob {.id 7})" 1)))
|
||||
(list :fn "sim/step" :loc "sand.flan:60:1"
|
||||
:fetched t :locals nil))))
|
||||
(buf (test-flan--cnr state))
|
||||
@ -494,25 +705,41 @@
|
||||
(test-flan--check "and TAB again closes it"
|
||||
(not (string-match-p "i32 i = 7" (buffer-string))))))
|
||||
|
||||
;; The two buffers meet: `i' on a local opens the inspector on its name, which
|
||||
;; is an expression the program can be handed.
|
||||
;; The two buffers meet, and this is the fixture the bug lived in. `i' used
|
||||
;; to send the local's *name* to be evaluated, which resolves wherever the
|
||||
;; evaluator stands: right on the innermost frame by luck, and on any other
|
||||
;; frame a global, another binding of the same name, or nothing — with the
|
||||
;; listing right above it showing the frame's own storage and nothing saying
|
||||
;; the two disagree. It sends the frame and the slot index now.
|
||||
(let ((asked nil))
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (form) (push (plist-get form :code) asked)
|
||||
(list :status "ok" :value "(Blob {.id 7})")))
|
||||
(lambda (form) (push form asked)
|
||||
(list :status "ok" :type "Blob" :value "(Blob {.id 7})")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(with-current-buffer (test-flan--cnr
|
||||
(list :condition "Missing" :restarts '("retry")
|
||||
:stack (list (list :fn "f" :fetched t
|
||||
:locals '(("b" "Blob" "…"))))))
|
||||
:stack (list (list :fn "g" :fetched t
|
||||
:locals '(("b" "Blob" "…" 4)))
|
||||
(list :fn "f" :fetched t
|
||||
:locals '(("b" "Blob" "…" 2))))))
|
||||
(goto-char (point-min))
|
||||
(search-forward " 0: > f")
|
||||
(search-forward " 1: > f")
|
||||
(flan-cnr-toggle-frame)
|
||||
(goto-char (point-min))
|
||||
(search-forward " 1: v f")
|
||||
(search-forward "Blob b")
|
||||
(save-window-excursion (flan-cnr-inspect))
|
||||
(test-flan--check "`i' on a local inspects it by name"
|
||||
(equal (car asked) "b")))))
|
||||
(test-flan--check "`i' on a local inspects it by frame and slot"
|
||||
(equal (plist-get (car asked) :op) "inspect"))
|
||||
;; The outer frame, and its own slot index — the two facts a name cannot
|
||||
;; carry. Frame 1 has a `b' and so does frame 0; sending "b" would have
|
||||
;; reached whichever one the evaluator stands in.
|
||||
(test-flan--check "naming the frame the listing was drawn from"
|
||||
(= 1 (plist-get (car asked) :frame)))
|
||||
(test-flan--check "and the slot index that frame's listing gave"
|
||||
(= 2 (plist-get (car asked) :slot)))
|
||||
(test-flan--check "nothing is evaluated as an expression"
|
||||
(null (plist-get (car asked) :code))))))
|
||||
|
||||
;; `flan-cnr-show' refuses a running program by name rather than opening an
|
||||
;; empty buffer.
|
||||
@ -635,10 +862,10 @@
|
||||
;; inspector is built on.
|
||||
(with-current-buffer buf
|
||||
(goto-char (point-min))
|
||||
(test-flan--check "and a global line is inspectable"
|
||||
(test-flan--check "and a global line is inspectable, by expression"
|
||||
(progn (search-forward "pressure")
|
||||
(equal (get-text-property (point) 'flan-cnr-inspect)
|
||||
"pressure")))))
|
||||
'(:expr "pressure"))))))
|
||||
|
||||
;; Empty is a claim, not a gap: the section is the union of what the stack
|
||||
;; reaches, so nothing in it means the state is all in the locals.
|
||||
|
||||
475
lib/dev.ml
475
lib/dev.ml
@ -628,7 +628,17 @@ let layout t ~ty =
|
||||
List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname ty)
|
||||
t.session.Session.program.Tast.unions
|
||||
then
|
||||
error (ty ^ " is a union, not a struct; union values are milestone 6")
|
||||
(* Unions have landed, so "milestone 6" was stale — but what replaces it
|
||||
is not a layout. This op's reply is a flat [:fields] list, and a union
|
||||
is a tag and one payload per case: there is no one field list to
|
||||
answer with, and flattening the cases into one would describe storage
|
||||
no value ever has. So it says which kind of type this is, and where
|
||||
the question it was probably asked for *is* answered — the renderer
|
||||
walks a union now, so a union value prints in a frame's locals and at
|
||||
`C-x C-e' with its case and that case's fields. *)
|
||||
error
|
||||
(ty
|
||||
^ " is a union, not a struct; a union is a tag and one payload per case, so it has no single field list for this op to answer with. Its value renders with its case and fields in a frame's locals and at C-x C-e")
|
||||
else
|
||||
let suffix = "/" ^ ty in
|
||||
let candidates =
|
||||
@ -724,6 +734,115 @@ let backtrace_op t =
|
||||
Printf.sprintf ":more %d" more ]
|
||||
| Error m -> error ("the program refused to say where it is: " ^ m))
|
||||
|
||||
(* Build a render thunk, hand it to the program, and read back what it wrote.
|
||||
|
||||
The same five steps for every verb that renders something inside the
|
||||
stopped program — [locals], [globals] and [inspect] — and they are here
|
||||
once rather than three times because the note this file already carries
|
||||
about the fingerprint applies to plumbing too: four of five hand-offs
|
||||
present looks exactly like one hand-off dropping a step, and that is a bug
|
||||
nobody sees until the one path that lost it is the one being used.
|
||||
|
||||
[tag] only names the [.so] on disk, which is what someone reads when they
|
||||
go looking at [t.dir] to find out which verb produced what. *)
|
||||
let run_render_thunk t ~tag ~(c : Session.change) : (string, string) result =
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "%s%d.so" tag t.n) in
|
||||
match
|
||||
Build.shared
|
||||
~opts:{ Build.default with Build.dev = true;
|
||||
Build.debug = t.session.Session.debug }
|
||||
~ir:c.Session.ir ~out ()
|
||||
with
|
||||
| exception Failure m -> Error m
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
Error ("cannot reach the program: " ^ Unix.error_message e)
|
||||
| "ok" ->
|
||||
let rec wait ms =
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ when ms <= 0 -> None
|
||||
| _ ->
|
||||
ignore (Unix.select [] [] [] 0.005);
|
||||
if alive t then wait (ms - 5) else None
|
||||
in
|
||||
(match wait 5000 with
|
||||
| Some v -> Ok v
|
||||
| None ->
|
||||
Error
|
||||
"the program did not reach a frame boundary; is it calling \
|
||||
(agent/poll)?")
|
||||
| reply -> Error ("the program refused the module: " ^ reply))
|
||||
|
||||
(* The frame checks, which every verb that reads a *frame* has to make and
|
||||
must make the same way. [inspect] exists precisely because the listing is
|
||||
frame-accurate and the inspector was not, so it sharing this function with
|
||||
[locals] rather than repeating four conditions is the point: an inspector
|
||||
that sidestepped the fingerprint would read stale slots out of a frame the
|
||||
listing above it is already refusing.
|
||||
|
||||
[what] goes into the wording — "read slot names from" is not the sentence
|
||||
[inspect] wants — and nothing else differs. *)
|
||||
let stopped_frame t ~frame ~what : (string * Tast.fn, string) result =
|
||||
if not (alive t) then Error "the program exited; restart flan dev"
|
||||
else
|
||||
match state t with
|
||||
| Running ->
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"the program is running; %s is read from a stopped frame, and \
|
||||
nothing in a frame that is still executing holds still"
|
||||
what)
|
||||
| Unreachable m -> Error ("cannot ask the program where it is: " ^ m)
|
||||
| Stopped _ ->
|
||||
(match backtrace t with
|
||||
| Error m -> Error ("the program refused to say where it is: " ^ m)
|
||||
| Ok (frames, _) ->
|
||||
(match List.nth_opt frames frame with
|
||||
| None ->
|
||||
Error
|
||||
(Printf.sprintf "there is no frame %d; the backtrace has %d" frame
|
||||
(List.length frames))
|
||||
| Some (name, _, mine, nslots, sig_, _rsig) ->
|
||||
if not mine then
|
||||
Error
|
||||
(name
|
||||
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
|
||||
else
|
||||
match find_fn t name with
|
||||
| None ->
|
||||
Error
|
||||
(name
|
||||
^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from")
|
||||
| Some fn ->
|
||||
(* The two body checks come first, including for a frame
|
||||
with no slots. "every slot in it is one the compiler made
|
||||
up" is a claim about the body this session holds, and a
|
||||
zero-slot frame whose body has since been replaced by one
|
||||
with slots is a frame that claim is false about. *)
|
||||
if nslots <> Array.length fn.Tast.slots then
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
|
||||
name nslots name (Array.length fn.Tast.slots))
|
||||
else if sig_ <> Emit.slot_fingerprint fn then
|
||||
(* The count matching is not the same as the body matching.
|
||||
A redefinition that renames a local, or changes its type
|
||||
to one of the same shape, keeps the count — and then
|
||||
every name here would be the new body's read against the
|
||||
old body's storage, which is the "visible rather than
|
||||
correct" answer this project refuses to give. Said by
|
||||
name, because a frame that is missing and a frame that
|
||||
cannot be trusted are different facts. *)
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
|
||||
name name)
|
||||
else Ok (name, fn)))
|
||||
|
||||
(* [(:op "locals" :frame N)] — what a stopped frame's named locals hold.
|
||||
|
||||
The half of a break loop that the author actually wanted, and the reason
|
||||
@ -758,122 +877,110 @@ let backtrace_op t =
|
||||
30-bit hash — but only between two differing bodies of the function whose
|
||||
qualified name already matched, since [find_fn] gates the comparison. *)
|
||||
let locals t ~frame =
|
||||
if not (alive t) then error "the program exited; restart flan dev"
|
||||
else
|
||||
match state t with
|
||||
| Running ->
|
||||
error
|
||||
"the program is running; locals are read from a stopped frame, and \
|
||||
nothing in a frame that is still executing holds still"
|
||||
| Unreachable m -> error ("cannot ask the program for its locals: " ^ m)
|
||||
| Stopped _ ->
|
||||
(match backtrace t with
|
||||
| Error m -> error ("the program refused to say where it is: " ^ m)
|
||||
| Ok (frames, _) ->
|
||||
(match List.nth_opt frames frame with
|
||||
| None ->
|
||||
error
|
||||
(Printf.sprintf "there is no frame %d; the backtrace has %d" frame
|
||||
(List.length frames))
|
||||
| Some (name, _, mine, nslots, sig_, _rsig) ->
|
||||
if not mine then
|
||||
error
|
||||
(name
|
||||
^ " is a frame of the expression this break is inside, not of the program; its thunk is not part of the session, so there is no record of what its slots are called")
|
||||
else
|
||||
match find_fn t name with
|
||||
| None ->
|
||||
error
|
||||
(name
|
||||
^ " is not a function this session holds; a lifted handler clause has no declaration of its own to read slot names from")
|
||||
| Some fn ->
|
||||
(* The two body checks come first, including for a frame
|
||||
with no slots. "every slot in it is one the compiler made
|
||||
up" is a claim about the body this session holds, and a
|
||||
zero-slot frame whose body has since been replaced by one
|
||||
with slots is a frame that claim is false about. *)
|
||||
if nslots <> Array.length fn.Tast.slots then
|
||||
error
|
||||
(Printf.sprintf
|
||||
"%s on the stack has %d slots and the %s this session holds has %d: the frame is running a body that has been redefined since, so every slot index here would be a guess"
|
||||
name nslots name (Array.length fn.Tast.slots))
|
||||
else if sig_ <> Emit.slot_fingerprint fn then
|
||||
(* The count matching is not the same as the body matching.
|
||||
A redefinition that renames a local, or changes its type
|
||||
to one of the same shape, keeps the count — and then
|
||||
every name here would be the new body's read against the
|
||||
old body's storage, which is the "visible rather than
|
||||
correct" answer this project refuses to give. Said by
|
||||
name, because a frame that is missing and a frame that
|
||||
cannot be trusted are different facts. *)
|
||||
error
|
||||
(Printf.sprintf
|
||||
"%s on the stack was compiled from a different body than the %s this session holds: this frame's body was redefined since it was entered, so its names no longer describe its values"
|
||||
name name)
|
||||
else if nslots = 0 then
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
|
||||
":note "
|
||||
^ Wire.quote
|
||||
"that frame records no slots; every slot in it is one the compiler made up" ]
|
||||
else
|
||||
match bound_slots t ~frame with
|
||||
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
|
||||
| Ok bound ->
|
||||
let c, refused = Session.render_locals t.session ~frame ~fn ~bound in
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "l%d.so" t.n) in
|
||||
(match Build.shared
|
||||
~opts:{ Build.default with Build.dev = true;
|
||||
Build.debug = t.session.Session.debug }
|
||||
~ir:c.Session.ir ~out () with
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
| "ok" ->
|
||||
let rec wait ms =
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ when ms <= 0 -> None
|
||||
| _ ->
|
||||
ignore (Unix.select [] [] [] 0.005);
|
||||
if alive t then wait (ms - 5) else None
|
||||
in
|
||||
(match wait 5000 with
|
||||
| Some v ->
|
||||
(* One line per slot, name and type and value,
|
||||
tab separated — safe because every string the
|
||||
renderer emits is escaped. *)
|
||||
let entries =
|
||||
List.filter_map
|
||||
(fun line ->
|
||||
match String.split_on_char '\t' line with
|
||||
| [ n; ty; value ] ->
|
||||
Some
|
||||
(Wire.list
|
||||
[ Wire.quote n; Wire.quote ty;
|
||||
Wire.quote value ])
|
||||
| _ -> None)
|
||||
(String.split_on_char '\n' v)
|
||||
in
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name;
|
||||
":locals " ^ Wire.list entries;
|
||||
":refused "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (n, why) ->
|
||||
Wire.list
|
||||
[ Wire.quote n; Wire.quote why ])
|
||||
refused) ]
|
||||
| None ->
|
||||
error
|
||||
"the program did not reach a frame boundary; is \
|
||||
it calling (agent/poll)?")
|
||||
| reply -> error ("the program refused the module: " ^ reply)
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
error ("cannot reach the program: " ^ Unix.error_message e))
|
||||
| exception Failure m -> error m)))
|
||||
match stopped_frame t ~frame ~what:"locals" with
|
||||
| Error m -> error m
|
||||
| Ok (name, fn) ->
|
||||
if Array.length fn.Tast.slots = 0 then
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
|
||||
":note "
|
||||
^ Wire.quote
|
||||
"that frame records no slots; every slot in it is one the compiler made up" ]
|
||||
else
|
||||
(match bound_slots t ~frame with
|
||||
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
|
||||
| Ok bound ->
|
||||
let c, refused = Session.render_locals t.session ~frame ~fn ~bound in
|
||||
(match run_render_thunk t ~tag:"l" ~c with
|
||||
| Error m -> error m
|
||||
| Ok v ->
|
||||
(* One line per slot — name, type, value, slot index — tab
|
||||
separated, and safe because every string the renderer emits is
|
||||
escaped. The index is last and it is what [i] in the break
|
||||
buffer hands back to [inspect]: two slots can share a name, so
|
||||
the name is not an identifier and the position in this list is
|
||||
not one either, since a refused slot is not in it. *)
|
||||
let entries =
|
||||
List.filter_map
|
||||
(fun line ->
|
||||
match String.split_on_char '\t' line with
|
||||
| [ n; ty; value; slot ] ->
|
||||
Some
|
||||
(Wire.list
|
||||
[ Wire.quote n; Wire.quote ty; Wire.quote value; slot ])
|
||||
| _ -> None)
|
||||
(String.split_on_char '\n' v)
|
||||
in
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name;
|
||||
":locals " ^ Wire.list entries;
|
||||
":refused "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
|
||||
refused) ]))
|
||||
|
||||
(* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second
|
||||
rooting mode. [BUILT.md]'s "Two ways to root a walk" says what each root
|
||||
can and cannot do; this is the half that names a frame.
|
||||
|
||||
[i] in the break buffer used to send a local's *name* to be evaluated as an
|
||||
expression. On the innermost frame that happens to be right; on any other
|
||||
it is evaluated wherever the evaluator stands, so it may resolve to a
|
||||
global, to a different binding of the same name, or to nothing — with the
|
||||
listing right above it showing the frame's own storage and nothing saying
|
||||
the two disagree.
|
||||
|
||||
This roots the walk where the listing roots it: a frame and a slot index,
|
||||
which is the address the shadow stack knows, plus the type [Tast.fn.slots]
|
||||
knows. A step into a field is then an address plus an offset with that
|
||||
field's type, which is arithmetic [Render.render] already does — see
|
||||
[Session.render_slot], which is [render_locals] with a path applied to the
|
||||
root and one line out instead of one per slot.
|
||||
|
||||
The frame checks are [locals]'s, by construction: both go through
|
||||
[stopped_frame]. An inspector that made its own would be free to read a
|
||||
frame whose body was redefined since it was entered, which is exactly the
|
||||
stale-slot answer the listing refuses.
|
||||
|
||||
The slot is named by *index* and not by name, because a name is not unique:
|
||||
[check.ml]'s [fresh_slot] only ever allocates, so (let [v 22] …) inside
|
||||
(let [v 11] …) is two slots both called [v], and both are in the listing.
|
||||
The index travels out with each line of [locals] for exactly this.
|
||||
|
||||
[:path] is a list the reader parses: a string is a field, an integer is an
|
||||
element, and the symbol [some] is an option's payload. Empty means the slot
|
||||
itself. *)
|
||||
let inspect t ~frame ~slot ~path =
|
||||
match stopped_frame t ~frame ~what:"a local" with
|
||||
| Error m -> error m
|
||||
| Ok (name, fn) ->
|
||||
(match bound_slots t ~frame with
|
||||
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
|
||||
| Ok bound ->
|
||||
if not (List.mem slot bound) then
|
||||
(* The same refusal the listing gives, and for the same reason: an
|
||||
unbound slot's entry is null, and a thunk that rendered it would
|
||||
fault on the game thread of a program that is already stopped. *)
|
||||
error
|
||||
(Printf.sprintf
|
||||
"slot %d of %s was not bound yet at the point the program \
|
||||
stopped; there is nothing at that address to read"
|
||||
slot name)
|
||||
else
|
||||
match Session.render_slot t.session ~frame ~fn ~slot ~path with
|
||||
| Error why -> error why
|
||||
| Ok (c, label, ty) ->
|
||||
(match run_render_thunk t ~tag:"i" ~c with
|
||||
| Error m -> error m
|
||||
| Ok v ->
|
||||
(* One value and nothing else, so the whole of what came back is
|
||||
it — minus the trailing newline the renderer does not write
|
||||
here, because there is no second line to separate it from. *)
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
|
||||
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v ]))
|
||||
|
||||
|
||||
(* [(:op "globals")] — the globals the stopped stack reaches, in one section.
|
||||
|
||||
@ -1063,66 +1170,39 @@ let globals_op t =
|
||||
nothing here that is not already in the locals" ]
|
||||
else begin
|
||||
let c, refused = Session.render_globals t.session ~globals:ordered in
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
t.n <- t.n + 1;
|
||||
let out = Filename.concat t.dir (Printf.sprintf "g%d.so" t.n) in
|
||||
match Build.shared
|
||||
~opts:{ Build.default with Build.dev = true;
|
||||
Build.debug = t.session.Session.debug }
|
||||
~ir:c.Session.ir ~out () with
|
||||
| _ ->
|
||||
(match deliver t out with
|
||||
| "ok" ->
|
||||
let rec wait ms =
|
||||
match result t with
|
||||
| Some (g, v) when Int64.compare g before > 0 -> Some v
|
||||
| _ when ms <= 0 -> None
|
||||
| _ ->
|
||||
ignore (Unix.select [] [] [] 0.005);
|
||||
if alive t then wait (ms - 5) else None
|
||||
in
|
||||
(match wait 5000 with
|
||||
| Some v ->
|
||||
(* One line per global, name and type and value, tab
|
||||
separated — safe because every string the renderer emits
|
||||
is escaped. The frames are added back here, from the
|
||||
table above, because the thunk knows nothing about the
|
||||
stack it was chosen for. *)
|
||||
let by_name = Hashtbl.create 32 in
|
||||
List.iter
|
||||
(fun (g : Tast.global) ->
|
||||
Hashtbl.replace by_name g.Tast.gname (where g))
|
||||
ordered;
|
||||
let entries =
|
||||
List.filter_map
|
||||
(fun line ->
|
||||
match String.split_on_char '\t' line with
|
||||
| [ n; ty; value ] ->
|
||||
Some
|
||||
(Wire.list
|
||||
[ Wire.quote n; Wire.quote ty; Wire.quote value;
|
||||
(try Hashtbl.find by_name n
|
||||
with Not_found -> Wire.list []) ])
|
||||
| _ -> None)
|
||||
(String.split_on_char '\n' v)
|
||||
in
|
||||
ok
|
||||
[ ":globals " ^ Wire.list entries;
|
||||
":refused "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (n, why) ->
|
||||
Wire.list [ Wire.quote n; Wire.quote why ])
|
||||
refused);
|
||||
skipped_field ]
|
||||
| None ->
|
||||
error
|
||||
"the program did not reach a frame boundary; is it calling \
|
||||
(agent/poll)?")
|
||||
| reply -> error ("the program refused the module: " ^ reply)
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
error ("cannot reach the program: " ^ Unix.error_message e))
|
||||
| exception Failure m -> error m
|
||||
match run_render_thunk t ~tag:"g" ~c with
|
||||
| Error m -> error m
|
||||
| Ok v ->
|
||||
(* One line per global, name and type and value, tab separated —
|
||||
safe because every string the renderer emits is escaped. The
|
||||
frames are added back here, from the table above, because the
|
||||
thunk knows nothing about the stack it was chosen for. *)
|
||||
let by_name = Hashtbl.create 32 in
|
||||
List.iter
|
||||
(fun (g : Tast.global) ->
|
||||
Hashtbl.replace by_name g.Tast.gname (where g))
|
||||
ordered;
|
||||
let entries =
|
||||
List.filter_map
|
||||
(fun line ->
|
||||
match String.split_on_char '\t' line with
|
||||
| [ n; ty; value ] ->
|
||||
Some
|
||||
(Wire.list
|
||||
[ Wire.quote n; Wire.quote ty; Wire.quote value;
|
||||
(try Hashtbl.find by_name n
|
||||
with Not_found -> Wire.list []) ])
|
||||
| _ -> None)
|
||||
(String.split_on_char '\n' v)
|
||||
in
|
||||
ok
|
||||
[ ":globals " ^ Wire.list entries;
|
||||
":refused "
|
||||
^ Wire.list
|
||||
(List.map
|
||||
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
|
||||
refused);
|
||||
skipped_field ]
|
||||
end)
|
||||
|
||||
(* A choice is validated by the *program*, on its listener thread, against a
|
||||
@ -1516,6 +1596,47 @@ let handle t req =
|
||||
| Some "backtrace" -> backtrace_op t
|
||||
| Some "locals" ->
|
||||
locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0)
|
||||
(* The path is read by the language's own reader, so it arrives as a form
|
||||
and is matched here rather than parsed out of a string: a string element
|
||||
is a field, an integer is an element, and the symbol [some] is an
|
||||
option's payload. Anything else is refused by name rather than skipped —
|
||||
a path with a step silently dropped out of it would render a *different*
|
||||
value and say nothing. *)
|
||||
| Some "inspect" ->
|
||||
(match Wire.int_field req "slot" with
|
||||
| None -> error "inspect needs :slot, the index the locals listing gave"
|
||||
| Some slot ->
|
||||
let frame =
|
||||
match Wire.int_field req "frame" with Some n -> n | None -> 0
|
||||
in
|
||||
let steps =
|
||||
match Wire.field req "path" with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.fold_left
|
||||
(fun acc (e : Form.t) ->
|
||||
match acc with
|
||||
| Error _ -> acc
|
||||
| Ok got ->
|
||||
(match e.Form.v with
|
||||
| Form.Str f -> Ok (Session.Sfield f :: got)
|
||||
| Form.Int i -> Ok (Session.Sindex (Int64.to_int i) :: got)
|
||||
| Form.Sym "some" -> Ok (Session.Ssome :: got)
|
||||
| _ ->
|
||||
Error
|
||||
"a :path step is a string for a field, an integer for an element, or `some' for an option's payload"))
|
||||
(Ok []) l
|
||||
|> Result.map List.rev
|
||||
(* Emacs prints an empty list as [nil], because it has no other
|
||||
spelling for one. Taking it is cheaper than making every client
|
||||
in that language special-case the empty path, and [nil] is not a
|
||||
step under any other reading. *)
|
||||
| Some { Form.v = Form.Sym "nil"; _ } -> Ok []
|
||||
| Some _ -> Error "inspect's :path is a list"
|
||||
| None -> Ok []
|
||||
in
|
||||
(match steps with
|
||||
| Error m -> error m
|
||||
| Ok path -> inspect t ~frame ~slot ~path))
|
||||
(* 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
|
||||
|
||||
270
lib/session.ml
270
lib/session.ml
@ -496,8 +496,15 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
|
||||
let v = { Tast.e = Tast.Deref typed; ty; loc } in
|
||||
match Render.render c 0 v with
|
||||
| parts ->
|
||||
(* The slot *index* travels with the line, last, and it is what makes
|
||||
[i] in the break buffer able to name this exact slot back to the
|
||||
daemon. The name cannot: [check.ml]'s [fresh_slot] only ever
|
||||
allocates, so (let [v 22] …) inside (let [v 11] …) is two slots both
|
||||
called [v] and both listed here. Nor can the position in the list,
|
||||
because a refused slot is not in it. See [render_slot]. *)
|
||||
Some
|
||||
((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts) @ [ lit "\n" ])
|
||||
((lit (name ^ "\t" ^ Types.to_string ty ^ "\t") :: parts)
|
||||
@ [ lit ("\t" ^ string_of_int i ^ "\n") ])
|
||||
| exception Loc.Error (_, why) ->
|
||||
(* A type the structural printer has no arm for — a map, a function
|
||||
value, a type variable. Named, with the reason, rather than left out
|
||||
@ -554,6 +561,267 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
|
||||
ignore origin;
|
||||
({ ir; names = []; fns = []; installs = true }, List.rev !refused)
|
||||
|
||||
(* ── One slot of a stopped frame, walked ───────────────────────────── *)
|
||||
|
||||
(* The inspector's second rooting mode, and the whole of what it needed.
|
||||
|
||||
The inspector navigates by rewriting *expressions* — `(.pos b)' where the
|
||||
last one was `b' — because a Flan value has no header and the thunk that
|
||||
rendered it is [dlclose]d as soon as it returns, so nothing can be held on
|
||||
this side the way CIDER holds a JVM object. The cost of that is the bug it
|
||||
had: a name sent back to be evaluated is evaluated wherever the evaluator
|
||||
stands, which on any frame but the innermost may resolve to a global, to a
|
||||
different binding, or to nothing, with the listing above it still showing
|
||||
the frame's own storage.
|
||||
|
||||
Rooting at the slot's address alone does not fix it — an address is not an
|
||||
expression, so the first step has nothing to build from. What makes this
|
||||
work is that the step does not have to be an expression either. A frame's
|
||||
address comes from the shadow stack and every slot's type comes from
|
||||
[Tast.fn.slots], so a step into a field is an address plus an offset with
|
||||
that field's type, which is *exactly* the arithmetic [Render.render] does
|
||||
for the locals listing. So this is [render_locals] with a path applied to
|
||||
the root before the walk, and not a second walk.
|
||||
|
||||
What the path cannot do is the honest half. Every step is refused by name
|
||||
with its reason rather than guessed at: a field the type does not have, an
|
||||
index past the end of a fixed array, an option's payload on something that
|
||||
is not an option. A pointer is still never followed — that is the
|
||||
renderer's rule and not this mode's. *)
|
||||
|
||||
(* A step, as the editor sends it. [Sfield] on a union carries the case as
|
||||
well, because a union's payload is at an offset that depends on which case
|
||||
it is, and the renderer is what told the editor which case this value
|
||||
currently holds. Guessing the case from a field name that two cases share
|
||||
would read one case's layout over another's payload. *)
|
||||
type step = Sfield of string | Sindex of int | Ssome
|
||||
|
||||
let step_text = function
|
||||
| Sfield f -> "." ^ f
|
||||
| Sindex i -> Printf.sprintf "[%d]" i
|
||||
| Ssome -> ".some"
|
||||
|
||||
let path_text path = String.concat "" (List.map step_text path)
|
||||
|
||||
let step_into t (v : Tast.expr) (s : step) : (Tast.expr, string) result =
|
||||
let loc = v.Tast.loc in
|
||||
let ty = v.Tast.ty in
|
||||
let no why = Error why in
|
||||
match s with
|
||||
| Ssome ->
|
||||
(match ty with
|
||||
| Types.Option pay -> Ok { Tast.e = Tast.Field (v, 1); ty = pay; loc }
|
||||
| _ ->
|
||||
no
|
||||
(Printf.sprintf "%s is not an option, so it has no payload to go into"
|
||||
(Types.to_string ty)))
|
||||
| Sindex i ->
|
||||
(match ty with
|
||||
| Types.Array (n, el) ->
|
||||
if i < 0 || Int64.compare (Int64.of_int i) n >= 0 then
|
||||
no
|
||||
(Printf.sprintf "%d is past the end of %s, which has %Ld elements" i
|
||||
(Types.to_string ty) n)
|
||||
else
|
||||
Ok
|
||||
{ Tast.e =
|
||||
Tast.Prim
|
||||
(Tast.At,
|
||||
[ v;
|
||||
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
|
||||
ty = Types.Int Types.I32; loc } ]);
|
||||
ty = el; loc }
|
||||
| Types.Slice el ->
|
||||
(* A slice's length is not in its type, so this is the one step whose
|
||||
range cannot be settled here. It is checked in the program, like
|
||||
every other index in a dev build. *)
|
||||
if i < 0 then no (Printf.sprintf "%d is not an index" i)
|
||||
else
|
||||
Ok
|
||||
{ Tast.e =
|
||||
Tast.Prim
|
||||
(Tast.At,
|
||||
[ v;
|
||||
{ Tast.e = Tast.Int (Int64.of_int i, Types.I32);
|
||||
ty = Types.Int Types.I32; loc } ]);
|
||||
ty = el; loc }
|
||||
| _ ->
|
||||
no
|
||||
(Printf.sprintf "%s is not an array or a slice, so it has no element %d"
|
||||
(Types.to_string ty) i))
|
||||
| Sfield spec ->
|
||||
(match ty with
|
||||
| Types.Named n
|
||||
when List.exists (fun (u : Tast.union) -> String.equal u.Tast.uname n)
|
||||
t.program.Tast.unions ->
|
||||
let u =
|
||||
List.find (fun (u : Tast.union) -> String.equal u.Tast.uname n)
|
||||
t.program.Tast.unions
|
||||
in
|
||||
(* The editor spells this `Union.case.field', which is the head the
|
||||
renderer wrote — `(Union.case {.field …})' — with the field appended.
|
||||
A bare `case.field' is taken too, since that is the same fact said
|
||||
shorter. *)
|
||||
(match String.rindex_opt spec '.' with
|
||||
| None ->
|
||||
no
|
||||
(Printf.sprintf
|
||||
"%s is a union: a field of it has to name the case that holds \
|
||||
it, because the payload's offset depends on which case the \
|
||||
value is in"
|
||||
n)
|
||||
| Some k ->
|
||||
let case = String.sub spec 0 k
|
||||
and fname = String.sub spec (k + 1) (String.length spec - k - 1) in
|
||||
let case =
|
||||
let pre = n ^ "." in
|
||||
let lp = String.length pre in
|
||||
if String.length case > lp && String.equal (String.sub case 0 lp) pre
|
||||
then String.sub case lp (String.length case - lp)
|
||||
else case
|
||||
in
|
||||
(match
|
||||
List.find_opt
|
||||
(fun (vr : Tast.variant) -> String.equal vr.Tast.vname case)
|
||||
u.Tast.cases
|
||||
with
|
||||
| None ->
|
||||
no (Printf.sprintf "%s has no case called %s" n case)
|
||||
| Some vr ->
|
||||
let rec idx i = function
|
||||
| [] -> None
|
||||
| (f : Tast.field) :: rest ->
|
||||
if String.equal f.Tast.fname fname then Some (i, f.Tast.fty)
|
||||
else idx (i + 1) rest
|
||||
in
|
||||
(match idx 0 vr.Tast.vfields with
|
||||
| None ->
|
||||
no
|
||||
(Printf.sprintf "%s.%s has no field called %s" n case fname)
|
||||
| Some (i, fty) ->
|
||||
Ok
|
||||
{ Tast.e = Tast.CaseField (v, vr.Tast.vname, i); ty = fty; loc })))
|
||||
| Types.Named n ->
|
||||
(match
|
||||
List.find_opt
|
||||
(fun (s : Tast.structure) -> String.equal s.Tast.sname n)
|
||||
t.program.Tast.structs
|
||||
with
|
||||
| None ->
|
||||
no
|
||||
(Printf.sprintf
|
||||
"%s is a type this session has no layout for, so there is no \
|
||||
field to step to"
|
||||
n)
|
||||
| Some st ->
|
||||
let rec idx i = function
|
||||
| [] -> None
|
||||
| (f : Tast.field) :: rest ->
|
||||
if String.equal f.Tast.fname spec then Some (i, f.Tast.fty)
|
||||
else idx (i + 1) rest
|
||||
in
|
||||
(match idx 0 st.Tast.fields with
|
||||
| None ->
|
||||
no (Printf.sprintf "%s has no field called %s" n spec)
|
||||
| Some (i, fty) -> Ok { Tast.e = Tast.Field (v, i); ty = fty; loc }))
|
||||
| _ ->
|
||||
no
|
||||
(Printf.sprintf "%s has no fields, so there is no .%s in it"
|
||||
(Types.to_string ty) spec))
|
||||
|
||||
(* Renders slot [slot] of frame [frame], after walking [path] into it. The
|
||||
thunk is [render_locals]'s, minus the loop over every slot: one root, one
|
||||
line, and the reply carries the type the path ended at so the editor can
|
||||
say what it is looking at.
|
||||
|
||||
The caller has already established that the frame is the body this session
|
||||
holds — the slot fingerprint — and that the slot is bound. This function
|
||||
does not re-derive either; it is handed the [fn] that check passed. *)
|
||||
let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
||||
: (change * string * string, string) result =
|
||||
let loc = fn.Tast.floc in
|
||||
let nslots_of_fn = Array.length fn.Tast.slots in
|
||||
if slot < 0 || slot >= nslots_of_fn then
|
||||
Error
|
||||
(Printf.sprintf "there is no slot %d in %s; it has %d" slot fn.Tast.name
|
||||
nslots_of_fn)
|
||||
else
|
||||
let sname =
|
||||
if slot < Array.length fn.Tast.snames then fn.Tast.snames.(slot) else None
|
||||
in
|
||||
match sname with
|
||||
| None ->
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"slot %d of %s is one the compiler made up; no name was written for \
|
||||
it, and it is not something the listing offers"
|
||||
slot fn.Tast.name)
|
||||
| Some name ->
|
||||
let extra = ref [] and nslots = ref 0 in
|
||||
let c =
|
||||
{ Render.structs = t.program.Tast.structs;
|
||||
unions = t.program.Tast.unions;
|
||||
enums = Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
||||
emit = dev_emitter;
|
||||
alloc = (fun ty ->
|
||||
let i = !nslots in
|
||||
incr nslots;
|
||||
extra := ty :: !extra;
|
||||
i) }
|
||||
in
|
||||
let idx n =
|
||||
{ Tast.e = Tast.Int (Int64.of_int n, Types.I64); ty = Types.Int Types.I64;
|
||||
loc }
|
||||
in
|
||||
let ty = fn.Tast.slots.(slot) in
|
||||
let address =
|
||||
{ Tast.e = Tast.Call ("flan/dev-slot", [ idx frame; idx slot ]);
|
||||
ty = Types.Ptr (Types.Int Types.U8); loc }
|
||||
in
|
||||
let typed =
|
||||
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr ty), [ address ]);
|
||||
ty = Types.Ptr ty; loc }
|
||||
in
|
||||
let root = { Tast.e = Tast.Deref typed; ty; loc } in
|
||||
let rec walk v = function
|
||||
| [] -> Ok v
|
||||
| s :: rest ->
|
||||
(match step_into t v s with
|
||||
| Error why -> Error why
|
||||
| Ok v' -> walk v' rest)
|
||||
in
|
||||
(match walk root path with
|
||||
| Error why -> Error (name ^ path_text path ^ ": " ^ why)
|
||||
| Ok v ->
|
||||
(match Render.render c 0 v with
|
||||
| exception Loc.Error (_, why) -> Error (name ^ path_text path ^ ": " ^ why)
|
||||
| parts ->
|
||||
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
|
||||
t.thunks <- t.thunks + 1;
|
||||
let tname = Printf.sprintf "inspect/%d" t.thunks in
|
||||
let thunk : Tast.fn =
|
||||
{ Tast.name = tname; params = []; ret = Types.Unit;
|
||||
body =
|
||||
(nullary "flan/dev-begin" :: parts) @ [ nullary "flan/dev-end" ];
|
||||
fdefers = []; fparent = None; floc = loc;
|
||||
slots = Array.of_list (List.rev !extra);
|
||||
snames = Array.make (List.length !extra) None }
|
||||
in
|
||||
let program =
|
||||
{ t.program with
|
||||
Tast.fns = t.program.Tast.fns @ [ thunk ];
|
||||
externs = t.program.Tast.externs @ externs }
|
||||
in
|
||||
let ir =
|
||||
Emit.redefinition ~dev:true ~debug:t.debug ~known:(known t)
|
||||
~call:tname program ~fns:[ tname ]
|
||||
in
|
||||
ignore origin;
|
||||
Ok
|
||||
({ ir; names = []; fns = []; installs = true },
|
||||
name ^ path_text path,
|
||||
Types.to_string v.Tast.ty)))
|
||||
|
||||
(* ── The globals a stopped stack reaches ───────────────────────────── *)
|
||||
|
||||
(* The other half of what a break loop can show, and in this language arguably
|
||||
|
||||
53
test/programs/dev-inspect.flan
Normal file
53
test/programs/dev-inspect.flan
Normal file
@ -0,0 +1,53 @@
|
||||
;;;; A stopped stack whose OUTER frame holds a local the evaluator cannot see.
|
||||
;;;;
|
||||
;;;; dev-locals.flan is about what one frame holds; this one is about which
|
||||
;;;; frame the answer came from. The whole of the bug the `inspect' verb
|
||||
;;;; exists for is that an expression is evaluated where the evaluator stands,
|
||||
;;;; so a local's *name* reaches the right storage only when the frame is the
|
||||
;;;; innermost one. `mark' below is a global AND a local of the outer frame,
|
||||
;;;; holding different things of different types: evaluating the name answers
|
||||
;;;; the global, and rooting at the frame and slot answers the frame.
|
||||
;;;;
|
||||
;;;; The other locals are the shapes a path step has to walk and that an
|
||||
;;;; expression cannot reach at all: an option's payload, which has no
|
||||
;;;; accessor form in the language, and a union case's field, whose offset
|
||||
;;;; depends on which case the value is in.
|
||||
(import agent "vendor:agent")
|
||||
|
||||
(defstruct Point [x f32 y f32])
|
||||
(defstruct Boom [why i32])
|
||||
|
||||
(defunion Shape
|
||||
[Empty
|
||||
(Dot [x f64 y f64])
|
||||
(Rect [w i32 h i32])])
|
||||
|
||||
;; The discriminator. `outer' binds a local of this name to something else, so
|
||||
;; every claim about which frame answered is visible in the value itself.
|
||||
(defvar mark i64)
|
||||
|
||||
;; The innermost frame, and it is deliberately dull: it holds nothing worth
|
||||
;; inspecting, so that the frame worth inspecting is not the one an expression
|
||||
;; would have found by luck.
|
||||
(defn deeper [] i64
|
||||
(restart-case
|
||||
(do (error (Boom {.why 7})) 1)
|
||||
(carry-on [] 5)))
|
||||
|
||||
(defn outer [] i64
|
||||
(let [mark (Point {.x 1.5 .y 2.5})
|
||||
xs [10 20 30]
|
||||
box (Some (Point {.x 4.5 .y 5.5}))
|
||||
s (Shape.Rect {.w 3 .h 6})]
|
||||
(deeper)))
|
||||
|
||||
(defvar ticks i64)
|
||||
|
||||
(defn main [] i32
|
||||
(set mark 99)
|
||||
(agent/start "/tmp/flan-dev-inspect-fallback.sock")
|
||||
(print (outer)) (println "")
|
||||
(dotimes [i 4000]
|
||||
(agent/wait 5)
|
||||
(set ticks (+ ticks 1)))
|
||||
0)
|
||||
209
test/test_dev.ml
209
test/test_dev.ml
@ -884,6 +884,215 @@ let () =
|
||||
end
|
||||
end;
|
||||
|
||||
(* ── Which frame the inspector answered from ───────────────────── *)
|
||||
|
||||
(* The locals listing was already frame-accurate; the inspector was not.
|
||||
`i' in the break buffer sent the local's *name* to be evaluated, and an
|
||||
expression is evaluated where the evaluator stands — the right frame
|
||||
only when the frame is the innermost one.
|
||||
|
||||
dev-inspect.flan is built so that failing to root at the frame is
|
||||
visible in the value rather than only in the reasoning: `mark' is a
|
||||
global holding 99 and a local of the *outer* frame holding a Point, and
|
||||
the two are not even the same type. So the discriminating pair below is
|
||||
one evaluation and one inspection of the same name.
|
||||
|
||||
It also carries the two shapes an expression cannot reach at all: an
|
||||
option's payload, which no accessor form in the language names, and a
|
||||
union case's field, whose offset depends on which case the value is
|
||||
in. *)
|
||||
let isock = tmp "inspect.sock" and iout = tmp "inspect.out" in
|
||||
(try Sys.remove isock with Sys_error _ -> ());
|
||||
let ifd = Unix.openfile iout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let ipid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-inspect.flan"; "-s"; isock |]
|
||||
Unix.stdin ifd Unix.stderr
|
||||
in
|
||||
Unix.close ifd;
|
||||
if not (await (fun () -> Sys.file_exists isock)) then begin
|
||||
fail "the inspect daemon never listened";
|
||||
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect isock 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 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 inspect program never stopped"
|
||||
else begin
|
||||
(* The slot travels by index and the index comes off the listing,
|
||||
which is the fourth element of each entry. Reading it here rather
|
||||
than writing 0 exercises the field the editor depends on, and keeps
|
||||
this test from passing for the wrong reason if slot allocation ever
|
||||
shifts. *)
|
||||
let slot_of r name =
|
||||
match Wire.field r "locals" with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.fold_left
|
||||
(fun acc (e : Form.t) ->
|
||||
match acc with
|
||||
| Some _ -> acc
|
||||
| None ->
|
||||
(match e.Form.v with
|
||||
| Form.List
|
||||
[ { Form.v = Form.Str n; _ }; _; _;
|
||||
{ Form.v = Form.Int i; _ } ]
|
||||
when String.equal n name ->
|
||||
Some (Int64.to_int i)
|
||||
| _ -> None))
|
||||
None l
|
||||
| _ -> None
|
||||
in
|
||||
let listing = ask "(:op \"locals\" :frame 1)" in
|
||||
if status listing <> "ok" then
|
||||
fail "locals of the outer frame: %s"
|
||||
(Option.value ~default:(status listing) (Wire.string_field listing "message"))
|
||||
else begin
|
||||
let inspect ?(path = "()") slot =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)" slot
|
||||
path)
|
||||
in
|
||||
let value r = Option.value ~default:"" (Wire.string_field r "value") in
|
||||
let want name path ty v =
|
||||
match slot_of listing name with
|
||||
| None ->
|
||||
fail "the locals listing gave no slot index for %s, so the \
|
||||
inspector has nothing to root at" name
|
||||
| Some slot ->
|
||||
let r = inspect ~path slot in
|
||||
if status r <> "ok" then
|
||||
fail "inspect %s%s: %s" name path
|
||||
(Option.value ~default:(status r) (Wire.string_field r "message"))
|
||||
else begin
|
||||
if value r <> v then
|
||||
fail "inspect %s%s rendered %s, not %s" name path (value r) v;
|
||||
if Option.value ~default:"" (Wire.string_field r "type") <> ty then
|
||||
fail "inspect %s%s says its type is %s, not %s" name path
|
||||
(Option.value ~default:"" (Wire.string_field r "type")) ty
|
||||
end
|
||||
in
|
||||
(* The pair the whole verb exists for. `mark' evaluated as an
|
||||
expression is the global, because that is where the evaluator
|
||||
stands; `mark' rooted at frame 1's slot is the frame's own
|
||||
storage. Both answers are correct answers to different
|
||||
questions, and the break buffer was asking the wrong one. *)
|
||||
let r = ask "(:op \"eval-expr\" :code \"mark\" :file \"<t>\")" in
|
||||
if status r <> "ok" || value r <> "99" then
|
||||
fail "the global `mark' did not evaluate to 99: %s" (value r);
|
||||
want "mark" "()" "Point" "(Point {.x 1.5 .y 2.5})";
|
||||
(* A path step, which is an address plus an offset with that field's
|
||||
type — the arithmetic the listing already does. *)
|
||||
want "mark" "(\"x\")" "f32" "1.5";
|
||||
want "xs" "(1)" "i32" "20";
|
||||
(* And the two an expression cannot write at all. *)
|
||||
want "box" "(some)" "Point" "(Point {.x 4.5 .y 5.5})";
|
||||
want "box" "(some \"x\")" "f32" "4.5";
|
||||
want "s" "(\"Shape.Rect.w\")" "i32" "3";
|
||||
(* Emacs prints an empty list as `nil' and has no other spelling for
|
||||
one, so a client in that language cannot send `()'. *)
|
||||
(match slot_of listing "mark" with
|
||||
| None -> ()
|
||||
| Some slot ->
|
||||
let r = inspect ~path:"nil" slot in
|
||||
if status r <> "ok" || value r <> "(Point {.x 1.5 .y 2.5})" then
|
||||
fail "a :path of nil was not read as the slot itself: %s"
|
||||
(Option.value ~default:(status r) (Wire.string_field r "message")));
|
||||
(* Every step that does not fit the type in hand is refused by name
|
||||
with its reason. A path with a step quietly dropped out of it
|
||||
would render a *different* value and say nothing, which is the
|
||||
failure this whole buffer is built to avoid. *)
|
||||
List.iter
|
||||
(fun (name, path, needle) ->
|
||||
match slot_of listing name with
|
||||
| None -> ()
|
||||
| Some slot ->
|
||||
let r = inspect ~path slot in
|
||||
let m = Option.value ~default:"" (Wire.string_field r "message") in
|
||||
if status r <> "error" then
|
||||
fail "inspect %s%s answered instead of refusing: %s" name path
|
||||
(value r)
|
||||
else if
|
||||
(* The refusal names the step and says why. *)
|
||||
not
|
||||
(contains m needle
|
||||
&& contains m name)
|
||||
then fail "inspect %s%s refused without saying why: %s" name path m)
|
||||
[ ("mark", "(\"nope\")", "no field called nope");
|
||||
("mark", "(some)", "not an option");
|
||||
("xs", "(9)", "past the end");
|
||||
(* A union field without its case: the payload's offset depends
|
||||
on the case, so guessing one that two cases share would read
|
||||
one case's layout over another's payload. *)
|
||||
("s", "(\"w\")", "name the case") ]
|
||||
end;
|
||||
(* The innermost frame records no slots at all, and that is refused
|
||||
with the reason rather than answered with something. *)
|
||||
let r = ask "(:op \"inspect\" :frame 0 :slot 0 :path ())" in
|
||||
if status r <> "error" then
|
||||
fail "a frame with no slots answered the inspector anyway";
|
||||
(* And the frame checks are the listing's, by construction: both go
|
||||
through `stopped_frame'. An inspector with its own copy would be
|
||||
free to read a frame whose body was redefined since it was entered,
|
||||
which is exactly the stale-slot answer the listing refuses. This
|
||||
body renames every local and keeps the count and the types, which
|
||||
only the slot fingerprint can see. *)
|
||||
let r =
|
||||
ask
|
||||
"(:op \"eval\" :code \"(defn outer [] i64 (let [tag (Point {.x 9.0 .y 9.0}) ys [1 2 3] maybe (Some (Point {.x 0.0 .y 0.0})) sh (Shape.Rect {.w 1 .h 1})] (deeper)))\" :file \"/tmp/buf.flan\")"
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "installing a renamed body while stopped: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"))
|
||||
else begin
|
||||
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
||||
if status r <> "error" then
|
||||
fail
|
||||
"the inspector read a frame whose body was redefined under it: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "value"))
|
||||
end
|
||||
end;
|
||||
(* And a running program has no frame to root at. The inspector says so
|
||||
rather than falling back to evaluating the name somewhere else, which
|
||||
is the behaviour it replaced. *)
|
||||
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
||||
if status r <> "ok" then
|
||||
fail "resuming the inspect program: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
||||
fail "the inspect program never resumed"
|
||||
else begin
|
||||
let r = ask "(:op \"inspect\" :frame 1 :slot 0 :path ())" in
|
||||
if status r <> "error" then
|
||||
fail "a running program answered the inspector"
|
||||
end;
|
||||
ignore (ask "(:op \"close\")");
|
||||
Unix.close c;
|
||||
if not
|
||||
(await ~ms:5000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] ipid with
|
||||
| 0, _ -> false
|
||||
| _ -> true
|
||||
| exception Unix.Unix_error _ -> true))
|
||||
then begin
|
||||
(try Unix.kill ipid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] ipid) 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;
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user