diff --git a/docs/BUILT.md b/docs/BUILT.md index 4b15117..3dad02a 100644 --- a/docs/BUILT.md +++ b/docs/BUILT.md @@ -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 diff --git a/emacs/MANUAL.md b/emacs/MANUAL.md index 742d822..5235178 100644 --- a/emacs/MANUAL.md +++ b/emacs/MANUAL.md @@ -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.** ``, ``, 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 diff --git a/emacs/flan-inspect.el b/emacs/flan-inspect.el index afcb736..2587989 100644 --- a/emacs/flan-inspect.el +++ b/emacs/flan-inspect.el @@ -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. `' and `' 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'.") diff --git a/emacs/test-flan-cider.el b/emacs/test-flan-cider.el index dcc18a1..0e613c7 100644 --- a/emacs/test-flan-cider.el +++ b/emacs/test-flan-cider.el @@ -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 })") + (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") diff --git a/emacs/test-flan.el b/emacs/test-flan.el index 128a913..7a009a9 100644 --- a/emacs/test-flan.el +++ b/emacs/test-flan.el @@ -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 diff --git a/lib/check.ml b/lib/check.ml index 59f8604..61ce1f5 100644 --- a/lib/check.ml +++ b/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 = "" } 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, diff --git a/lib/dev.ml b/lib/dev.ml index 34baa6e..3904488 100644 --- a/lib/dev.ml +++ b/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 diff --git a/lib/session.ml b/lib/session.ml index a119ffe..8fe6e1c 100644 --- a/lib/session.ml +++ b/lib/session.ml @@ -1212,6 +1212,288 @@ let render_slot ?(origin = "") 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 = "") 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 diff --git a/test/test_dev.ml b/test/test_dev.ml index a9fccd1..79cc888 100644 --- a/test/test_dev.ml +++ b/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 diff --git a/vendor/agent/flan_agent.c b/vendor/agent/flan_agent.c index 01a00f5..e376ad1 100644 --- a/vendor/agent/flan_agent.c +++ b/vendor/agent/flan_agent.c @@ -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; }