Merge: the inspector writes, against the stop it rendered under
This commit is contained in:
commit
5bd533c64e
@ -4501,6 +4501,97 @@ expression root with an effect in it would fire once a second for ever.
|
||||
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.
|
||||
|
||||
## Writing one of them back, and the difference between a stop and being stopped
|
||||
|
||||
SLY sets a value from its inspector; this does that and then the thing the author actually wanted, which is the buffer
|
||||
*being* the value. Both are `(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)` — one edit for `e` on a
|
||||
line, one per changed leaf for a committed buffer — and both are refused whole if any single edit is impossible.
|
||||
|
||||
**The addressing is `inspect`'s, to the letter**, and that is not economy. Same `stopped_frame`, same slot index, same
|
||||
`Session.step_into`, read by the same wire parser. A write that addressed values its own way would be free to land
|
||||
somewhere the render above it never showed, which is exactly the stale-slot answer both verbs exist to refuse. What is
|
||||
new is that the walk has to end at a **place** rather than a value, and that the value being stored is an expression
|
||||
somebody typed, checked against the type the walk ended at.
|
||||
|
||||
### `stopped_only` is not enough for a write, and the gap is not small
|
||||
|
||||
The gate at `flan_agent_poll` asked `j.stopped_only && depth <= 0` — "is the program stopped". For a *read* that is the
|
||||
whole question: the worst a render can do against the wrong stop is print something that was true of a different frame,
|
||||
into a buffer nobody stores anywhere.
|
||||
|
||||
A write is not that. A module that stores through `flan/dev-slot` reaches its target through whatever snapshot is on
|
||||
top when the store runs. Resume and stop again inside the build window — ~300ms of `llc`, and a game that breaks every
|
||||
frame closes it without trying — and `depth > 0` is true again, the job is accepted, and the store lands in the same
|
||||
slot index of a different stack. Not a fault: a plausible shape, in the wrong place, silently. Nothing already here
|
||||
catches it. The slot fingerprint does not: the same function re-entered has the same fingerprint. The refusal counter
|
||||
does not: it counts jobs that were *dropped*, and this one is not.
|
||||
|
||||
So a write names the **stop** and not the state. `snap_push` has minted a monotone, never-reused generation since the
|
||||
restart machinery needed one for the same reason, and it travels on the request as `at-stop N ` beside `stopped-only `
|
||||
— in front of the path rather than inside the module, for `stopped_only`'s own reason: what is stopped-only, or
|
||||
addressed to one stop, is the *question* and not the code. A new `stop` verb answers the current one (0 while
|
||||
running), `inspect` carries it out on every reply, and it is checked twice:
|
||||
|
||||
- in the daemon, before anything is built, so a stale buffer refuses in a tenth of the time and the sentence names the
|
||||
buffer rather than the module;
|
||||
- in the agent, on the game thread, at the moment the job is claimed — which is the check that makes it *sound*, since
|
||||
everything between the two takes time.
|
||||
|
||||
The two drops say different sentences, because the fixes differ. Resumed: stop it again. Re-stopped: stopping it again
|
||||
does nothing, and what is wanted is to look at what is there now.
|
||||
|
||||
### Three refusals about where, above both backends
|
||||
|
||||
`Session.step_into` builds four shapes and three of them are places. The fourth is named in `session.ml` rather than
|
||||
left to a backend, because `emit`'s `place` would `failwith` on an Option — it derives the type through `Named n` —
|
||||
and `x86`'s `field_loc` handles one fine. Two backends disagreeing about what is writable is worse than either answer.
|
||||
|
||||
Each refusal gives the reason about the *program*, not about the compiler. A data type's case field: which case the
|
||||
bytes are in is the tag, so there is no address to store to that does not also settle it. An option's payload: storing
|
||||
past the tag leaves a `None` holding a value nothing will ever look at. A pointer: an address typed into a prompt is
|
||||
one the editor made up, nothing blessed it, and the program would dereference it at a moment nobody chose — which is
|
||||
the read half's rule said in the other direction.
|
||||
|
||||
### `Check.expression` grew a `want`, and `Check.expressions` a shared frame
|
||||
|
||||
The first is why `3` into an `f32` field is an f32 three. Without an expectation the literal takes its default width
|
||||
and the store is refused for a mismatch the reader never wrote; with one it arrives at the place's type, and what stays
|
||||
refused is what really does not fit — in the checker's own words, which is the only place that sentence should be
|
||||
written down.
|
||||
|
||||
The second is the batch. Two expressions checked apart both number their slots from zero, so splicing them into one
|
||||
thunk would have the second one's `let` reading and writing the first one's storage: a frame that is two frames wearing
|
||||
one frame's clothes. There is exactly one allocator of slot indices in this compiler and it is `ctx`'s counter, so
|
||||
sharing the `ctx` is the whole of the fix.
|
||||
|
||||
The thunk stores and then **renders the same place**, between the same `dev-begin`/`dev-end` the read half uses. What
|
||||
comes back is therefore not the editor's idea of what it asked for; it is what is there afterwards, read by the printer
|
||||
that drew the buffer. One job also means the store and the reading of it cannot straddle a resume. `retains` is left at
|
||||
its default: a module that stores a string literal leaves the program pointing into that module's image, and the
|
||||
default is what keeps the mapping alive for it.
|
||||
|
||||
### The buffer as the value
|
||||
|
||||
A rendered Flan value is a Flan literal, so the editable form of the value is the value's own spelling — no second
|
||||
notation, nothing to translate. `flan-inspect--literal` lays it out over lines and round-trips through
|
||||
`flan-inspect-parse`, which is what makes a commit a comparison of two *parses* rather than of two strings.
|
||||
|
||||
A commit is a diff and not a blast. One write per changed leaf, so editing one field of a struct does not rewrite the
|
||||
others with whatever was on the screen — which matters exactly when it is hardest to see that it does. A shape that
|
||||
changed is a refusal rather than an edit, and the refusal voids the edits that were collected before it: the walk
|
||||
visits fields in order, so a struct with one good change and one impossible one has already collected the good one, and
|
||||
handing that back beside the refusal would make it possible to send half of what was asked for.
|
||||
|
||||
The one guard that is easy to miss: a value the renderer truncated cannot be opened for editing at all. `...` is what
|
||||
it writes where it stopped, and a commit read off a buffer containing one could not tell a field that was never written
|
||||
from a field somebody deleted.
|
||||
|
||||
**Writing is refused on the expression and address roots**, by name. Not an omission to be worked around by sending
|
||||
`(set …)` to be evaluated: an expression is evaluated wherever the evaluator stands and at whatever moment it next
|
||||
reaches a frame boundary, which for a write means possibly into a running program. That leaves globals unwritable from
|
||||
the inspector for now, since the break buffer roots them at an expression — `C-x C-e` on `(set the-global …)` does that
|
||||
write knowingly, and the inspector will not do it behind a key that looks like the safe one.
|
||||
|
||||
## The watch window, and why it is the only listing that is pushed
|
||||
|
||||
The port of the author's Clojure `watch.el`, with the good idea kept and the transport turned round. The original is
|
||||
|
||||
@ -376,6 +376,10 @@ per line.
|
||||
| `g` | read it again |
|
||||
| `TAB` / `n` | next field |
|
||||
| `S-TAB` / `p` | previous field |
|
||||
| `e` | set the field at point |
|
||||
| `C-c C-e` | open the value for editing |
|
||||
| `C-c C-c` | commit what you changed in it |
|
||||
| `C-c C-k` | abandon the edit |
|
||||
| `q` | close |
|
||||
|
||||
Two things worth knowing, because they are unlike other inspectors.
|
||||
@ -443,6 +447,83 @@ 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.
|
||||
|
||||
### Changing one — `e`, and `C-c C-e`
|
||||
|
||||
The inspector writes as well as reads, and the loop it is for is the one the
|
||||
whole dev story is about: "that field is wrong" and "is it *this* value that
|
||||
fixes it" are two keystrokes apart, where editing the source and reloading
|
||||
answers a different question — it answers what the **next** run does.
|
||||
|
||||
**`e`** sets the field or element at point. You are prompted with what is there
|
||||
now, and what you type is a Flan **expression**, evaluated in the program and
|
||||
checked against the type of the place it is going into. `(+ 1 2)`, a string
|
||||
literal, a whole struct literal all work; one that does not fit comes back with
|
||||
the checker's own sentence — *expected f32, found string* — and nothing is
|
||||
stored. A literal arrives at the place's width, so `3` into an `f32` field is
|
||||
three point oh and not a refusal you would have had to write `3.0` to avoid.
|
||||
Point on no field line at all sets the whole value, which is how a data type's
|
||||
case is changed.
|
||||
|
||||
**`C-c C-e`** turns the buffer into the value. What you get is the Flan literal
|
||||
the program wrote — the value's own spelling, with no second notation to learn
|
||||
— and you edit it as text. **`C-c C-c`** commits; **`C-c C-k`** throws it away.
|
||||
|
||||
A commit is a **diff**, not a blast. The buffer is read back as a value,
|
||||
compared leaf by leaf with what was drawn, and one write is sent per leaf that
|
||||
changed — so editing one field of a struct does not rewrite the others with
|
||||
what happened to be on your screen. Every write in a commit goes in **one**
|
||||
module: either all of them happened at this stop, or none did.
|
||||
|
||||
What it refuses, and each by name with the reason:
|
||||
|
||||
- **A shape that changed.** Adding or removing an element, adding or renaming a
|
||||
field, putting a number where a struct was, changing which case a data type
|
||||
holds. Those are changes to the container or to the tag, not stores into
|
||||
storage. `e` on the value sets it whole, which is the operation that *is*
|
||||
available.
|
||||
- **A value the renderer did not write.** `<ptr>`, `<Name>`, and the `...` the
|
||||
walk writes where it stopped at its depth or span bound. A buffer with one of
|
||||
those in it is a buffer missing part of the value, and a commit read off it
|
||||
could not tell a field that was never written from one you deleted — so the
|
||||
value refuses to be opened for editing at all.
|
||||
- **A pointer.** An address typed into a prompt is one the editor made up.
|
||||
Nothing blessed it and the program would dereference it at a moment nobody
|
||||
chose; the read half does not follow pointers either.
|
||||
- **An option's payload on its own.** The tag is what says whether there is
|
||||
one. Set the option.
|
||||
|
||||
### What makes writing safe
|
||||
|
||||
Writing is refused outright on the expression and address roots. Only the
|
||||
**frame and slot** root can be written to, and the reasons are what the whole
|
||||
feature rests on.
|
||||
|
||||
The program must be **stopped**, because a poke into storage the program is
|
||||
mutating is corruption with a plausible shape. But "stopped" is not enough on
|
||||
its own: a write is built by a compiler, and a third of a second of `llc` is
|
||||
long enough for a game to resume, run a frame, and stop again. The same slot
|
||||
index of a different stack is not the place you were looking at.
|
||||
|
||||
So a write names the **stop** it was addressed to, not the state. Every
|
||||
inspection carries the number of the stop it was read at; a write hands that
|
||||
number back; and it is checked twice — here, before anything is built, so a
|
||||
stale buffer refuses in a tenth of the time and names the buffer rather than
|
||||
the module, and again inside the program, on the game thread, at the moment the
|
||||
module is claimed. A program that went round its loop between the drawing and
|
||||
the commit refuses with *look again and re-do the edit*, which is the whole of
|
||||
the fix.
|
||||
|
||||
The read-only view stays the default. `e` and `C-c C-e` are there when the root
|
||||
can carry them, and the key legend at the foot of the buffer lists them only
|
||||
then — a legend offering a key that would refuse is advertising a refusal.
|
||||
|
||||
A **global** is not writable from here yet: the break buffer roots globals at an
|
||||
expression, and an expression is evaluated wherever the evaluator stands and
|
||||
whenever it next reaches a frame boundary, which for a write means possibly
|
||||
into a running program. `C-x C-e` on `(set the-global …)` does that write
|
||||
knowingly; the inspector will not do it behind a key that looks the same as the
|
||||
safe one.
|
||||
|
||||
### Where the memory went — `M-x flan-allocations` and `M-x flan-leaks`
|
||||
|
||||
The same registry, read as a table rather than at one address. **`M-x
|
||||
|
||||
@ -96,6 +96,7 @@
|
||||
|
||||
;;; Code:
|
||||
|
||||
(require 'cl-lib)
|
||||
(require 'seq)
|
||||
(require 'subr-x)
|
||||
|
||||
@ -420,6 +421,24 @@ whole.")
|
||||
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.")
|
||||
(defvar-local flan-inspect--rendered nil
|
||||
"What the program wrote, before it was parsed.
|
||||
Kept because it is the thing edit mode hands you: a Flan literal is what the
|
||||
renderer writes, so the buffer you type into is the value's own spelling and
|
||||
not a second notation invented for editing it.")
|
||||
(defvar-local flan-inspect--at-stop nil
|
||||
"Which stop this buffer was drawn at, as the daemon numbered it.
|
||||
Nil where the reply did not say — only the slot root does, because only it
|
||||
reads from a frame, and only what is read from a frame can be written back.
|
||||
A write carries this number, and the program refuses it if it has been round
|
||||
its loop and stopped again since: what is on the screen would then describe
|
||||
storage that has moved, and overwriting it would be aimed at nothing anybody
|
||||
looked at.")
|
||||
(defvar-local flan-inspect--editing nil
|
||||
"Where the value starts, while this buffer is the value rather than a listing.
|
||||
A marker and not a flag, because the header above it is two lines or three
|
||||
depending on whether the daemon named a type, and the reader that parses the
|
||||
buffer back has to start in the same place this one stopped writing.")
|
||||
|
||||
(defun flan-inspect--label (child)
|
||||
"How CHILD is named in the list: `0.' for an element, `.x' for a field.
|
||||
@ -571,8 +590,12 @@ DECLARED is the type the daemon named, when it named one."
|
||||
(flan-inspect-refusal node root))
|
||||
'face 'font-lock-comment-face)))))
|
||||
(insert "\n")
|
||||
;; The write keys are only listed where they would work. A legend that
|
||||
;; offered `e' on an expression root would be advertising a refusal.
|
||||
(insert (propertize
|
||||
"RET inspect l back g refresh TAB/n next p previous q quit\n"
|
||||
(if (flan-inspect--writable)
|
||||
"RET inspect l back g refresh TAB/n next p previous q quit\n"
|
||||
"RET inspect e set C-c C-e edit l back g refresh TAB/n next p previous q quit\n")
|
||||
'face 'shadow))
|
||||
(goto-char (point-min))))
|
||||
|
||||
@ -616,10 +639,17 @@ and whether that may be followed is the answer"))
|
||||
(_ (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")))
|
||||
(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))))
|
||||
(list :value (or (plist-get r :value)
|
||||
(user-error
|
||||
"flan: the program answered without a value for %s"
|
||||
(flan-inspect--root-label root path)))
|
||||
:type (plist-get r :type)
|
||||
;; The stop the read happened at, where the reply carried one. It
|
||||
;; travels with the value rather than being asked for separately,
|
||||
;; because asked separately it would be a second question about a
|
||||
;; different instant — and the whole use of the number is that it is
|
||||
;; true of *what is on the screen*.
|
||||
:at-stop (plist-get r :at-stop))))
|
||||
|
||||
(defun flan-inspect--show (root path &optional stack)
|
||||
"Render ROOT walked by PATH in the inspector buffer, with STACK behind it."
|
||||
@ -629,9 +659,19 @@ and whether that may be followed is the answer"))
|
||||
(unless (derived-mode-p 'flan-inspect-mode) (flan-inspect-mode))
|
||||
(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--rendered (plist-get answer :value))
|
||||
(setq flan-inspect--node (flan-inspect-parse flan-inspect--rendered))
|
||||
(setq flan-inspect--type (plist-get answer :type))
|
||||
(setq flan-inspect--at-stop (plist-get answer :at-stop))
|
||||
(setq flan-inspect--stack stack)
|
||||
(setq flan-inspect--editing nil)
|
||||
;; Put back what editing turned off, here and not in the two commands
|
||||
;; that leave it: this is the one funnel every drawing goes through, and
|
||||
;; the mode body that set them in the first place does not run a second
|
||||
;; time on a buffer that is already in the mode. Without it a listing
|
||||
;; drawn after a commit is a listing you can yank into.
|
||||
(setq buffer-read-only t)
|
||||
(setq-local truncate-lines t)
|
||||
(flan-inspect--render root path flan-inspect--node stack
|
||||
flan-inspect--type))
|
||||
(display-buffer buf)
|
||||
@ -769,6 +809,360 @@ someone asked for reads very differently from one a timer produced."
|
||||
flan-inspect--stack)
|
||||
(with-current-buffer flan-inspect-buffer (goto-char (min p (point-max))))))
|
||||
|
||||
;;; Writing one back
|
||||
|
||||
;; SLY sets a value from its inspector, and the reason it is worth having here
|
||||
;; is the reason the read half exists: the loop between "that field is wrong"
|
||||
;; and "is it this value that fixes it" is the loop the whole dev story is
|
||||
;; about, and changing the source and reloading answers a different question —
|
||||
;; it answers what the *next* run does.
|
||||
;;
|
||||
;; Two ways in, and they are the same request underneath. `e' on a line sets
|
||||
;; one field. `C-c C-e' turns the buffer into the value itself, you edit it
|
||||
;; like text, and `C-c C-c' sends one write per leaf you changed. Both end in
|
||||
;; `(:op "set")' with a list of (path, expression) edits, both are refused
|
||||
;; whole if any one edit is impossible, and both redraw from what the program
|
||||
;; holds afterwards rather than from what was typed.
|
||||
;;
|
||||
;; What makes writing defensible at all is that the program is stopped and
|
||||
;; stays stopped. The daemon checks that, the agent checks it again on the
|
||||
;; game thread at the moment the module is claimed, and the *stop* is named
|
||||
;; rather than the state — so a program that resumed and stopped again between
|
||||
;; the drawing and the commit refuses, instead of storing into the same slot
|
||||
;; index of a stack nobody looked at.
|
||||
|
||||
(defun flan-inspect--writable (&optional what)
|
||||
"Why this buffer cannot be written to, or nil if it can.
|
||||
WHAT names the operation in the refusal."
|
||||
(let ((what (or what "a write")))
|
||||
(cond
|
||||
((null flan-inspect--root) "nothing is being inspected")
|
||||
;; The write verb roots at a frame slot and has no other root. That is
|
||||
;; not an omission to be worked around here by sending `(set …)' to be
|
||||
;; evaluated: an expression is evaluated wherever the evaluator stands and
|
||||
;; at whatever moment it gets a frame boundary, which for a *write* means
|
||||
;; storing into a program that is very possibly running — the one thing
|
||||
;; this must not do. So it is refused, with the root that can.
|
||||
((not (eq (car-safe flan-inspect--root) :slot))
|
||||
(format "%s roots at a frame's slot, and this buffer is on %s. \
|
||||
`i' on a local in the break buffer gives the root that can be written to"
|
||||
what
|
||||
(if (eq (car-safe flan-inspect--root) :addr)
|
||||
"an address"
|
||||
"an expression")))
|
||||
((not (and (integerp flan-inspect--at-stop) (> flan-inspect--at-stop 0)))
|
||||
(format "%s has to name the stop it was read at, and this drawing \
|
||||
carries none. Press `g' to read it again" what))
|
||||
(t nil))))
|
||||
|
||||
(defun flan-inspect--send (edits)
|
||||
"Store EDITS, a list of (STEPS . CODE), into what this buffer is showing.
|
||||
STEPS are relative to the buffer's own path. Redraws from the reply, which is
|
||||
the program's storage read back and not an echo of what was sent."
|
||||
(let* ((root flan-inspect--root)
|
||||
(path flan-inspect--path)
|
||||
(stack flan-inspect--stack)
|
||||
(frame (nth 1 root))
|
||||
(slot (nth 2 root))
|
||||
(r (funcall
|
||||
flan-inspect-request-function
|
||||
(append
|
||||
(list :op "set" :frame frame :slot slot)
|
||||
(when path
|
||||
(list :path (mapcar #'flan-inspect-wire-step path)))
|
||||
(list :at-stop flan-inspect--at-stop
|
||||
:edits
|
||||
(mapcar
|
||||
(lambda (e)
|
||||
(append (list :code (cdr e))
|
||||
(when (car e)
|
||||
(list :path
|
||||
(mapcar #'flan-inspect-wire-step
|
||||
(car e))))))
|
||||
edits))))))
|
||||
(unless (equal (plist-get r :status) "ok")
|
||||
(user-error "flan: %s" (or (plist-get r :message) "refused")))
|
||||
;; Redrawn from a fresh read rather than from the reply's value, even
|
||||
;; though the reply carries one. The reply is the value at the path that
|
||||
;; was written; the buffer may be showing a parent of it, and drawing the
|
||||
;; child there would be the wrong value in the right place. `--show' also
|
||||
;; picks up the new stop number, which the next commit needs.
|
||||
(flan-inspect--show root path stack)
|
||||
(message "flan: wrote %s" (plist-get r :value))
|
||||
r))
|
||||
|
||||
(defun flan-inspect-set ()
|
||||
"Set the field or element at point, or the whole value when point is not on one.
|
||||
Prompts with what is there now; what you type is a Flan *expression*, checked
|
||||
in the program against the type of the place it is going into — so `(+ 1 2)',
|
||||
a string literal and a struct literal all work, and one that does not fit is
|
||||
refused in the checker's own words."
|
||||
(interactive)
|
||||
(let ((why (flan-inspect--writable "setting a value")))
|
||||
(when why (user-error "flan: %s" why)))
|
||||
(let* ((step (get-text-property (point) 'flan-inspect-step))
|
||||
(node (or (get-text-property (point) 'flan-inspect-node)
|
||||
flan-inspect--node))
|
||||
;; The step the wire wants carries the type it is a field *of*, the
|
||||
;; same graft `flan-inspect-into' makes and for the same reason: a
|
||||
;; data type's payload sits at an offset that depends on the case.
|
||||
(steps (cond
|
||||
((null step) nil)
|
||||
((eq (plist-get flan-inspect--node :kind) 'option) (list '(:some)))
|
||||
(t (list (pcase step
|
||||
(`(:field ,name)
|
||||
(list :field name
|
||||
(plist-get flan-inspect--node :type)))
|
||||
(_ step))))))
|
||||
(where (flan-inspect--root-label
|
||||
flan-inspect--root
|
||||
(append flan-inspect--path steps)))
|
||||
(now (flan-inspect--literal node))
|
||||
(code (read-string (format "Set %s to: " where) now)))
|
||||
(when (string-empty-p (string-trim code))
|
||||
(user-error "flan: nothing to store"))
|
||||
(flan-inspect--send (list (cons steps code)))))
|
||||
|
||||
;;; The buffer as the value
|
||||
|
||||
;; The second half, and the one that is not SLY's. A rendered Flan value is a
|
||||
;; Flan literal — `(Point {.x 1.5 .y 2.5})' is what the renderer writes and
|
||||
;; what the source would write — so the editable form of the value is the
|
||||
;; value's own spelling, with no second notation to learn and nothing to
|
||||
;; translate. Editing it is editing text; committing it is a diff.
|
||||
;;
|
||||
;; A diff and not a blast. A struct with one changed field sends one write for
|
||||
;; that field, so the untouched fields are not rewritten with what was on the
|
||||
;; screen — which matters exactly when it is hardest to see that it does: two
|
||||
;; people, or a program and a person, touching the same value.
|
||||
|
||||
(defun flan-inspect--literal (node &optional indent)
|
||||
"NODE as Flan source, laid out over lines from INDENT.
|
||||
Round-trips through `flan-inspect-parse': what this writes is what that reads,
|
||||
which is what makes the commit a comparison of two parses rather than a
|
||||
comparison of two strings."
|
||||
(let* ((indent (or indent 0))
|
||||
(pad (make-string (+ indent 2) ?\s))
|
||||
(kids (plist-get node :children)))
|
||||
(pcase (plist-get node :kind)
|
||||
('struct
|
||||
(if (null kids)
|
||||
(format "(%s {})" (plist-get node :text))
|
||||
(concat "(" (plist-get node :text) " {"
|
||||
(mapconcat
|
||||
(lambda (c)
|
||||
(concat "\n" pad "." (format "%s" (car c)) " "
|
||||
(flan-inspect--literal (cdr c) (+ indent 2))))
|
||||
kids "")
|
||||
"})")))
|
||||
('seq
|
||||
(if (null kids) "[]"
|
||||
(concat "["
|
||||
(mapconcat
|
||||
(lambda (c)
|
||||
(concat "\n" pad (flan-inspect--literal (cdr c) (+ indent 2))))
|
||||
kids "")
|
||||
"]")))
|
||||
('option
|
||||
(concat "(some " (flan-inspect--literal (cdr (car kids)) indent) ")"))
|
||||
(_ (plist-get node :text)))))
|
||||
|
||||
(defun flan-inspect--complete (node)
|
||||
"Why NODE is not a whole value, or nil if it is.
|
||||
The renderer stops at a depth of 4 and a span of 8, and what it writes when it
|
||||
stops is `...'. A buffer holding one of those is a buffer where some of the
|
||||
value is simply not present — and a commit read off it would look exactly like
|
||||
somebody having deleted the part that was never written."
|
||||
(cond
|
||||
((eq (plist-get node :kind) 'trunc)
|
||||
"the renderer stopped at its depth bound of 4 here, so part of this value \
|
||||
was never written. Inspect the field that holds it, which re-roots the walk")
|
||||
((plist-get node :truncated)
|
||||
"the renderer stopped at its span bound of 8, so some of these are not in \
|
||||
the buffer — and a commit read off it could not tell them from ones you had \
|
||||
deleted")
|
||||
(t (seq-some (lambda (c) (flan-inspect--complete (cdr c)))
|
||||
(plist-get node :children)))))
|
||||
|
||||
(defun flan-inspect--diff (old new)
|
||||
"One edit per leaf that differs between OLD and NEW.
|
||||
Returns (EDITS . REFUSAL): EDITS is a list of (STEPS . CODE) and REFUSAL, when
|
||||
it is non-nil, is why the two cannot be compared at all. A shape that changed
|
||||
is a refusal and not an edit — adding a field to a struct or an element to an
|
||||
array is not something a store can do, and quietly writing the leaves that did
|
||||
line up would be the half-done version of what was asked."
|
||||
(let ((edits nil) (why nil))
|
||||
(cl-labels
|
||||
((no (fmt &rest args) (unless why (setq why (apply #'format fmt args))))
|
||||
(label (steps)
|
||||
(if steps
|
||||
(mapconcat (lambda (s)
|
||||
(pcase s
|
||||
(`(:field ,f . ,_) (concat "." f))
|
||||
(`(:index ,i) (format "[%d]" i))
|
||||
(`(:some) ".some")
|
||||
(_ "")))
|
||||
(reverse steps) "")
|
||||
"this value"))
|
||||
(walk (o n steps parent)
|
||||
(let ((ok (plist-get o :kind)) (nk (plist-get n :kind)))
|
||||
(cond
|
||||
((equal o n) nil)
|
||||
;; Asked of the *old* node and before the kinds are compared,
|
||||
;; because the question is what the program wrote and not what
|
||||
;; was typed over it. `<ptr>' and `<Name>' are what the renderer
|
||||
;; writes when it has not written the value, so anything in their
|
||||
;; place is an edit of nothing, whatever shape it now has.
|
||||
((memq ok '(ptr opaque))
|
||||
(no "%s is written as %s, which is what the renderer writes \
|
||||
when it did not write the value — so there is nothing there to have changed"
|
||||
(label steps) (plist-get o :text)))
|
||||
((not (eq ok nk))
|
||||
(no "%s was %s and is now %s: a store replaces a value, it \
|
||||
does not change what kind of thing is there. Use `e' on it to set the whole \
|
||||
value"
|
||||
(label steps) (flan-inspect--kind-name ok)
|
||||
(flan-inspect--kind-name nk)))
|
||||
((memq ok '(struct option))
|
||||
(if (and (eq ok 'struct)
|
||||
(not (equal (plist-get o :text) (plist-get n :text))))
|
||||
;; The head is the struct's name, and for a data type it is
|
||||
;; `Type.case' — so a changed head is a changed *case*, which
|
||||
;; is a change to the tag and not to any field under it.
|
||||
(no "%s is a %s and the buffer says %s: which case a data \
|
||||
type holds is the tag, not a field, so it is set whole. Use `e' on it"
|
||||
(label steps) (plist-get o :text) (plist-get n :text))
|
||||
(children o n steps)))
|
||||
((eq ok 'seq)
|
||||
(if (/= (length (plist-get o :children))
|
||||
(length (plist-get n :children)))
|
||||
(no "%s had %d element%s and the buffer has %d: adding or \
|
||||
removing one is a change to the container, which is a thing the program does \
|
||||
and not a thing a store does"
|
||||
(label steps) (length (plist-get o :children))
|
||||
(if (= 1 (length (plist-get o :children))) "" "s")
|
||||
(length (plist-get n :children)))
|
||||
(children o n steps)))
|
||||
((equal (plist-get o :text) (plist-get n :text)) nil)
|
||||
(t
|
||||
(push (cons (reverse steps) (plist-get n :text)) edits))))
|
||||
(ignore parent))
|
||||
(children (o n steps)
|
||||
(let ((ok (mapcar #'car (plist-get o :children)))
|
||||
(nk (mapcar #'car (plist-get n :children))))
|
||||
(if (not (equal ok nk))
|
||||
(no "%s has %s in the buffer and %s in the program: a store \
|
||||
writes what is there, it does not add or rename fields"
|
||||
(label steps)
|
||||
(if nk (mapconcat (lambda (k) (format "%s" k)) nk " ") "nothing")
|
||||
(if ok (mapconcat (lambda (k) (format "%s" k)) ok " ") "nothing"))
|
||||
(dolist (c (plist-get o :children))
|
||||
(let ((step (if (integerp (car c))
|
||||
(list :index (car c))
|
||||
(if (eq (plist-get o :kind) 'option)
|
||||
(list :some)
|
||||
(list :field (car c) (plist-get o :type))))))
|
||||
(walk (cdr c)
|
||||
(cdr (assoc (car c) (plist-get n :children)))
|
||||
(cons step steps) o)))))))
|
||||
(walk old new nil nil))
|
||||
;; A refusal voids the edits rather than sitting beside them. The walk
|
||||
;; visits fields in order, so a struct with one good change and one
|
||||
;; impossible one collects the good one before it reaches the other — and
|
||||
;; handing that back with the refusal would make it possible for a caller
|
||||
;; to send half of what was asked for. Nothing does; this is what makes
|
||||
;; it not merely a convention.
|
||||
(cons (and (null why) (nreverse edits)) why)))
|
||||
|
||||
(defun flan-inspect--kind-name (kind)
|
||||
"KIND, said in words, for a refusal that has to name two of them."
|
||||
(pcase kind
|
||||
('struct "a struct") ('seq "a sequence") ('option "an option")
|
||||
('ptr "a pointer") ('opaque "a type with no structure")
|
||||
('trunc "the renderer's mark for where it stopped")
|
||||
(_ "a single value")))
|
||||
|
||||
(defun flan-inspect-edit ()
|
||||
"Turn this buffer into the value, editable.
|
||||
What you get is the Flan literal the program wrote. Change it as text;
|
||||
`C-c C-c' sends one write per leaf you changed and redraws from what the
|
||||
program holds afterwards, `C-c C-k' throws the edit away."
|
||||
(interactive)
|
||||
(let ((why (flan-inspect--writable "editing the value")))
|
||||
(when why (user-error "flan: %s" why)))
|
||||
(when flan-inspect--editing (user-error "flan: this buffer is already open for editing"))
|
||||
(let ((why (flan-inspect--complete flan-inspect--node)))
|
||||
(when why (user-error "flan: %s" why)))
|
||||
(let ((inhibit-read-only t))
|
||||
(erase-buffer)
|
||||
(insert (propertize (flan-inspect--root-label flan-inspect--root
|
||||
flan-inspect--path)
|
||||
'face 'font-lock-function-name-face)
|
||||
"\n")
|
||||
(when flan-inspect--type
|
||||
(insert (propertize (format "%s\n" flan-inspect--type)
|
||||
'face 'font-lock-type-face)))
|
||||
(insert (propertize
|
||||
"--- Editing. C-c C-c commits what you changed, C-c C-k abandons it.\n"
|
||||
'face 'font-lock-comment-face))
|
||||
(insert "\n")
|
||||
;; Where the value starts, recorded rather than counted back to. The
|
||||
;; header above is two lines or three depending on whether the daemon
|
||||
;; named a type, and a count written here and again in the reader is two
|
||||
;; places to keep in step for no gain.
|
||||
(setq flan-inspect--editing (point-marker))
|
||||
(set-marker-insertion-type flan-inspect--editing nil)
|
||||
(insert (flan-inspect--literal flan-inspect--node))
|
||||
(insert "\n")
|
||||
(setq buffer-read-only nil)
|
||||
(setq-local truncate-lines nil)
|
||||
;; The header is not part of the value, so it is not part of what gets
|
||||
;; parsed back — and it is fixed rather than merely un-parsed, because a
|
||||
;; header edited by accident would otherwise read as the value having
|
||||
;; grown a line.
|
||||
(add-text-properties (point-min) (marker-position flan-inspect--editing)
|
||||
'(read-only t front-sticky t))
|
||||
(goto-char (point-max))
|
||||
(forward-line -1)))
|
||||
|
||||
(defun flan-inspect--edited ()
|
||||
"What the editable part of this buffer says, parsed."
|
||||
(save-excursion
|
||||
(goto-char (marker-position flan-inspect--editing))
|
||||
(let ((text (buffer-substring-no-properties (point) (point-max))))
|
||||
(when (string-empty-p (string-trim text))
|
||||
(user-error "flan: there is nothing left in the buffer to commit"))
|
||||
(let ((node (flan-inspect-parse text)))
|
||||
(unless node
|
||||
(user-error "flan: the buffer does not read as a Flan value"))
|
||||
node))))
|
||||
|
||||
(defun flan-inspect-commit ()
|
||||
"Send one write per leaf changed since this buffer was opened for editing."
|
||||
(interactive)
|
||||
(unless flan-inspect--editing
|
||||
(user-error "flan: this buffer is a listing, not the value; `C-c C-e' opens it for editing"))
|
||||
(let* ((old flan-inspect--node)
|
||||
(new (flan-inspect--edited))
|
||||
(d (flan-inspect--diff old new))
|
||||
(edits (car d))
|
||||
(why (cdr d)))
|
||||
(when why (user-error "flan: %s" why))
|
||||
(unless edits
|
||||
;; Not silently nothing. A commit that found no change is a fact worth
|
||||
;; saying — most often it means the edit went into the header, or into a
|
||||
;; part of the buffer that is a summary rather than the value.
|
||||
(user-error "flan: nothing in the buffer differs from what the program holds"))
|
||||
(flan-inspect--send edits)))
|
||||
|
||||
(defun flan-inspect-abandon ()
|
||||
"Throw the edit away and draw what the program holds."
|
||||
(interactive)
|
||||
(unless flan-inspect--editing
|
||||
(user-error "flan: this buffer is not open for editing"))
|
||||
(flan-inspect--show flan-inspect--root flan-inspect--path
|
||||
flan-inspect--stack))
|
||||
|
||||
(defun flan-inspect--fields ()
|
||||
"The start of every inspectable line, in order.
|
||||
Both movement commands go through this rather than walking property changes
|
||||
@ -823,6 +1217,15 @@ the kind of thing nobody reports and everybody notices."
|
||||
(define-key map [backtab] #'flan-inspect-previous)
|
||||
(define-key map "p" #'flan-inspect-previous)
|
||||
(define-key map "q" #'quit-window)
|
||||
;; The write half. `e' for the one field under point, because that is the
|
||||
;; letter Emacs uses for "edit the thing here" everywhere else a buffer
|
||||
;; lists things; the prefixed pair for the mode, because `C-c C-c' is what
|
||||
;; commits an editing buffer in this editor — message, log-edit and
|
||||
;; org-src all — and `C-c C-k' is what abandons one.
|
||||
(define-key map "e" #'flan-inspect-set)
|
||||
(define-key map (kbd "C-c C-e") #'flan-inspect-edit)
|
||||
(define-key map (kbd "C-c C-c") #'flan-inspect-commit)
|
||||
(define-key map (kbd "C-c C-k") #'flan-inspect-abandon)
|
||||
map)
|
||||
"Keys in `flan-inspect-mode'.")
|
||||
|
||||
|
||||
@ -655,6 +655,285 @@ unwind would send the next one to a daemon that is not there."
|
||||
(or (test-flan--caught #'flan-inspect-pop) ""))))))
|
||||
|
||||
|
||||
;;; Writing one back
|
||||
|
||||
(message "\nsetting a value, and the buffer as the value")
|
||||
|
||||
(defun test-flan--writable (value &optional type replies body)
|
||||
"Open a slot root on VALUE, at a stop, and run BODY in its buffer.
|
||||
The stop number is what makes the buffer writable at all, so it is in the
|
||||
fixture rather than in each test: a reply without one is a reply from a read
|
||||
the daemon could not date, and this helper is for the case where it could."
|
||||
(test-flan--slot
|
||||
1 0 "b"
|
||||
(or replies
|
||||
(lambda (form)
|
||||
(if (equal (plist-get form :op) "set")
|
||||
(list :status "ok" :type (or type "Blob") :value value :at-stop 7
|
||||
:wrote 1)
|
||||
(list :status "ok" :type (or type "Blob") :value value :at-stop 7))))
|
||||
body))
|
||||
|
||||
;; The two refusals that come before any request: a root that names no frame,
|
||||
;; and a drawing that names no stop. Both are refusals of *this buffer*
|
||||
;; rather than of the value in it, and both say which root can.
|
||||
(let ((flan-inspect-request-function
|
||||
(lambda (_) (list :status "ok" :value "7" :type "i32")))
|
||||
(flan-inspect-buffer " *test-inspect*"))
|
||||
(save-window-excursion
|
||||
(flan-inspect "g")
|
||||
(with-current-buffer " *test-inspect*"
|
||||
(test-flan--check "an expression root cannot be written to"
|
||||
(string-match-p
|
||||
"roots at a frame's slot"
|
||||
(or (test-flan--caught #'flan-inspect-set) "")))
|
||||
(test-flan--check "and neither can an address root, for the same reason"
|
||||
(progn
|
||||
(flan-inspect-address 4096 nil)
|
||||
(string-match-p
|
||||
"roots at a frame's slot"
|
||||
(or (test-flan--caught #'flan-inspect-set) "")))))))
|
||||
|
||||
(test-flan--slot
|
||||
1 0 "b"
|
||||
(lambda (_) (list :status "ok" :type "i32" :value "7"))
|
||||
(lambda ()
|
||||
(test-flan--check "a slot root the daemon did not date cannot be written to"
|
||||
(string-match-p
|
||||
"name the stop"
|
||||
(or (test-flan--caught #'flan-inspect-set) "")))
|
||||
(test-flan--check "and the legend does not offer keys that would refuse"
|
||||
(not (string-match-p "e set" (buffer-string))))))
|
||||
|
||||
;; `e' on a field line. What is sent is the buffer's own path with the line's
|
||||
;; step on the end, the stop the drawing was made at, and the expression typed
|
||||
;; — not a value the client converted into anything.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
|
||||
(lambda ()
|
||||
(test-flan--check "the legend offers the write keys where they work"
|
||||
(string-match-p "e set" (buffer-string)))
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) ; .id
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ 1 2)")))
|
||||
(flan-inspect-set))
|
||||
(let ((sent (car (last test-flan--asked 2))))
|
||||
(test-flan--check "e sends a set"
|
||||
(equal (plist-get sent :op) "set"))
|
||||
(test-flan--check "rooted at the frame and slot the buffer is on"
|
||||
(and (equal (plist-get sent :frame) 1)
|
||||
(equal (plist-get sent :slot) 0)))
|
||||
(test-flan--check "naming the stop the drawing was made at"
|
||||
(equal (plist-get sent :at-stop) 7))
|
||||
(test-flan--check "with one edit, at the field the line names"
|
||||
(equal (plist-get sent :edits)
|
||||
'((:code "(+ 1 2)" :path ("id")))))
|
||||
(test-flan--check "and the expression is sent as it was typed"
|
||||
(equal (plist-get (car (plist-get sent :edits)) :code)
|
||||
"(+ 1 2)")))
|
||||
(test-flan--check "and the buffer is drawn again from a fresh read"
|
||||
(equal (plist-get (car test-flan--asked) :op) "inspect"))))
|
||||
|
||||
;; The prompt offers what is there, so the common edit is a character.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next) (flan-inspect-next) ; .name
|
||||
(let ((offered nil))
|
||||
(cl-letf (((symbol-function 'read-string)
|
||||
(lambda (_ &optional init &rest _r) (setq offered init) "\"sandy2\"")))
|
||||
(flan-inspect-set))
|
||||
(test-flan--check "the prompt starts from what is there now"
|
||||
(equal offered "\"sandy\"")))))
|
||||
|
||||
;; Point on nothing in particular sets the whole value, which is how a data
|
||||
;; type's case is changed and how anything the field list cannot reach is.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7})" "Blob" nil
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(Blob {.id 9})")))
|
||||
(flan-inspect-set))
|
||||
(let ((sent (car (last test-flan--asked 2))))
|
||||
(test-flan--check "point off a field line sets the whole value"
|
||||
(equal (plist-get sent :edits)
|
||||
'((:code "(Blob {.id 9})")))))))
|
||||
|
||||
;; A refusal from the daemon reaches the person and changes nothing. The
|
||||
;; refusals that matter here are the daemon's own — a type that does not fit,
|
||||
;; a stop that has moved — and this end must not paper over either.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7})" "Blob"
|
||||
(lambda (form)
|
||||
(if (equal (plist-get form :op) "set")
|
||||
(list :status "error" :message "expected i32, found string")
|
||||
(list :status "ok" :type "Blob" :value "(Blob {.id 7})" :at-stop 7)))
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "\"no\"")))
|
||||
(test-flan--check "the checker's refusal reaches the person"
|
||||
(string-match-p
|
||||
"expected i32, found string"
|
||||
(or (test-flan--caught #'flan-inspect-set) ""))))))
|
||||
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7})" "Blob"
|
||||
(lambda (form)
|
||||
(if (equal (plist-get form :op) "set")
|
||||
(list :status "error"
|
||||
:message "this was written against stop 7 and the program is at \
|
||||
stop 9 now: it ran on and stopped again, so what is on the screen is not what \
|
||||
would be overwritten. Look again and re-do the edit")
|
||||
(list :status "ok" :type "Blob" :value "(Blob {.id 7})" :at-stop 7)))
|
||||
(lambda ()
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "9")))
|
||||
(test-flan--check "a stale drawing is refused with what to do about it"
|
||||
(string-match-p
|
||||
"Look again"
|
||||
(or (test-flan--caught #'flan-inspect-set) ""))))))
|
||||
|
||||
;;; The buffer as the value
|
||||
|
||||
;; The literal the editable buffer holds is the value's own spelling, and it
|
||||
;; has to read back as what it was written from — otherwise a commit would
|
||||
;; diff a parse against a different parse and see changes nobody made.
|
||||
(let ((round
|
||||
(lambda (s)
|
||||
(equal (flan-inspect-parse s)
|
||||
(flan-inspect-parse
|
||||
(flan-inspect--literal (flan-inspect-parse s)))))))
|
||||
(test-flan--check "a struct round-trips through the editable spelling"
|
||||
(funcall round "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))
|
||||
(test-flan--check "an array does too"
|
||||
(funcall round "[ 10 20 30]"))
|
||||
(test-flan--check "and an option, and a nested one"
|
||||
(funcall round "(some (V {.x 1 .y (some 2)}))")))
|
||||
|
||||
(let ((old (flan-inspect-parse "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})")))
|
||||
;; One leaf changed is one edit, with the steps that reach it and nothing
|
||||
;; else — the whole point of diffing rather than writing the value back.
|
||||
(let ((d (flan-inspect--diff
|
||||
old
|
||||
(flan-inspect-parse
|
||||
"(Blob {.id 7 .name \"sandy\" .pos (V {.x 2.5 .y 0})})"))))
|
||||
(test-flan--check "one changed leaf is one edit"
|
||||
(equal (car d) '((((:field "pos" "Blob") (:field "x" "V")) . "2.5"))))
|
||||
(test-flan--check "and nothing is refused about it" (null (cdr d))))
|
||||
(let ((d (flan-inspect--diff
|
||||
old
|
||||
(flan-inspect-parse
|
||||
"(Blob {.id 8 .name \"tuned\" .pos (V {.x 1.5 .y 0})})"))))
|
||||
(test-flan--check "two changed leaves are two edits, and only two"
|
||||
(equal (car d)
|
||||
'((((:field "id" "Blob")) . "8")
|
||||
(((:field "name" "Blob")) . "\"tuned\"")))))
|
||||
(let ((d (flan-inspect--diff old (flan-inspect-parse "(Blob {.id 7 .name \"sandy\" .pos (V {.x 1.5 .y 0})})"))))
|
||||
(test-flan--check "an untouched value is no edits at all"
|
||||
(and (null (car d)) (null (cdr d)))))
|
||||
;; And the shapes that are not stores. Each is refused whole, so the leaf
|
||||
;; that did line up beside it does not go either.
|
||||
(let ((d (flan-inspect--diff
|
||||
old
|
||||
(flan-inspect-parse
|
||||
"(Blob {.id 8 .name \"sandy\" .pos 3})"))))
|
||||
(test-flan--check "a leaf where a struct was is refused, not written"
|
||||
(and (null (car d)) (string-match-p "kind of thing" (cdr d)))))
|
||||
(let ((d (flan-inspect--diff
|
||||
old
|
||||
(flan-inspect-parse "(Blob {.id 7 .name \"sandy\"})"))))
|
||||
(test-flan--check "a field removed is refused by name"
|
||||
(and (null (car d))
|
||||
(string-match-p "does not add or rename" (cdr d))))))
|
||||
|
||||
(let ((d (flan-inspect--diff (flan-inspect-parse "[ 1 2 3]")
|
||||
(flan-inspect-parse "[ 1 2 3 4]"))))
|
||||
(test-flan--check "an element added is a change to the container, and refused"
|
||||
(and (null (car d))
|
||||
(string-match-p "3 elements and the buffer has 4" (cdr d)))))
|
||||
|
||||
(let ((d (flan-inspect--diff
|
||||
(flan-inspect-parse "(Shape.circle {.r 1})")
|
||||
(flan-inspect-parse "(Shape.square {.r 1})"))))
|
||||
(test-flan--check "a data type's case is the tag, so it is not a field edit"
|
||||
(and (null (car d)) (string-match-p "set whole" (cdr d)))))
|
||||
|
||||
(let ((d (flan-inspect--diff (flan-inspect-parse "(B {.p <ptr>})")
|
||||
(flan-inspect-parse "(B {.p 4096})"))))
|
||||
(test-flan--check "typing over what the renderer did not write is refused"
|
||||
(and (null (car d)) (string-match-p "nothing there" (cdr d)))))
|
||||
|
||||
;; The truncation guard. A value the renderer stopped short of is one where
|
||||
;; some of the fields are simply absent from the buffer, and a commit read off
|
||||
;; it could not tell them from fields somebody deleted.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7 .deep (V {.a (W {.b ...})})})" "Blob" nil
|
||||
(lambda ()
|
||||
(test-flan--check "a truncated value refuses to be opened for editing"
|
||||
(string-match-p
|
||||
"never written"
|
||||
(or (test-flan--caught #'flan-inspect-edit) "")))))
|
||||
|
||||
;; And the whole round trip: open, edit the text, commit, and what goes out is
|
||||
;; one write for the leaf that changed.
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7 .name \"sandy\"})" "Blob" nil
|
||||
(lambda ()
|
||||
(flan-inspect-edit)
|
||||
(test-flan--check "editing shows the value as a Flan literal"
|
||||
(string-match-p "(Blob {" (buffer-string)))
|
||||
(test-flan--check "and says how to commit it"
|
||||
(string-match-p "C-c C-c commits" (buffer-string)))
|
||||
(test-flan--check "a commit with nothing changed says so"
|
||||
(string-match-p
|
||||
"nothing in the buffer differs"
|
||||
(or (test-flan--caught #'flan-inspect-commit) "")))
|
||||
(goto-char (point-min))
|
||||
(search-forward ".id 7")
|
||||
(replace-match ".id 42")
|
||||
(flan-inspect-commit)
|
||||
(let ((sent (car (last test-flan--asked 2))))
|
||||
(test-flan--check "the commit writes the one leaf that changed"
|
||||
(equal (plist-get sent :edits)
|
||||
'((:code "42" :path ("id")))))
|
||||
(test-flan--check "and names the stop the buffer was drawn at"
|
||||
(equal (plist-get sent :at-stop) 7)))
|
||||
(test-flan--check "and the buffer is a listing again afterwards"
|
||||
(not flan-inspect--editing))))
|
||||
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7})" "Blob" nil
|
||||
(lambda ()
|
||||
(flan-inspect-edit)
|
||||
(goto-char (point-max))
|
||||
(insert "junk (")
|
||||
(test-flan--check "an edit that has stopped being a value refuses whole"
|
||||
(let ((why (test-flan--caught #'flan-inspect-commit)))
|
||||
;; It reads as *something*, but not as the same shape,
|
||||
;; which is the refusal that names what changed.
|
||||
(and why (not (string-match-p "wrote" why)))))
|
||||
(flan-inspect-abandon)
|
||||
(test-flan--check "and abandoning draws what the program holds"
|
||||
(and (not flan-inspect--editing)
|
||||
(string-match-p "\\.id +7" (buffer-string))))
|
||||
;; The listing is read-only again, and that is the assertion rather than
|
||||
;; the flag: the flag says which mode the buffer is in, this says whether
|
||||
;; `C-k' on a line of the listing would do something.
|
||||
(test-flan--check "and the listing is read-only again afterwards"
|
||||
buffer-read-only)))
|
||||
|
||||
(test-flan--writable
|
||||
"(Blob {.id 7})" "Blob" nil
|
||||
(lambda ()
|
||||
(test-flan--check "committing a listing says it is not an edit"
|
||||
(string-match-p
|
||||
"C-c C-e"
|
||||
(or (test-flan--caught #'flan-inspect-commit) "")))))
|
||||
|
||||
|
||||
;;; Restarts: which of them can be taken
|
||||
|
||||
(message "\nrestarts, and §4's shadowing")
|
||||
|
||||
@ -15,6 +15,7 @@
|
||||
(require 'flan-repl)
|
||||
(require 'flan-watch)
|
||||
(require 'flan-lower)
|
||||
(require 'flan-inspect)
|
||||
|
||||
(defvar test-flan--failures 0)
|
||||
|
||||
@ -831,8 +832,13 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
;; Break it: `step' is called every time round the program's loop, so a body
|
||||
;; that errors stops it on its own game thread, in a frame of its own — not
|
||||
;; inside anything this client asked for. Nothing tells Emacs.
|
||||
;;
|
||||
;; The local in front of the error is for the inspector's write half further
|
||||
;; down: a frame has to have a named slot holding something with a field in
|
||||
;; it before anything can be stored into one. It is read back out by the
|
||||
;; error, so it is not a binding the checker can call unused.
|
||||
(flan--eval
|
||||
"(defn step [] i64 (restart-case (do (error (Missing {.id 7})) 0) (use-placeholder [] -1)))"
|
||||
"(defn step [] i64 (let [blip (Missing {.id 7})] (restart-case (do (error (Missing {.id (.id blip)})) 0) (use-placeholder [] -1))))"
|
||||
"form")
|
||||
(let ((deadline (+ (float-time) 20)))
|
||||
(while (and (not flan--stopped) (< (float-time) deadline))
|
||||
@ -884,6 +890,84 @@ already rely on it — so nothing here is a stand-in for the real thing."
|
||||
(flan-clear-result)
|
||||
(delete-region beg (point-max)))
|
||||
|
||||
;; The inspector, and then the inspector writing. This is the one place the
|
||||
;; whole chain runs against a real program: a frame the shadow stack knows,
|
||||
;; a slot index read off the listing, a render, a store, and a second render
|
||||
;; that is not the first one's echo — it is a fresh request, so what it shows
|
||||
;; came out of the program's storage after the write.
|
||||
(let* ((listing (flan--request '(:op "locals" :frame 0)))
|
||||
(slot (car (delq nil
|
||||
(mapcar (lambda (l)
|
||||
(and (equal (nth 0 l) "blip") (nth 3 l)))
|
||||
(plist-get listing :locals)))))
|
||||
(read-id (lambda ()
|
||||
(plist-get (flan--request
|
||||
(list :op "inspect" :frame 0 :slot slot
|
||||
:path '("id")))
|
||||
:value)))
|
||||
(refusal (lambda (f)
|
||||
(or (condition-case e (progn (funcall f) nil)
|
||||
(error (error-message-string e)))
|
||||
""))))
|
||||
(test-flan--check "the stopped frame's listing gives the local a slot index"
|
||||
(integerp slot))
|
||||
(when (integerp slot)
|
||||
(save-window-excursion
|
||||
(with-current-buffer (flan-inspect-slot 0 slot "blip")
|
||||
(test-flan--check "the inspector draws the local from the frame"
|
||||
(string-match-p "\\.id +7" (buffer-string)))
|
||||
(test-flan--check "and the drawing says which stop it was made at"
|
||||
(and (integerp flan-inspect--at-stop)
|
||||
(> flan-inspect--at-stop 0)))
|
||||
;; Level one: one field, from the line that names it.
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "(+ 40 2)")))
|
||||
(flan-inspect-set))
|
||||
(test-flan--check "a field set from the inspector lands in the frame"
|
||||
(string-match-p "\\.id +42" (buffer-string)))
|
||||
(test-flan--check "and reading it again agrees with the program"
|
||||
(equal (funcall read-id) "42"))
|
||||
;; A value that does not fit is refused in the checker's own words,
|
||||
;; and nothing moves.
|
||||
(goto-char (point-min))
|
||||
(flan-inspect-next)
|
||||
(cl-letf (((symbol-function 'read-string) (lambda (&rest _) "\"no\"")))
|
||||
(test-flan--check "a value of the wrong type is refused by the checker"
|
||||
(string-match-p "expected i32"
|
||||
(funcall refusal #'flan-inspect-set))))
|
||||
(test-flan--check "and the refused write changed nothing"
|
||||
(equal (funcall read-id) "42"))
|
||||
;; Level two: the buffer *is* the value, edited as text and committed
|
||||
;; as a diff.
|
||||
(flan-inspect-edit)
|
||||
(test-flan--check "editing shows the value as the literal it is"
|
||||
(string-match-p "(Missing {" (buffer-string)))
|
||||
(goto-char (point-min))
|
||||
(search-forward ".id 42")
|
||||
(replace-match ".id 11")
|
||||
(flan-inspect-commit)
|
||||
(test-flan--check "committing the buffer stores what was changed in it"
|
||||
(string-match-p "\\.id +11" (buffer-string)))
|
||||
(test-flan--check "and the program agrees"
|
||||
(equal (funcall read-id) "11"))
|
||||
;; And a commit against a stop the program has left refuses rather
|
||||
;; than storing into a stack nobody looked at. The stop is moved on
|
||||
;; here rather than the program, because making a program leave a
|
||||
;; break and come back inside a batch run is a race; what is under
|
||||
;; test is the refusal, and it is the program making it.
|
||||
(flan-inspect-edit)
|
||||
(goto-char (point-min))
|
||||
(search-forward ".id 11")
|
||||
(replace-match ".id 99")
|
||||
(setq flan-inspect--at-stop (+ 1000 flan-inspect--at-stop))
|
||||
(test-flan--check "a commit against a stop the program has left is refused"
|
||||
(string-match-p
|
||||
"Look again" (funcall refusal #'flan-inspect-commit)))
|
||||
(test-flan--check "and that write did not land either"
|
||||
(equal (funcall read-id) "11")))))
|
||||
(when (get-buffer flan-inspect-buffer) (kill-buffer flan-inspect-buffer)))
|
||||
|
||||
;; And installing, which the break loop allows on purpose: there is no frame
|
||||
;; in progress, so the rule against swapping a body that is on the stack does
|
||||
;; not apply. This is the fix-it-and-retry loop — the broken `step' is
|
||||
|
||||
53
lib/check.ml
53
lib/check.ml
@ -7107,19 +7107,58 @@ let instances_since env mark =
|
||||
List.rev
|
||||
(List.filteri (fun i _ -> i < fresh) env.instances)
|
||||
|
||||
(* One expression, checked against a program that is already running. The
|
||||
frame is empty — a REPL expression has no parameters and no enclosing
|
||||
function — so the slots it needs are whatever its own [let]s allocate. *)
|
||||
let expression env (e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array =
|
||||
(* Expressions checked against a program that is already running, all of them
|
||||
into *one* frame. It is empty to start with — a REPL expression has no
|
||||
parameters and no enclosing function — so the slots it ends up with are
|
||||
whatever their own [let]s allocate.
|
||||
|
||||
One frame and not one each, which is what the inspector's write verb needs
|
||||
and what it must not assemble by hand. Two expressions checked separately
|
||||
both number their slots from zero, so splicing them into one thunk would
|
||||
have the second one's [let] reading and writing the first one's storage — a
|
||||
frame that is two frames wearing one frame's clothes. Sharing the [ctx] is
|
||||
the whole of the fix, and it is a fix because there is exactly one allocator
|
||||
of slot indices in this compiler and it is this record's counter.
|
||||
|
||||
They are otherwise independent: none of them binds a name for the next,
|
||||
because the list is a list of values being stored and not a sequence.
|
||||
|
||||
[want] is the write verb too, and [C-x C-e] passes none: a store into a
|
||||
slot of type [f32] has an expectation to offer and a typed expression does
|
||||
not. The whole value of passing it is that [3] arrives as an [f32] rather
|
||||
than as an [i32] the store would then have to be refused for. It flows
|
||||
through [check] the way an expectation flows anywhere — that is what
|
||||
bidirectional means — and [expect] at the end catches the arms that ignore
|
||||
it, so the refusal is the checker's own "expected f32, found string" rather
|
||||
than a second sentence written here that would drift from it. *)
|
||||
let expressions env (es : (Types.t option * Ast.expr) list) :
|
||||
Tast.expr list * Types.t array * string option array =
|
||||
let ctx =
|
||||
{ env; ret = Types.Unit; slots = 0; slot_tys = []; slot_names = []; scope = []; defers = [];
|
||||
outer = []; outer_what = None; in_frames = None; loops = []; tail = false; in_defer = false; defer_ok = false; defer_block = "a nested form"; owner = "<none>" }
|
||||
in
|
||||
let t = check ctx e in
|
||||
(t, Array.of_list (List.rev ctx.slot_tys),
|
||||
(* Folded rather than mapped, because [List.map]'s order is unspecified and
|
||||
every one of these calls has a side effect on [ctx] — the slot counter it
|
||||
shares. An order nobody chose is one that can differ between builds, and
|
||||
two frames laid out differently for the same edit is the kind of thing
|
||||
that is found by somebody else, much later. *)
|
||||
let ts =
|
||||
List.rev
|
||||
(List.fold_left
|
||||
(fun acc (want, (e : Ast.expr)) ->
|
||||
expect e.Ast.loc ~want (check ctx ?want e) :: acc)
|
||||
[] es)
|
||||
in
|
||||
(ts, Array.of_list (List.rev ctx.slot_tys),
|
||||
Array.of_list (List.rev ctx.slot_names))
|
||||
|
||||
(* The one-expression case, which is every caller but the write verb. *)
|
||||
let expression env ?want (e : Ast.expr) :
|
||||
Tast.expr * Types.t array * string option array =
|
||||
match expressions env [ (want, e) ] with
|
||||
| [ t ], tys, names -> (t, tys, names)
|
||||
| _ -> assert false
|
||||
|
||||
(* ── --no-gc ────────────────────────────────────────────────────────────
|
||||
|
||||
The flag that says this program is to be compiled with no collector in it,
|
||||
|
||||
243
lib/dev.ml
243
lib/dev.ml
@ -166,6 +166,30 @@ let deliver t path = String.trim (request t path)
|
||||
the *question*, not the code. *)
|
||||
let deliver_stopped_only t path = deliver t ("stopped-only " ^ path)
|
||||
|
||||
(* And the same again for a module that may only run from *one particular*
|
||||
break. See the agent's [at_stop] note for why a write needs the stronger
|
||||
promise: "stopped at all" lets a resume and a re-stop through, and a store
|
||||
that goes through the shadow stack would then land in the same slot index
|
||||
of a different stack. *)
|
||||
let deliver_at_stop t ~gen path =
|
||||
deliver t (Printf.sprintf "at-stop %d %s" gen path)
|
||||
|
||||
(* Which stop the program is at: a number that is never reused, and 0 when it
|
||||
is not stopped at all.
|
||||
|
||||
[state] cannot stand in for this. Two stops at the same [(error (Boom …))]
|
||||
are both [Stopped "Boom"], and "is this still the stop I rendered under" is
|
||||
exactly the question they cannot tell apart — which is the question a write
|
||||
has to have an answer to before it stores anything.
|
||||
|
||||
[None] where the program cannot be reached or answers something else, and
|
||||
the caller treats that the way it treats a missing refusal count: as no
|
||||
evidence, not as zero. Zero is a fact — it means running. *)
|
||||
let stop_gen t : int option =
|
||||
match request t "stop" with
|
||||
| exception Unix.Unix_error _ -> None
|
||||
| text -> int_of_string_opt (String.trim text)
|
||||
|
||||
(* How many stopped-only modules the program has thrown away for reaching the
|
||||
game thread while it was running, and the sentence the agent says about it.
|
||||
|
||||
@ -1348,17 +1372,33 @@ let backtrace_op t =
|
||||
that storage has existed since the process started. Neither carries a
|
||||
permission that can go stale between the asking and the running, because
|
||||
neither was given one. Tagging them stopped-only would refuse work that is
|
||||
sound, which is the other way to lose an answer. *)
|
||||
let run_render_thunk ?(stopped_only = false) t ~tag ~(c : Session.change)
|
||||
: (string, string) result =
|
||||
sound, which is the other way to lose an answer.
|
||||
|
||||
── [at_stop], the third setting, and the only one a write may use ────
|
||||
|
||||
A write through [flan/dev-slot] is the case the paragraph above declares
|
||||
safe and is not. What makes a *read* of a frame slot safe against a resume
|
||||
is that [snap_top] is then empty and the render produces nothing; what makes
|
||||
a write unsafe is that a resume followed by a second stop refills it, and
|
||||
the store lands in the same slot index of a stack the reader never saw.
|
||||
[stopped_only] is blind to that — the program is stopped, which is all it
|
||||
asks. So a write names the generation instead, and the agent compares it
|
||||
against the stop actually in force at the moment it claims the job.
|
||||
|
||||
The wait below is shared: both settings are watched through the same
|
||||
refusal counter, because the agent drops both the same way and the sentence
|
||||
it hands back is the one that says which. *)
|
||||
let run_render_thunk ?(stopped_only = false) ?at_stop t ~tag
|
||||
~(c : Session.change) : (string, string) result =
|
||||
let before = match result t with Some (g, _) -> g | None -> 0L in
|
||||
(* Read *before* the build, not before the wait: the resume this is watching
|
||||
for can land while llc is still running, and the job it kills is this one.
|
||||
[None] when the program cannot say, in which case nothing below compares
|
||||
against it — a missing count is no evidence either way. *)
|
||||
let refused_before = if stopped_only then refusals t else None in
|
||||
let watched = stopped_only || at_stop <> None in
|
||||
let refused_before = if watched then refusals t else None in
|
||||
let resumed () =
|
||||
match (refused_before, if stopped_only then refusals t else None) with
|
||||
match (refused_before, if watched then refusals t else None) with
|
||||
| Some (before, _), Some (now, why) when now > before -> Some why
|
||||
| _ -> None
|
||||
in
|
||||
@ -1367,7 +1407,11 @@ let run_render_thunk ?(stopped_only = false) t ~tag ~(c : Session.change)
|
||||
match build_module c ~debug:t.session.Session.debug ~out with
|
||||
| exception Failure m -> Error m
|
||||
| _ ->
|
||||
(match (if stopped_only then deliver_stopped_only t out else deliver t out) with
|
||||
(match
|
||||
(match at_stop with
|
||||
| Some gen -> deliver_at_stop t ~gen out
|
||||
| None -> if stopped_only then deliver_stopped_only t out else deliver t out)
|
||||
with
|
||||
| exception Unix.Unix_error (e, _, _) ->
|
||||
Error ("cannot reach the program: " ^ Unix.error_message e)
|
||||
| "ok" ->
|
||||
@ -1645,7 +1689,126 @@ let inspect t ~frame ~slot ~path =
|
||||
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 ]))
|
||||
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v;
|
||||
(* Which stop this was read at, so that a write built from
|
||||
what is on the screen can name it and be refused if the
|
||||
program has been round the loop since. Nothing about the
|
||||
read needs it; it is put here because *here* is the only
|
||||
moment at which it is true of what the reader is looking
|
||||
at, and an editor that asked for it separately would be
|
||||
asking a second time about a different instant. *)
|
||||
":at-stop " ^ string_of_int (Option.value ~default:0 (stop_gen t)) ]))
|
||||
|
||||
|
||||
(* [(:op "set" :frame N :slot I :path (...) :edits (...) :at-stop G)] — the
|
||||
inspector's other direction, and [docs/BUILT.md]'s "Writing one of them
|
||||
back" is the argument for having it at all.
|
||||
|
||||
The addressing is [inspect]'s, to the letter: same frame, same slot index,
|
||||
same path steps, same [stopped_frame] fingerprint. A write that addressed
|
||||
values its own way would be free to land somewhere the render above it
|
||||
never showed, which is precisely the stale-slot answer both verbs exist to
|
||||
refuse. [:edits] is a list of (path-from-here, expression) pairs, so one
|
||||
field set from a line of the buffer and a whole edited value committed at
|
||||
once are the same request with a different number of entries.
|
||||
|
||||
── The two stops, and why a write needs both to be the same ─────────
|
||||
|
||||
[:at-stop] is the generation the editor last *read* at. It is compared
|
||||
twice, and the two comparisons catch different things.
|
||||
|
||||
Here, before anything is built: the program has been round its loop and
|
||||
stopped again since the buffer was drawn, so what is on the screen
|
||||
describes storage that has been through a frame of the game. Nothing is
|
||||
wrong with the request except that its author has not seen what they are
|
||||
about to overwrite. It is refused, with the fact, and looking again is the
|
||||
whole of the fix.
|
||||
|
||||
And in the agent, on the game thread, at the moment the module is claimed:
|
||||
everything between this check and that one takes time — a third of a second
|
||||
of llc, a delivery, a wait — and a game that breaks every frame closes that
|
||||
window without trying. That check is the one that makes this sound; this
|
||||
one is the one that makes it *legible*, because a refusal that arrives
|
||||
before the build arrives in a tenth of the time and names the buffer rather
|
||||
than the module.
|
||||
|
||||
A write with no [:at-stop] is taken. The stop is still named to the agent —
|
||||
this end reads it and hands it over — so the window is closed either way;
|
||||
what is skipped is only the "you are looking at an older stop" check, which
|
||||
a caller that never rendered anything has no answer for. *)
|
||||
let set_slot t ~frame ~slot ~path ~edits ~expect_stop =
|
||||
match stopped_frame t ~frame ~what:"a local" with
|
||||
| Error m -> error m
|
||||
| Ok (name, fn) ->
|
||||
(match stop_gen t with
|
||||
| None ->
|
||||
error
|
||||
"cannot ask the program which stop it is at, and a write that cannot \
|
||||
name its stop is one the program has no way to refuse if it has \
|
||||
moved on"
|
||||
| Some 0 ->
|
||||
(* [stopped_frame] passed and this says running, so the program resumed
|
||||
in between. Said as the race it is rather than repeated as the
|
||||
running refusal, which would read as a check that had been made and
|
||||
had not. *)
|
||||
error
|
||||
"the program resumed while this was being asked; there is no frame to \
|
||||
store into any more"
|
||||
| Some gen ->
|
||||
(match expect_stop with
|
||||
| Some want when want <> gen ->
|
||||
error
|
||||
(Printf.sprintf
|
||||
"this was written against stop %d and the program is at stop %d \
|
||||
now: it ran on and stopped again, so what is on the screen is \
|
||||
not what would be overwritten. Look again and re-do the edit"
|
||||
want gen)
|
||||
| _ ->
|
||||
(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 listing's refusal, and the same one [inspect] gives: an
|
||||
unbound slot's entry is null, and storing through it would
|
||||
fault on the game thread of a program that is already
|
||||
stopped. A write faulting there is worse than a read doing
|
||||
it — the program is not coming back from either, but this
|
||||
one was asked to change something. *)
|
||||
error
|
||||
(Printf.sprintf
|
||||
"slot %d of %s was not bound yet at the point the program \
|
||||
stopped; there is nothing at that address to store to"
|
||||
slot name)
|
||||
else
|
||||
(* The rollback [eval_expr] takes and for its reason: checking
|
||||
the stored expressions can instantiate a generic, the copies
|
||||
land in the session before this module has been built or
|
||||
taken, and a copy the session holds and no module defines is
|
||||
a null cell. *)
|
||||
let held = Session.held t.session in
|
||||
let refused msg = Session.restore t.session held; error msg in
|
||||
(match
|
||||
Session.write_slot t.session ~frame ~fn ~slot ~path ~edits
|
||||
with
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } -> refused why
|
||||
| Error why -> refused why
|
||||
| Ok (c, label, ty) ->
|
||||
(match run_render_thunk ~at_stop:gen t ~tag:"s" ~c with
|
||||
| Error m -> refused m
|
||||
| Ok v ->
|
||||
(* The value is what the *program* holds now, rendered by
|
||||
the same thunk that did the storing — not an echo of
|
||||
what was asked for. A buffer redrawn from this shows
|
||||
the program's truth, which is the only reason it is
|
||||
worth redrawing. *)
|
||||
ok
|
||||
[ ":frame " ^ Wire.quote name; ":name " ^ Wire.quote label;
|
||||
":type " ^ Wire.quote ty; ":value " ^ Wire.quote v;
|
||||
":wrote " ^ string_of_int (List.length edits);
|
||||
":at-stop "
|
||||
^ string_of_int
|
||||
(Option.value ~default:0 (stop_gen t)) ])))))
|
||||
|
||||
|
||||
(* ── The allocation registry, read from this end ───────────────────── *)
|
||||
@ -2890,15 +3053,20 @@ let handle t req =
|
||||
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" ->
|
||||
| Some (("inspect" | "set") as verb) ->
|
||||
(match Wire.int_field req "slot" with
|
||||
| None -> error "inspect needs :slot, the index the locals listing gave"
|
||||
| None ->
|
||||
error (verb ^ " 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
|
||||
(* Shared with [set], which addresses the same way down to the step —
|
||||
one reader and not two, because a write that read its path by a
|
||||
second set of rules could reach a value the render above it never
|
||||
showed, which is the whole thing both verbs are built to refuse. *)
|
||||
let path_of what (f : Form.t option) =
|
||||
match f with
|
||||
| Some { Form.v = Form.List l; _ } ->
|
||||
List.fold_left
|
||||
(fun acc (e : Form.t) ->
|
||||
@ -2919,12 +3087,59 @@ let handle t req =
|
||||
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"
|
||||
| Some _ -> Error (what ^ " is a list")
|
||||
| None -> Ok []
|
||||
in
|
||||
(match steps with
|
||||
(match path_of (verb ^ "'s :path") (Wire.field req "path") with
|
||||
| Error m -> error m
|
||||
| Ok path -> inspect t ~frame ~slot ~path))
|
||||
| Ok path ->
|
||||
if verb = "inspect" then inspect t ~frame ~slot ~path
|
||||
else
|
||||
(* [:edits] is a list of [(:path (...) :code "...")], each path
|
||||
relative to [:path] above. A list even for one edit, because
|
||||
the buffer commit and the single field set are the same
|
||||
request and a shorthand for the second would be a second shape
|
||||
to keep in step with the first. *)
|
||||
let edits =
|
||||
match Wire.field req "edits" with
|
||||
| None ->
|
||||
Error
|
||||
"set needs :edits, a list of (:path (...) :code \"...\") — \
|
||||
what to store and where, relative to :path"
|
||||
| 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.List _ ->
|
||||
(match Wire.string_field e "code" with
|
||||
| None ->
|
||||
Error
|
||||
"every :edits entry needs :code, the expression \
|
||||
whose value is to be stored"
|
||||
| Some code ->
|
||||
(match
|
||||
path_of "an :edits entry's :path"
|
||||
(Wire.field e "path")
|
||||
with
|
||||
| Error m -> Error m
|
||||
| Ok steps -> Ok ((steps, code) :: got)))
|
||||
| _ ->
|
||||
Error
|
||||
"every :edits entry is a list: (:path (...) :code \
|
||||
\"...\")"))
|
||||
(Ok []) l
|
||||
|> Result.map List.rev
|
||||
| Some { Form.v = Form.Sym "nil"; _ } -> Ok []
|
||||
| Some _ -> Error "set's :edits is a list"
|
||||
in
|
||||
(match edits with
|
||||
| Error m -> error m
|
||||
| Ok edits ->
|
||||
set_slot t ~frame ~slot ~path ~edits
|
||||
~expect_stop:(Wire.int_field req "at-stop"))))
|
||||
(* 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
|
||||
|
||||
282
lib/session.ml
282
lib/session.ml
@ -1212,6 +1212,288 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
||||
name ^ path_text path,
|
||||
Types.to_string v.Tast.ty)))
|
||||
|
||||
(* ── Writing one of them back ──────────────────────────────────────── *)
|
||||
|
||||
(* The inspector's other direction. SLY sets a value from the inspector and
|
||||
the reason it is worth having here is the same one the read half has: a
|
||||
game keeps its state in a struct somewhere, and the loop between "that
|
||||
field is wrong" and "is it this value that fixes it" is the loop the whole
|
||||
dev story is about. Changing it in the source and reloading answers a
|
||||
different question — it answers what the *next* run does.
|
||||
|
||||
Everything about the addressing is the read half's, deliberately and not
|
||||
for economy: the same root, the same [step_into], the same refusals for a
|
||||
field a type does not have. A write that addressed values its own way would
|
||||
be free to land somewhere the render above it never showed, which is the
|
||||
whole class of bug [render_slot] exists to have closed.
|
||||
|
||||
What is new is two things. The walk has to end at a *place* and not at a
|
||||
value, and the value being stored is an expression somebody typed, so it
|
||||
goes through the checker against the type the walk ended at. Both of those
|
||||
refuse, and both refuse with a sentence rather than by doing something
|
||||
smaller than was asked. *)
|
||||
|
||||
(* The walk's last expression, as somewhere to store.
|
||||
|
||||
[step_into] builds exactly four shapes and three of them are places. That
|
||||
is not a coincidence to be relied on quietly, so the fourth is named here
|
||||
rather than left to fall through to a backend: [emit]'s [place] would
|
||||
[failwith] on it and [x86]'s would not, and two backends disagreeing about
|
||||
what is writable is worse than either answer.
|
||||
|
||||
Refused with the reason, not the layout. "A data type has no place form" is
|
||||
a fact about this compiler; "the tag is what says which case the bytes are"
|
||||
is the fact about the program, and it is the one that says why writing the
|
||||
field alone would be wrong even if the offset were right. *)
|
||||
let place_of (v : Tast.expr) : (Tast.place, string) result =
|
||||
match v.Tast.e with
|
||||
| Tast.Deref p -> Ok (Tast.Pderef p)
|
||||
| Tast.Prim (Tast.At, target :: idx) when idx <> [] ->
|
||||
Ok (Tast.Pindex (target, idx))
|
||||
(* [Ssome] builds this too, and it is the one [Field] that is not writable:
|
||||
an option is a tag and a payload, and storing the payload on its own
|
||||
leaves a [None] holding a value — a value nothing will ever read, because
|
||||
every reader asks the tag first. Set the option itself. *)
|
||||
| Tast.Field (target, _) when (match target.Tast.ty with
|
||||
| Types.Option _ -> true | _ -> false) ->
|
||||
Error
|
||||
"an option's payload is not a place on its own: the tag is what says \
|
||||
whether there is one, and storing past it would leave a None holding a \
|
||||
value nothing will ever look at. Set the option itself"
|
||||
| Tast.Field (target, i) -> Ok (Tast.Pfield (target, i))
|
||||
| Tast.CaseField (_, case, _) ->
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"%s is a field of a data type's case, and which case the bytes are in \
|
||||
is what the tag says — so there is no address to store to that does \
|
||||
not also have to settle the tag. Set the whole value instead"
|
||||
case)
|
||||
| _ ->
|
||||
Error
|
||||
(Printf.sprintf "%s is not somewhere a value can be stored"
|
||||
(Types.to_string v.Tast.ty))
|
||||
|
||||
(* And the types that are places but must not be written through the editor.
|
||||
|
||||
A [Ptr] is the one that matters. Every other refusal here is about a shape;
|
||||
this one is about where the number would come from. A pointer value typed
|
||||
into a prompt is an address this end made up, and the registry's whole
|
||||
argument is that an address is only worth anything with a blessing beside
|
||||
it. Storing one would hand the program a pointer nothing ever blessed, to
|
||||
be dereferenced at a moment nobody chose. The read half refuses to *follow*
|
||||
a pointer for the same reason it is refused here. *)
|
||||
let writable_type (ty : Types.t) : (unit, string) result =
|
||||
match ty with
|
||||
| Types.Ptr _ ->
|
||||
Error
|
||||
(Printf.sprintf
|
||||
"%s is a pointer, and an address typed in here is one this end made \
|
||||
up: nothing blessed it, and the program would dereference it at a \
|
||||
moment nobody chose. The inspector does not follow pointers either"
|
||||
(Types.to_string ty))
|
||||
| _ -> Ok ()
|
||||
|
||||
(* Stores into slot [slot] of frame [frame], one store per [edits] entry,
|
||||
after walking [path].
|
||||
|
||||
A list and not one store, because the buffer this exists for hands back a
|
||||
whole value with several fields changed in it. N modules would be N builds
|
||||
of a third of a second each and N trips past the agent's gate — so a
|
||||
five-field edit would feel broken, and, worse, would be five separate
|
||||
moments for a resume to land between. One module is one job: either every
|
||||
store in it happened at this stop or none of them did.
|
||||
|
||||
Each edit's steps are relative to [path], which is what the buffer is
|
||||
showing. A single field set from a line of the inspector is one edit with
|
||||
one step; a whole value committed is one edit per changed leaf, with the
|
||||
steps that reach it.
|
||||
|
||||
The thunk stores and then *renders*, between the same [dev-begin] and
|
||||
[dev-end] the read half uses, and what comes back is therefore not the
|
||||
editor's idea of what it asked for: it is what is actually there
|
||||
afterwards, read out of the program's own storage by the printer that drew
|
||||
the buffer in the first place.
|
||||
|
||||
[retains] is left at its default on purpose. A module that stores a string
|
||||
literal leaves the program pointing into that module's image, and the
|
||||
default is what keeps the mapping alive for it; claiming otherwise here to
|
||||
save a page would be [(set msg "tuned")] left pointing at unmapped memory,
|
||||
which [emit.ml] spells out where it writes [flan_reload_transient].
|
||||
|
||||
The caller has established the frame, as it has for [render_slot]. *)
|
||||
let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
|
||||
~(edits : (step list * string) list)
|
||||
: (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 if edits = [] then
|
||||
(* Not a no-op quietly performed. A commit that found nothing to write is
|
||||
a fact worth saying, and a module built to store nothing would cost a
|
||||
third of a second to say it. *)
|
||||
Error "there is nothing to store: nothing in this was changed"
|
||||
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 where = name ^ path_text path 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 (where ^ ": " ^ why)
|
||||
| Ok shown ->
|
||||
(* Two passes over the edits, and the split is the point. This one
|
||||
settles every *place* and refuses the whole commit if any of them
|
||||
is not one, before a single expression has been read — so a buffer
|
||||
with one impossible field in it stores nothing rather than storing
|
||||
the fields that happened to sort first. The module's
|
||||
all-or-nothing property would be an empty promise if this end had
|
||||
already half-decided. *)
|
||||
let rec places acc = function
|
||||
| [] -> Ok (List.rev acc)
|
||||
| (steps, code) :: rest ->
|
||||
let at = where ^ path_text steps in
|
||||
(match walk shown steps with
|
||||
| Error why -> Error (at ^ ": " ^ why)
|
||||
| Ok target ->
|
||||
(match writable_type target.Tast.ty with
|
||||
| Error why -> Error (at ^ ": " ^ why)
|
||||
| Ok () ->
|
||||
(match place_of target with
|
||||
| Error why -> Error (at ^ ": " ^ why)
|
||||
| Ok dest ->
|
||||
places ((at, dest, target.Tast.ty, code) :: acc) rest)))
|
||||
in
|
||||
(match places [] edits with
|
||||
| Error why -> Error why
|
||||
| Ok targets ->
|
||||
(* And this one reads and checks the values. Every expression is
|
||||
checked against one [ctx] — [Check.expressions], not one
|
||||
[Check.expression] each — because two expressions checked apart
|
||||
both number their slots from zero, and splicing them into one
|
||||
thunk would have the second one's [let] reading and writing the
|
||||
first one's storage. *)
|
||||
let mark = Check.instance_mark t.env in
|
||||
let wanted =
|
||||
List.map
|
||||
(fun (at, _, tty, code) ->
|
||||
let form =
|
||||
match Reader.read_all ~file:origin code with
|
||||
| [ f ] -> f
|
||||
| [] -> fail loc "nothing to store into %s" at
|
||||
| _ :: f :: _ -> fail f.Form.loc "one value at a time"
|
||||
in
|
||||
(* Expanded with the session's imported macros in front of
|
||||
it, for the reason [eval_expr] gives: the prompt sends
|
||||
one expression with no import in sight, and the session
|
||||
is the only thing holding what the imports brought in. *)
|
||||
(Some tty, Parse.with_imported t.macros (fun () -> Parse.expr form)))
|
||||
targets
|
||||
in
|
||||
(* Checked *against the place's type*, which is the whole reason
|
||||
[Check.expression] grew a [want]. Without it, [7] into an [f32]
|
||||
field arrives as an [i32] and is refused for a mismatch the
|
||||
reader never wrote; with it, it arrives as an [f32], and what
|
||||
stays refused is what really does not fit — in the checker's
|
||||
own words, which is the only place that sentence should ever be
|
||||
written down. *)
|
||||
let values, base, bnames = Check.expressions t.env wanted in
|
||||
let fresh = Check.instances_since t.env mark in
|
||||
let stores =
|
||||
List.map2
|
||||
(fun (_, dest, _, _) value ->
|
||||
{ Tast.e = Tast.Set (dest, value); ty = Types.Unit; loc })
|
||||
targets values
|
||||
in
|
||||
let extra = ref [] and nslots = ref (Array.length base) in
|
||||
let c =
|
||||
{ Render.structs = t.program.Tast.structs;
|
||||
datas = t.program.Tast.datas;
|
||||
unions = t.program.Tast.unions;
|
||||
enums =
|
||||
Hashtbl.fold (fun k v acc -> (k, v) :: acc) t.env.Check.enums [];
|
||||
emit = dev_emitter;
|
||||
ptrs = Some dev_pointers;
|
||||
alloc = (fun ty ->
|
||||
let i = !nslots in
|
||||
incr nslots;
|
||||
extra := ty :: !extra;
|
||||
i) }
|
||||
in
|
||||
(match Render.render c 0 shown with
|
||||
| exception Loc.Error { Loc.dmsg = why; _ } ->
|
||||
Error (where ^ ": " ^ why)
|
||||
| parts ->
|
||||
let nullary n =
|
||||
{ Tast.e = Tast.Call (n, []); ty = Types.Unit; loc }
|
||||
in
|
||||
t.thunks <- t.thunks + 1;
|
||||
let tname = Printf.sprintf "set/%d" t.thunks in
|
||||
let thunk : Tast.fn =
|
||||
{ Tast.name = tname; params = []; ret = Types.Unit;
|
||||
body =
|
||||
stores
|
||||
@ (nullary "flan/dev-begin" :: parts)
|
||||
@ [ nullary "flan/dev-end" ];
|
||||
fdefers = []; fparent = None; floc = loc;
|
||||
slots = Array.append base (Array.of_list (List.rev !extra));
|
||||
(* The stored expressions' own [let]s keep their names; the
|
||||
slots [render] added behind them are the walk's own
|
||||
scratch and have none to keep. *)
|
||||
snames =
|
||||
Array.append bnames
|
||||
(Array.make (List.length !extra) None) }
|
||||
in
|
||||
let program =
|
||||
{ t.program with
|
||||
Tast.fns = t.program.Tast.fns @ fresh @ [ thunk ];
|
||||
externs = t.program.Tast.externs @ externs }
|
||||
in
|
||||
let ir =
|
||||
redefinition t ~call:tname program
|
||||
~fns:
|
||||
(List.map (fun (f : Tast.fn) -> f.Tast.name) fresh
|
||||
@ [ tname ])
|
||||
in
|
||||
(* The instances the values forced stay, the thunk does not —
|
||||
[eval_expr] says why, and the caller takes the same [held]
|
||||
around this that it takes around one. *)
|
||||
t.program <-
|
||||
{ t.program with Tast.fns = t.program.Tast.fns @ fresh };
|
||||
Ok
|
||||
({ ir; x86 = t.x86; names = []; fns = []; installs = true },
|
||||
where, Types.to_string shown.Tast.ty))))
|
||||
|
||||
(* ── The globals a stopped stack reaches ───────────────────────────── *)
|
||||
|
||||
(* The other half of what a break loop can show, and in this language arguably
|
||||
|
||||
262
test/test_dev.ml
262
test/test_dev.ml
@ -1867,6 +1867,241 @@ let () =
|
||||
end
|
||||
end;
|
||||
|
||||
(* ── Writing one of them back ─────────────────────────────────── *)
|
||||
|
||||
(* The inspector's other direction. Its own daemon over the same program,
|
||||
because the block above finishes by redefining [outer] under its own
|
||||
frame on purpose — which is exactly the state in which nothing may be
|
||||
written, so it is no state to write from.
|
||||
|
||||
What is checked here is the three claims the verb makes. The store
|
||||
lands where the render said it would, and the value that comes back is
|
||||
read out of the program afterwards rather than echoed. The expression
|
||||
is checked against the *place's* type, so a literal arrives at the
|
||||
width the place has and a value that does not fit is refused in the
|
||||
checker's own words. And a write that cannot name the stop it was
|
||||
addressed to is refused rather than aimed at whatever stack happens to
|
||||
be there. *)
|
||||
let wsock = tmp "set.sock" and wout = tmp "set.out" in
|
||||
(try Sys.remove wsock with Sys_error _ -> ());
|
||||
let wfd = Unix.openfile wout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
|
||||
let wpid =
|
||||
Unix.create_process flan
|
||||
[| flan; "dev"; "programs/dev-inspect.flan"; "-s"; wsock; "--llvm" |]
|
||||
Unix.stdin wfd Unix.stderr
|
||||
in
|
||||
Unix.close wfd;
|
||||
if not (listening ~pid:wpid wsock) then begin
|
||||
fail "the set daemon %s" !listen_why;
|
||||
(try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ())
|
||||
end
|
||||
else begin
|
||||
let c = connect wsock 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 message r = Option.value ~default:(status r) (Wire.string_field r "message") in
|
||||
let value r = Option.value ~default:"" (Wire.string_field r "value") in
|
||||
if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
|
||||
fail "the set program never stopped"
|
||||
else begin
|
||||
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" (message listing)
|
||||
else begin
|
||||
let slot name =
|
||||
match slot_of listing name with
|
||||
| Some s -> s
|
||||
| None ->
|
||||
fail "the locals listing gave no slot index for %s" name;
|
||||
-1
|
||||
in
|
||||
let set ?(path = "()") name edits =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"set\" :frame 1 :slot %d :path %s :edits %s)"
|
||||
(slot name) path edits)
|
||||
in
|
||||
let inspect ?(path = "()") name =
|
||||
ask
|
||||
(Printf.sprintf "(:op \"inspect\" :frame 1 :slot %d :path %s)"
|
||||
(slot name) path)
|
||||
in
|
||||
(* One field, addressed the way a line of the buffer addresses it:
|
||||
the path reaches the field and the edit stores at it. The reply's
|
||||
value is the field read back, and the inspection after it is the
|
||||
independent one — the same thunk that stored could in principle
|
||||
have rendered the value it was handed rather than the storage. *)
|
||||
let r = set ~path:"(\"x\")" "mark" "((:code \"3.5\"))" in
|
||||
if status r <> "ok" then fail "setting mark.x: %s" (message r)
|
||||
else if value r <> "3.5" then
|
||||
fail "setting mark.x answered %s, not 3.5" (value r);
|
||||
let r = inspect ~path:"(\"x\")" "mark" in
|
||||
if value r <> "3.5" then
|
||||
fail "mark.x reads back as %s after the write, not 3.5" (value r);
|
||||
|
||||
(* And the literal arrives at the *place's* width. Without the
|
||||
expectation flowing into the checker this is the i32 three and
|
||||
"expected f32, found i32"; with it, it is the f32 three, which is
|
||||
the whole of what [Check.expression]'s [want] buys. *)
|
||||
let r = set ~path:"(\"x\")" "mark" "((:code \"3\"))" in
|
||||
if status r <> "ok" then
|
||||
fail "an integer literal into an f32 field: %s" (message r)
|
||||
else if value r <> "3" then
|
||||
fail "the integer three into an f32 field read back as %s" (value r);
|
||||
|
||||
(* Several fields at once, which is the buffer commit: one module,
|
||||
one job, one render of what is there afterwards. *)
|
||||
let r =
|
||||
set "mark" "((:path (\"x\") :code \"9.25\") (:path (\"y\") :code \"8.5\"))"
|
||||
in
|
||||
if status r <> "ok" then fail "setting both fields of mark: %s" (message r)
|
||||
else if value r <> "(Point {.x 9.25 .y 8.5})" then
|
||||
fail "the pair of writes answered %s" (value r);
|
||||
if Wire.int_field r "wrote" <> Some 2 then
|
||||
fail "a two-edit commit did not report writing two";
|
||||
|
||||
(* The whole value, not a field of it. *)
|
||||
let r = set "mark" "((:code \"(Point {.x 0.5 .y 0.25})\"))" in
|
||||
if status r <> "ok" then fail "setting mark whole: %s" (message r)
|
||||
else if value r <> "(Point {.x 0.5 .y 0.25})" then
|
||||
fail "setting mark whole answered %s" (value r);
|
||||
|
||||
(* An element, through the same [at] the render walks. The value is
|
||||
an expression and not a literal, because the point of sending
|
||||
Flan rather than a number is that it is evaluated in the
|
||||
program. *)
|
||||
let r = set "xs" "((:path (1) :code \"(+ 20 5)\"))" in
|
||||
if status r <> "ok" then fail "setting xs[1]: %s" (message r)
|
||||
else if value r <> "[ 10 25 30]" then
|
||||
fail "setting xs[1] answered %s" (value r);
|
||||
|
||||
(* A value that does not fit is refused in the checker's own words,
|
||||
and nothing is stored. *)
|
||||
let r = set ~path:"(\"x\")" "mark" "((:code \"\\\"hello\\\"\"))" in
|
||||
if status r <> "error" then
|
||||
fail "a string stored into an f32 field was accepted"
|
||||
else if not (contains_sub (message r) "expected f32") then
|
||||
fail "the type refusal does not name the type: %s" (message r);
|
||||
let r = inspect "mark" in
|
||||
if value r <> "(Point {.x 0.5 .y 0.25})" then
|
||||
fail "the refused write changed something: %s" (value r);
|
||||
|
||||
(* Two refusals about where, not about what. A data type's field has
|
||||
no address that does not also settle the tag, and an option's
|
||||
payload has none that does not settle whether there is one. Both
|
||||
are readable — the block above reads them — which is the point:
|
||||
what can be shown and what can be stored to are different sets,
|
||||
and each refusal says which it is. *)
|
||||
let r = set ~path:"(\"Shape.Rect.w\")" "s" "((:code \"11\"))" in
|
||||
if status r <> "error" then
|
||||
fail "a data type's case field was written to"
|
||||
else if not (contains_sub (message r) "tag") then
|
||||
fail "the data type refusal does not say why: %s" (message r);
|
||||
let r = set ~path:"(some)" "box" "((:code \"(Point {.x 1.0 .y 1.0})\"))" in
|
||||
if status r <> "error" then
|
||||
fail "an option's payload was written to on its own"
|
||||
else if not (contains_sub (message r) "None") then
|
||||
fail "the option refusal does not say why: %s" (message r);
|
||||
|
||||
(* An edit whose path is impossible refuses the whole commit, so the
|
||||
good edit beside it does not land either. All-or-nothing is what
|
||||
makes one module per commit worth anything. *)
|
||||
let r =
|
||||
set "mark" "((:path (\"x\") :code \"77.0\") (:path (\"z\") :code \"1.0\"))"
|
||||
in
|
||||
if status r <> "error" then fail "a commit with a bad field was taken";
|
||||
let r = inspect ~path:"(\"x\")" "mark" in
|
||||
if value r <> "0.5" then
|
||||
fail "half of a refused commit landed anyway: %s" (value r);
|
||||
|
||||
(* And a write addressed to a stop the program is no longer at is
|
||||
refused before anything is built. The number is one the program
|
||||
cannot be at — generations start at one and count up — so this is
|
||||
the mismatch and not a program that happens to have moved. *)
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf
|
||||
"(:op \"set\" :frame 1 :slot %d :path () :edits ((:code \"(Point {.x 2.0 .y 2.0})\")) :at-stop 999999)"
|
||||
(slot "mark"))
|
||||
in
|
||||
if status r <> "error" then
|
||||
fail "a write against a stop the program is not at was taken"
|
||||
else if not (contains_sub (message r) "Look again") then
|
||||
fail "the stale-stop refusal does not say what to do: %s" (message r);
|
||||
|
||||
(* The stop the reads have been carrying all along is the one the
|
||||
writes have been landing at, which is what makes the editor able
|
||||
to hold it between the two. *)
|
||||
let r = inspect "mark" in
|
||||
(match Wire.int_field r "at-stop" with
|
||||
| Some g when g > 0 ->
|
||||
let r =
|
||||
ask
|
||||
(Printf.sprintf
|
||||
"(:op \"set\" :frame 1 :slot %d :path (\"y\") :edits ((:code \"4.5\")) :at-stop %d)"
|
||||
(slot "mark") g)
|
||||
in
|
||||
if status r <> "ok" then
|
||||
fail "a write naming the stop it read at: %s" (message r)
|
||||
else if value r <> "4.5" then
|
||||
fail "the write naming its stop answered %s" (value r)
|
||||
| _ -> fail "an inspection did not say which stop it read at")
|
||||
end;
|
||||
(* An unbound slot has nothing to store to, and says so rather than
|
||||
faulting on the game thread of a program that is already stopped. *)
|
||||
let r = ask "(:op \"set\" :frame 0 :slot 0 :path () :edits ((:code \"1\")))" in
|
||||
if status r <> "error" then
|
||||
fail "a frame with no slots was written to"
|
||||
end;
|
||||
(* And a running program has no frame to store into. The same refusal
|
||||
the read half gives, through the same check, which is the point of
|
||||
it being the same check. *)
|
||||
let r = ask "(:op \"restart\" :name \"carry-on\")" in
|
||||
if status r <> "ok" then
|
||||
fail "resuming the set program: %s"
|
||||
(Option.value ~default:"" (Wire.string_field r "message"));
|
||||
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
|
||||
fail "the set program never resumed"
|
||||
else begin
|
||||
let r = ask "(:op \"set\" :frame 1 :slot 0 :path () :edits ((:code \"1\")))" in
|
||||
if status r <> "error" then
|
||||
fail "a running program was written to"
|
||||
end;
|
||||
ignore (ask "(:op \"close\")");
|
||||
Unix.close c;
|
||||
if not
|
||||
(await ~ms:5000 (fun () ->
|
||||
match Unix.waitpid [ Unix.WNOHANG ] wpid with
|
||||
| 0, _ -> false
|
||||
| _ -> true
|
||||
| exception Unix.Unix_error _ -> true))
|
||||
then begin
|
||||
(try Unix.kill wpid Sys.sigkill with Unix.Unix_error _ -> ());
|
||||
(try ignore (Unix.waitpid [] wpid) with Unix.Unix_error _ -> ())
|
||||
end
|
||||
end;
|
||||
|
||||
(* ── A pointer the registry knows about ───────────────────────── *)
|
||||
|
||||
(* The inspector's pointer arm, and the address root beside it.
|
||||
@ -4252,6 +4487,33 @@ let () =
|
||||
else if Wire.string_field r "value" <> Some "(Point {.x 1.5 .y 2.5})" then
|
||||
fail "x86 inspect of slot 2 answered %S"
|
||||
(Option.value ~default:"" (Wire.string_field r "value"));
|
||||
(* And the write half of the same root, for the reason this whole block
|
||||
exists: the two backends must answer the same. A store is where they
|
||||
could most easily not — the place forms the walk ends at are lowered
|
||||
by each backend's own [place], and the two disagree about an Option,
|
||||
which is why what may be written is settled in [session.ml] above
|
||||
both of them rather than in either. *)
|
||||
let r =
|
||||
request c
|
||||
"(:op \"set\" :frame 0 :slot 2 :path (\"y\") :edits ((:code \"6.5\")))"
|
||||
in
|
||||
if status r <> "ok" then fail "x86 set: %s" (said r)
|
||||
else if Wire.string_field r "value" <> Some "6.5" then
|
||||
fail "x86 set of p.y answered %S"
|
||||
(Option.value ~default:"" (Wire.string_field r "value"));
|
||||
let r = request c "(:op \"inspect\" :frame 0 :slot 2)" in
|
||||
if Wire.string_field r "value" <> Some "(Point {.x 1.5 .y 6.5})" then
|
||||
fail "x86: the store did not land where the render says it did: %S"
|
||||
(Option.value ~default:"" (Wire.string_field r "value"));
|
||||
(* A refusal that comes from above both backends reads the same here
|
||||
as it does there, which is the claim rather than the refusal. *)
|
||||
let r =
|
||||
request c
|
||||
"(:op \"set\" :frame 0 :slot 2 :path (\"y\") :edits ((:code \"\\\"no\\\"\")))"
|
||||
in
|
||||
if status r <> "error" || not (contains_sub (said r) "expected f32") then
|
||||
fail "x86: a value of the wrong type was not refused by the checker: %s"
|
||||
(said r);
|
||||
(* And the globals, which are not in the frame at all -- they are found
|
||||
through the same descriptor's fingerprint, and a frame whose
|
||||
[refsig] disagreed with what the daemon recomputes would refuse
|
||||
|
||||
103
vendor/agent/flan_agent.c
vendored
103
vendor/agent/flan_agent.c
vendored
@ -176,12 +176,41 @@ int flan_dev_reg_overflowed(void);
|
||||
* [handle] is set only for a module that declared itself transient — one that
|
||||
* ran a thunk and left nothing behind. Everything else is kept mapped forever:
|
||||
* a cell holds an address inside a module's text, and unloading it would leave
|
||||
* every call site pointing at unmapped memory. */
|
||||
* every call site pointing at unmapped memory.
|
||||
*
|
||||
* ── [at_stop], and why [stopped_only] is not enough for a *write* ──────
|
||||
*
|
||||
* [stopped_only] asks "is the program stopped", and for a read that is the
|
||||
* whole question: the worst a render can do against the wrong stop is print
|
||||
* something that was true of a different frame, and it is printed into a
|
||||
* buffer nobody stores anywhere.
|
||||
*
|
||||
* A write is not that. A module that *stores* into frame N slot I reaches its
|
||||
* target through [flan_agent_frame_slot], which reads whatever snapshot is on
|
||||
* top at the moment the store runs. Resume and stop again inside the build
|
||||
* window — ~300ms of llc, and a game loop that breaks every frame closes that
|
||||
* window without trying — and [depth] is above zero again, the job is
|
||||
* accepted, and the store lands in frame N of a *different* stack. Not a
|
||||
* fault: a plausible shape, in the wrong place, silently.
|
||||
*
|
||||
* So a write names the stop it was addressed against. [snap_push] mints a
|
||||
* generation that is monotone and never reused, precisely so that "resumed
|
||||
* and stopped again" is distinguishable from "still the same stop" — the
|
||||
* restart machinery already leans on it for the same reason. [at_stop] is
|
||||
* that number, asked for by the daemon through [stop] and handed back on the
|
||||
* request, and checked here, on the game thread, at the moment the job is
|
||||
* claimed. Zero means the job does not care, which is every read.
|
||||
*
|
||||
* It sits beside [stopped_only] rather than subsuming it because they are two
|
||||
* different questions and one of them has no answer to give: a render rooted
|
||||
* at a raw address wants "stopped at all" and has no stop to name, since the
|
||||
* registry that blessed the address is not a stack. */
|
||||
typedef struct {
|
||||
install_fn install;
|
||||
call_fn call;
|
||||
void *handle;
|
||||
int stopped_only;
|
||||
int32_t at_stop;
|
||||
} job;
|
||||
|
||||
/* Said once, in one place, and shipped to the daemon over [refusals] rather
|
||||
@ -193,6 +222,24 @@ static const char *RESUMED =
|
||||
"the program resumed while this inspection was being built — stop it again "
|
||||
"and re-ask";
|
||||
|
||||
/* The other way a job's stop can stop being the job's stop, and it needs its
|
||||
* own sentence because the fix is a different one. Above, the program is
|
||||
* running and the reader has to stop it. Here it *is* stopped — at a stop
|
||||
* that came after the one the request named — so stopping it again would do
|
||||
* nothing, and what is wanted is to look at what is there now. A write built
|
||||
* against a render of the old stop would otherwise land in storage the reader
|
||||
* never saw. */
|
||||
static const char *RESTOPPED =
|
||||
"the program was resumed and stopped again while this was being built, so it "
|
||||
"is no longer at the stop this was addressed to — look again and re-ask";
|
||||
|
||||
/* Which of the two the last drop was. One counter and two sentences rather
|
||||
* than two counters, because the daemon's question is "did a drop happen
|
||||
* between these two reads" and that is a count; the text is only what it says
|
||||
* afterwards. Last writer wins, which is the residual [refused_while_running]
|
||||
* already documents below for two inspections in flight at once. */
|
||||
static const char *_Atomic refused_why = NULL;
|
||||
|
||||
/* How many stopped-only jobs have been dropped, ever. A count and not a flag:
|
||||
* the daemon reads it before it delivers and again while it waits, and what it
|
||||
* wants to know is whether one happened *in between*, which a flag somebody
|
||||
@ -734,10 +781,25 @@ int32_t flan_agent_poll(void) {
|
||||
* nothing was installed, and [n] is what a caller polls to find out that
|
||||
* something was. */
|
||||
if (j.stopped_only && atomic_load(&depth) <= 0) {
|
||||
atomic_store(&refused_why, RESUMED);
|
||||
atomic_fetch_add(&refused_while_running, 1);
|
||||
if (j.handle != NULL) { dlclose(j.handle); }
|
||||
continue;
|
||||
}
|
||||
/* And the same gate for a job that named a stop. Read from [snap_top] and
|
||||
* not from [snap_gen], which is the counter and not the stop: after a
|
||||
* resume [snap_gen] still holds the generation of the break that ended,
|
||||
* so comparing against it would accept a job whose stop is over. The
|
||||
* snapshot on top is the stop that is in force. */
|
||||
if (j.at_stop != 0) {
|
||||
snapshot *s = snap_top();
|
||||
if (s == NULL || s->gen != j.at_stop) {
|
||||
atomic_store(&refused_why, s == NULL ? RESUMED : RESTOPPED);
|
||||
atomic_fetch_add(&refused_while_running, 1);
|
||||
if (j.handle != NULL) { dlclose(j.handle); }
|
||||
continue;
|
||||
}
|
||||
}
|
||||
if (j.install != NULL) { j.install(); n++; }
|
||||
/* After the install, so a thunk sees the bodies its own module published.
|
||||
*
|
||||
@ -1199,10 +1261,28 @@ static void handle_line(char *line, sink *o) {
|
||||
int k = snprintf(hdr, sizeof hdr, "%llu\n",
|
||||
(unsigned long long)atomic_load(&refused_while_running));
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
reply(o, RESUMED);
|
||||
const char *why = atomic_load(&refused_why);
|
||||
reply(o, why != NULL ? why : RESUMED);
|
||||
reply(o, "\n");
|
||||
return;
|
||||
}
|
||||
/* Which stop the program is at, as a number that is never reused and never
|
||||
* zero — zero being "it is not stopped". [status] cannot answer this: two
|
||||
* stops at the same [(error (Boom …))] are both "stopped Boom", and telling
|
||||
* them apart is the whole question a write has to ask before it stores into
|
||||
* a frame somebody rendered a moment ago.
|
||||
*
|
||||
* Its own verb rather than a field on [status] or [backtrace], because both
|
||||
* of those have readers in flight and a reply format is a thing two ends
|
||||
* agree on. Answered while running as well, for [status]'s reason: an
|
||||
* editor polls this without knowing the state already. */
|
||||
if (strcmp(line, "stop") == 0) {
|
||||
snapshot *s = (atomic_load(&depth) > 0) ? snap_top() : NULL;
|
||||
char hdr[32];
|
||||
int k = snprintf(hdr, sizeof hdr, "%d\n", s == NULL ? 0 : s->gen);
|
||||
if (k > 0) emit(o, hdr, (size_t)k);
|
||||
return;
|
||||
}
|
||||
if (strcmp(line, "result") == 0) {
|
||||
uint64_t gen = 0, len = 0;
|
||||
uint64_t cap = flan_dev_result_cap();
|
||||
@ -1404,6 +1484,23 @@ static void handle_line(char *line, sink *o) {
|
||||
stopped_only = 1;
|
||||
line += 13;
|
||||
}
|
||||
/* [at-stop N ] travels the same way and for the same reason, and it goes
|
||||
* after [stopped-only ] so that a module which is both spells it
|
||||
* "stopped-only at-stop 7 /path". Nothing sends both today — naming a stop
|
||||
* already implies one — but the two prefixes answer different questions and
|
||||
* a parser that made them exclusive would have to be revisited the first
|
||||
* time something wants the pair. The number is parsed here rather than
|
||||
* trusted: a path beginning "at-stop " with no number after it is a path,
|
||||
* and treating it as a malformed prefix would lose the module. */
|
||||
int32_t at_stop = 0;
|
||||
if (strncmp(line, "at-stop ", 8) == 0) {
|
||||
char *end = NULL;
|
||||
long n = strtol(line + 8, &end, 10);
|
||||
if (end != line + 8 && *end == ' ' && n > 0 && n <= 0x7fffffff) {
|
||||
at_stop = (int32_t)n;
|
||||
line = end + 1;
|
||||
}
|
||||
}
|
||||
/* Before the dlopen, not after it: a module there is no room to queue is
|
||||
* one there is no point relocating, and refusing here means no handle is
|
||||
* taken for it at all. Only one producer runs at a time, so room seen now is
|
||||
@ -1455,7 +1552,7 @@ static void handle_line(char *line, sink *o) {
|
||||
* is the failure being fixed. */
|
||||
if (!publish((job){ .install = f, .call = c,
|
||||
.handle = transient == NULL ? NULL : h,
|
||||
.stopped_only = stopped_only }))
|
||||
.stopped_only = stopped_only, .at_stop = at_stop }))
|
||||
fprintf(stderr, "flan: reload queue full after it was checked\n");
|
||||
return;
|
||||
}
|
||||
|
||||
Loading…
x
Reference in New Issue
Block a user