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

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

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-20 22:59:22 +07:00
commit 4a2c04bcc7
16 changed files with 1255 additions and 174 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

63
FIX.org
View File

@ -4047,3 +4047,66 @@ so an unprintable second argument underlines that argument, not the form —
pinned in test_flan.ml. Output pinned by test/programs/println-variadic.flan
and its acceptance row (LLVM), spacing exact, "|" markers so a leaked
trailing space is a visible red.
* Break-loop display pass, 2026-09-20
Off a dogfooding session that hit BoundsError: "can I get a better error
message? I don't see a precise line number anywhere, what is s1 and s3? the
condition field messages are weird, the continue message is weird too, do a
full pass and reword things."
** Built
- Condition values render. The break loop stashes the condition pointer in
the agent's snapshot (it used to discard it); [flan_agent_condition] hands
it back on the stopped thread; a new daemon op =condition= builds a render
thunk over the struct's fields — render_locals pointed at the condition —
and delivers it at-stop, so resume-and-restop cannot read the old type over
the new pointer. The buffer's headline now reads the fields inline:
"BoundsError — low 648, high 648, length 100", nothing hardcoding any one
condition. Works for user =error= conditions and for the trap-built ones,
on both backends.
- Precise location. The bounds/slice/arith trap sites publish their loc
around the break-hook call ([flan_break_site] in flan_rt.c), the snapshot
copies it, agent verb =site= serves it, and =break= answers =:site= plus
the line's text as =:source=. The buffer draws "at file:line:col" under the
headline with the source line and a caret at the column.
- Compiler temps are hidden from the locals listing rather than refused as
=s4=; a shadowing rebind strips its =~N= except when the outer binding is
on the same list, where both keep their raw spelling ([Session.shown_names]).
- Rewording. Every bracketed implementation note is gone from the buffer
(they were implemented anyway); the refusal table is one short sentence per
section; the abort line says what abort does ("end the program here; the
dev session ends with it" — true: abort is _exit(134) and merged flan dev
is that process). A shadowed restart is now *takeable*: the buffer sends
=restart-at= with the index for every choice, name as receipt, so the
shadowed line just says "same name as N; taken by its number".
- A u8 shows its character where a person is inspecting: =97 (\a)= in a
frame's locals, in inspect, and in a condition's fields. Ruled by the
author: =[u8]= already renders as text, so a lone byte reading =97= was an
asymmetry exactly where someone is reading rather than computing.
=println= is untouched — a u8 is a number and that path is the program
talking. The switch is =Render.pointers=, which already marks the
inspecting side and which =println= passes as =None=, so the printing path
cannot acquire this by accident. Spellings answer to lib/reader.ml's
=read_byte= (the five named ones, and any single non-delimiter character),
so what is shown could be typed back; a byte with no spelling shows the
number alone rather than an invented escape or a raw control byte. The
table is in flan_dev.c as one call: the value is only known at run time,
and a chain over ninety-odd comparisons per rendered byte would have been
the walk paying for its own shape. Pinned on both backends with a
printable, a named and an unprintable byte, and =println (u8 97)= pinned
bare in the acceptance table — the existing 255 could not tell the two
apart.
** Deferred, ready to build
- Restart locations. The =%restart= frame is mirrored across emit.ml, x86.ml
and flan_rt.c (fields 0-9 today), so giving =continue= a file:line:col
means: two fields (loc ptr + i64 len, the module's own string, like the
shadow frame's), stores emitted at emit_restart_case in both backends, a
[flan_restart_loc] accessor, the agent snapshot copying it beside each
name, =restarts= growing a loc column, and the buffer printing
"0: [continue] sand.flan:52". Cross-backend ABI change; do it as one lane,
not as a rider.
- A site for user =error= calls. flan_error has no loc parameter; threading
one through means both backends' call emission. Same lane as above if the
frame is being touched anyway.

303
emacs/flan-cnr.el
View File

@ -38,14 +38,14 @@
;;
;; `show-restarts' also numbers them and brackets the name — and omits the
;; bracket on a name already used further in. That device is not decoration.
;; A restart is invoked by name; the name resolves to the innermost frame
;; offering it; so a second frame offering `retry' is real, is on the list, and
;; **cannot be chosen by name**. spec-conditions.md §4 says exactly this about
;; Flan ("takes the first frame offering the name"), and `flan_find_restart'
;; does exactly this in the runtime. Today's `completing-read' hides it: the
;; list has `retry' in it twice, picking either sends the string "retry", and
;; the inner one runs. Here the shadowed entry is drawn and refused, by name,
;; with the reason.
;; A restart *typed by name* resolves to the innermost frame offering it, so a
;; second frame offering `retry' is real, is on the list, and cannot be named
;; from a prompt — spec-conditions.md §4, and `flan_find_restart' in the
;; runtime. Today's `completing-read' hides it: the list has `retry' twice,
;; picking either sends the string "retry", and the inner one runs. Here
;; every choice goes out by *number* (`restart-at', with the name as a
;; receipt), so a shadowed entry is drawn without its bracket and is still
;; takeable — the bracket says only what a typed name would reach.
;;
;; **CIDER's stacktrace buffer** answers *how it should behave*: frames that
;; expand in place, TAB to fold, everything reachable from the keyboard,
@ -84,25 +84,19 @@ from fixtures, and so `flan.el' is named in one place.")
;;; What is not available, and why
;; Said in one table rather than at each use, because these are claims about
;; the protocol and they should be revisable in one place when a verb lands.
;; Each carries its status in the same three words the design uses.
;; Said in one table rather than at each use, so a section's reason is
;; revisable in one place. One short sentence each: these print in the
;; buffer, and the buffer is not the place for design notes.
(defconst flan-cnr-unavailable
'((layout
. "the daemon could not resolve this condition's name to a struct [the `layout' op answers out of `Tast.structs' and needs a *qualified* name. A package qualifies what it declares, so two packages' `Missing' are two names and neither is `Missing'; the daemon refuses a bare one and lists what it could have meant rather than picking. A name it cannot place at all is a program built from source this daemon did not compile]")
(value
. "the break loop is handed the condition as an opaque pointer, and `break_loop' currently discards it; nothing at run time can render a value whose type it does not know [needs an agent verb: `condition', to stash and hand back the pointer, and a daemon-built render thunk aimed at it]")
(site
. "a restart frame carries its name and the hash matching uses, and no location [needs a location in the restart frame, which the compiler must emit]")
(params
. "restart arguments are checked at run time against a frame that does not record its arity [needs a field in the restart frame]")
. "no struct has this name; a trap's name has no fields behind it")
(stack
. "the program is running. A backtrace is the game thread's frame chain and it is changing while it runs, so the daemon refuses to take one [not a missing feature: ask again once it has stopped]")
. "the program is running; ask again once it stops")
(locals
. "this frame has no named locals the daemon can read. A slot the compiler invented is refused by name rather than shown as `s4', and a slot whose binding had not run when the error happened has no address yet [both are refusals with reasons, not gaps — the frame's own line says how many slots it has]")
. "this frame has no named locals")
(globals
. "no frame on this stack references a global [not a gap: the section is the *union of what the frames reach*, not a listing of everything the program has, so an empty one means the state this stack is working on is all in its locals]"))
. "no frame on this stack reads a global; its state is all in its locals"))
"Why a section of this buffer is empty, by name.")
(defun flan-cnr--why (key)
@ -149,6 +143,56 @@ nothing in the compiler knows a breakpoint from an error and this buffer is the
first place that can tell the difference. Named here rather than spelled at
its use, because it is a fact about the prelude.")
(defun flan-cnr--headline-fields (fields)
"The condition's own numbers, folded into the headline.
FIELDS is the fields list; the result is \"low 9, high 9, length 4\" over the
fields whose values arrived and are short enough to read inline, or nil.
Generic on purpose: the fields are the condition's own, so BoundsError reads
as its numbers and every other condition reads as its own."
(let ((short (seq-filter (lambda (f)
(and (nth 2 f) (<= (length (nth 2 f)) 24)
(not (string-match-p "\n" (nth 2 f)))))
fields)))
(when short
(concat (mapconcat (lambda (f) (format "%s %s" (nth 0 f) (nth 2 f)))
(seq-take short 4) ", ")
;; A headline is one line, so a wide condition is cut — and
;; says it is, because a silently short list reads as the whole
;; of what the condition carries. The section below has all of
;; them.
(when (> (length short) 4) ", …")))))
(defun flan-cnr--site-line-col (site)
"The (LINE . COL) a SITE string names, or nil."
(when (and site (string-match ":\\([0-9]+\\):\\([0-9]+\\)\\'" site))
(cons (string-to-number (match-string 1 site))
(string-to-number (match-string 2 site)))))
(defun flan-cnr--insert-site (state)
"Where the expression that trapped is written, with the line and a caret.
The frame lines below say where each call was; this is the only record of the
indexing or the division itself, so it sits directly under the headline."
(let ((site (plist-get state :site)))
(when site
(insert (propertize (format "at %s\n" site) 'face 'shadow))
(let ((source (plist-get state :source))
(lc (flan-cnr--site-line-col site)))
(when (and source lc)
(let* ((prefix (format "%4d| " (car lc)))
(col (max 0 (1- (cdr lc))))
;; The pad copies the source's own leading whitespace rather
;; than assuming spaces: a tab-indented line puts the caret
;; a tab-stop off under any other rule, and a caret that
;; points at the wrong column is worse than none.
(pad (concat (make-string (length prefix) ?\s)
(mapconcat
(lambda (ch) (if (eq ch ?\t) "\t" " "))
(string-to-list (substring source 0
(min col (length source))))
""))))
(insert "\n" (propertize prefix 'face 'shadow) source "\n")
(insert pad (propertize "^" 'face 'error) "\n")))))))
(defun flan-cnr--insert-condition (state)
(let* ((name (or (plist-get state :condition) "a condition"))
;; A breakpoint is a stop, not a failure. Everything underneath is
@ -157,43 +201,67 @@ its use, because it is a fact about the prelude.")
;; only thing that can be wrong here is the word for it. Calling a
;; breakpoint unhandled would be a small lie told at the top of the
;; one buffer that exists to say what happened.
(paused (equal name flan-cnr-breakpoint)))
(paused (equal name flan-cnr-breakpoint))
(numbers (flan-cnr--headline-fields (plist-get state :fields))))
(insert (propertize name 'face (if paused 'warning 'error)))
(when numbers (insert " — " numbers))
(insert "\n")
(insert (propertize
(if paused
" — a breakpoint; stopped where (pause) was called, nothing unwound\n"
" — unhandled; stopped on the frame that erred, nothing unwound\n")
'face 'shadow)))
"stopped at (pause); nothing has been unwound\n"
"unhandled; stopped where it erred, nothing unwound\n")
'face 'shadow))
(flan-cnr--insert-site state))
(insert "\n")
(flan-cnr--section "Condition fields:")
;; Two refusals, not one, and keeping them apart is the point. The *shape* of
;; a condition — its field names and their types — is in `Tast.structs',
;; which the daemon holds because it owns the build; no running program is
;; involved in answering it. Only the *values* need the pointer the break
;; loop was handed. So a field can be named and typed while its value is
;; refused, which is strictly more than saying nothing, and it is what tells
;; you whether the :path you were about to blame is even a field of this
;; condition.
(let ((fields (plist-get state :fields)))
;; The shape and the values are two answers. The shape — names and types —
;; is the daemon's own, out of the build it holds; the values are read out
;; of the stopped program by a thunk the daemon builds. So a field can be
;; named and typed while its value is missing, and the row says why in one
;; sentence rather than being left off.
(let ((fields (plist-get state :fields))
(why (plist-get state :fields-why)))
(if (null fields)
(insert (flan-cnr--unavailable 'layout))
(let ((w (apply #'max 4 (mapcar (lambda (f) (length (nth 0 f))) fields)))
(tw (apply #'max 4 (mapcar (lambda (f) (length (or (nth 1 f) ""))) fields))))
(dolist (f fields)
(let ((start (point))
(name (nth 0 f)) (type (or (nth 1 f) "?")) (value (nth 2 f)))
(insert (format " :%s%s %s%s " name
(make-string (- w (length name)) ?\s)
(propertize type 'face 'font-lock-type-face)
(make-string (- tw (length type)) ?\s)))
(insert (if value value
(propertize (concat "value not available — "
(flan-cnr--why 'value))
'face 'font-lock-comment-face))
"\n")
(add-text-properties start (point)
(list 'flan-cnr-inspect nil
'mouse-face 'highlight)))))))
;; Three different empties, and only one of them is a refusal. A
;; condition that *declares* no fields is an ordinary thing — Pause is
;; one — and saying "no struct has this name" about it would be
;; false. `:fields-empty' is the daemon's own count, so this end is
;; not inferring it from a list that is also empty when the read
;; failed.
(insert (propertize
(cond
((plist-get state :fields-empty)
" this condition has no fields\n")
(t (concat " not available — "
(or why (flan-cnr--why 'layout)) "\n")))
'face 'font-lock-comment-face))
(progn
;; The section-wide reason, once, above the rows — repeating it per
;; field was the noise the rewording pass was asked to cut.
(when why
(insert (propertize (concat " not read — " why "\n")
'face 'font-lock-comment-face)))
(let ((w (apply #'max 4 (mapcar (lambda (f) (length (nth 0 f))) fields)))
(tw (apply #'max 4 (mapcar (lambda (f) (length (or (nth 1 f) ""))) fields))))
(dolist (f fields)
(let ((start (point))
(name (nth 0 f)) (type (or (nth 1 f) "?")) (value (nth 2 f)))
(insert (format " :%s%s %s%s " name
(make-string (- w (length name)) ?\s)
(propertize type 'face 'font-lock-type-face)
(make-string (- tw (length type)) ?\s)))
(insert (if value value
;; A field-specific reason — no printer for its type —
;; is that row's own; a bare "not read" defers to the
;; sentence above.
(propertize
(if (nth 3 f) (concat "not read — " (nth 3 f))
"not read")
'face 'font-lock-comment-face))
"\n")
(add-text-properties start (point)
(list 'flan-cnr-inspect nil
'mouse-face 'highlight))))))))
(insert "\n"))
(defun flan-cnr--insert-restarts (state)
@ -209,21 +277,23 @@ its use, because it is a fact about the prelude.")
(let* ((i (nth 0 r)) (name (nth 1 r)) (owner (nth 2 r))
(start (point)))
;; SBCL's bracket: it is there when the name reaches this frame and
;; gone when it does not.
;; gone when it does not. A shadowed entry is still takeable — the
;; choice goes out by number, not by name — so the missing bracket
;; says only that typing the name at a prompt would reach the
;; inner one.
(insert (format " %2d: %s%s%s " i
(if owner " " "[")
(propertize name 'face
(if owner 'shadow 'font-lock-keyword-face))
(if owner " " "]")))
(insert (make-string (- w (length name)) ?\s))
(if owner
(insert (propertize
(format "shadowed by %d — `restart' resolves a name to the innermost frame offering it, so this one cannot be taken by name [needs an agent verb: `restart-at INDEX']" owner)
'face 'font-lock-comment-face))
(insert (propertize (flan-cnr--why 'site) 'face 'shadow)))
(when owner
(insert (propertize
(format "same name as %d; taken by its number" owner)
'face 'shadow)))
(insert "\n")
(add-text-properties start (point)
(list 'flan-cnr-restart (if owner nil name)
(list 'flan-cnr-restart name
'flan-cnr-shadowed owner
'flan-cnr-index i
'mouse-face 'highlight))))))
@ -232,7 +302,7 @@ its use, because it is a fact about the prelude.")
(let ((start (point)))
(insert (format " %2d: [%s] " (length rows)
(propertize "abort" 'face 'error)))
(insert (propertize "let the program die where it stopped; this ends `flan dev' too\n"
(insert (propertize "end the program here; the dev session ends with it\n"
'face 'shadow))
(add-text-properties start (point)
(list 'flan-cnr-abort t 'mouse-face 'highlight))))
@ -375,25 +445,26 @@ puts the likely culprit on top."
;;; Commands
(defun flan-cnr--refuse-shadowed ()
(user-error
"flan: restart %d is shadowed by %d; `restart' takes a name, and this name reaches the inner frame. Taking this one needs an index verb the daemon does not have"
(get-text-property (point) 'flan-cnr-index)
(get-text-property (point) 'flan-cnr-shadowed)))
(defun flan-cnr-take ()
"Take the restart on this line."
(interactive)
(cond
((get-text-property (point) 'flan-cnr-abort) (flan-cnr-abort))
((get-text-property (point) 'flan-cnr-shadowed) (flan-cnr--refuse-shadowed))
((get-text-property (point) 'flan-cnr-restart)
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-restart)))
(flan-cnr--invoke (get-text-property (point) 'flan-cnr-index)
(get-text-property (point) 'flan-cnr-restart)))
((get-text-property (point) 'flan-cnr-frame) (flan-cnr-toggle-frame))
(t (user-error "flan: nothing to take on this line"))))
(defun flan-cnr--invoke (name)
(let ((r (funcall flan-cnr-request-function (list :op "restart" :name name))))
(defun flan-cnr--invoke (index name)
"Take restart INDEX, named NAME.
By index, because the index is the identity — two frames can offer `retry'
and only one of them is the one on this line. The name rides along as a
receipt: the daemon checks it against what the program has at that index and
refuses if the two have drifted apart, so a stale buffer cannot take a
different restart than the one it showed."
(let ((r (funcall flan-cnr-request-function
(list :op "restart-at" :index index :name name))))
(if (equal (plist-get r :status) "ok")
;; Accepted, not resumed — the choice is validated against the stopped
;; stack and taken when that thread next comes round its loop. So the
@ -555,9 +626,10 @@ anyone who would rather TAB always moved."
(defun flan-cnr-state-from-reply (reply &optional fields stack globals)
"The buffer's state, out of a `break' REPLY.
FIELDS is the condition's layout, if it was asked for and answered — a list of
(NAME TYPE VALUE), where VALUE is nil because no running program was consulted
to get it.
FIELDS is what `flan-cnr-condition-fields' returned — rows of
(NAME TYPE VALUE), with VALUE nil where it could not be read, and the
one-sentence reason beside them — or the bare rows, which is how the
fixture-driven tests pass them.
GLOBALS is what `flan-cnr-globals' returned, or nil.
@ -569,7 +641,20 @@ Takes the layout rather than fetching it, so this stays a function from data to
data and the fixture-driven tests can drive it without a socket."
(list :condition (plist-get reply :condition)
:restarts (plist-get reply :restarts)
:fields fields
;; Where the expression that trapped is written, and that line's text.
;; `break' carries both when the stop has a site; a user (error ...)
;; has none, and then the headline simply has no line to point at.
:site (plist-get reply :site)
:source (plist-get reply :source)
;; FIELDS is either the rows themselves — the fixtures' shape — or
;; `flan-cnr-condition-fields''s plist of rows plus the one-sentence
;; reason the values half is missing.
:fields (if (keywordp (car-safe fields))
(plist-get fields :fields)
fields)
:fields-why (and (keywordp (car-safe fields)) (plist-get fields :why))
:fields-empty (and (keywordp (car-safe fields))
(plist-get fields :empty))
;; STACK is passed in rather than fetched, for the same reason FIELDS
;; is: this stays a function from data to data, so the fixture tests
;; drive it with no socket. Nil is still a legitimate answer — the
@ -596,18 +681,61 @@ qualified struct name the compiler put into the error: `Emit' takes it from
up by the same name. So it resolves without anything here knowing what package
it came from.
A refusal is not an error here: nil means the layout section draws the reason
it is empty, which is the degradation the buffer is already built for."
(when (and type (not (string-empty-p type)))
(let ((r (funcall flan-cnr-request-function (list :op "layout" :type type))))
(when (equal (plist-get r :status) "ok")
(mapcar (lambda (f)
;; The value is nil, and that is the honest half: the shape
;; of a condition is a fact about the build, its contents
;; are a fact about the stopped frame, and only the first is
;; knowable today.
(list (nth 0 f) (nth 1 f) nil))
(plist-get r :fields))))))
A refusal is not an error here: `:fields' nil means the section draws the
reason it is empty, which is the degradation the buffer is already built for,
and `:why' carries the daemon's own sentence for it — a bare name it will not
guess between two packages reads better than anything this end could invent.
Returns (:fields ROWS :why WHY), the shape `flan-cnr-condition-fields'
returns, so the two are interchangeable where the buffer takes either."
(let ((r (and type (not (string-empty-p type))
(funcall flan-cnr-request-function
(list :op "layout" :type type)))))
(if (equal (plist-get r :status) "ok")
(list :fields
(mapcar (lambda (f)
;; The value is nil: the shape of a condition is a
;; fact about the build, its contents are a fact about
;; the stopped frame, and this op only ever answers
;; the first.
(list (nth 0 f) (nth 1 f) nil))
(plist-get r :fields))
:why "the stop's value was not readable")
(list :fields nil :why (plist-get r :message)))))
(defun flan-cnr-condition-fields (type)
"The stopped condition's fields with their values, or what stands in.
Asks `condition' first — the daemon builds a thunk that renders the fields at
the pointer the break loop stashed — and falls back to `layout' when that is
refused, so the names and the types still show with one sentence saying why
the values do not. Returns (:fields ROWS :why WHY): ROWS are
(NAME TYPE VALUE [WHY]) with VALUE nil where it was not read, and WHY is the
section-wide reason, nil when the values arrived."
(let ((r (funcall flan-cnr-request-function '(:op "condition"))))
(if (equal (plist-get r :status) "ok")
(list :fields
(append
(mapcar (lambda (f) (list (nth 0 f) (nth 1 f) (nth 2 f)))
(plist-get r :fields))
;; A field the renderer refused — no printer for its type —
;; still shows, with its own reason in the value column.
(mapcar (lambda (f) (list (nth 0 f) nil nil (nth 1 f)))
(plist-get r :refused)))
:why nil
;; The build's own count. Zero means this condition declares no
;; fields, which is a fact about it and not a failure to read
;; one.
:empty (eql 0 (plist-get r :declared)))
;; The shape alone, through the one function that spells the `layout'
;; request. Its own reason is kept when it is the one that refused —
;; "not a qualified name" says more than anything about the values —
;; and the values' reason otherwise.
(let* ((why (plist-get r :message))
(fallback (flan-cnr-layout type)))
(list :fields (plist-get fallback :fields)
:why (if (plist-get fallback :fields)
(or why (plist-get fallback :why))
(or (plist-get fallback :why) why)))))))
(defun flan-cnr-backtrace ()
"The stopped program's frames, innermost first, as the renderer wants them.
@ -690,7 +818,8 @@ walk from a running program."
(unless (derived-mode-p 'flan-cnr-mode) (flan-cnr-mode))
(flan-cnr--render
(flan-cnr-state-from-reply r
(flan-cnr-layout (plist-get r :condition))
(flan-cnr-condition-fields
(plist-get r :condition))
(flan-cnr-backtrace)
(flan-cnr-globals))))
(pop-to-buffer buf)

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

@ -981,8 +981,8 @@ would be overwritten. Look again and re-do the edit")
(string-match-p " 0: \\[retry\\]" text))
(test-flan--check "a shadowed one has no bracket, as SBCL's has none"
(string-match-p " 2: retry " text))
(test-flan--check "and says why, and what it would take"
(string-match-p "shadowed by 0.*restart-at" text))
(test-flan--check "and says whose name it repeats"
(string-match-p "same name as 0" text))
(test-flan--check "abort is the last entry on the same list"
(string-match-p " 3: \\[abort\\]" text))
;; The rule: nothing implemented is refused by name, with the reason. These
@ -990,7 +990,7 @@ would be overwritten. Look again and re-do the edit")
;; The shape of a condition and the values in it are two different
;; refusals, and with nothing at all the outer one is what shows.
(test-flan--check "the condition's fields are refused, not omitted"
(string-match-p "Condition fields:\n not available.*Tast.structs" text))
(string-match-p "Condition fields:\n not available — no struct" text))
;; The stack is no longer refused for want of a mechanism — the shadow stack
;; landed and the daemon answers `backtrace'. What this fixture has is no
;; stack *passed in*, which is the running-program case, so the reason it
@ -1011,7 +1011,9 @@ would be overwritten. Look again and re-do the edit")
(test-flan--check "and abort is still offered"
(string-match-p " 0: \\[abort\\]" text)))
;; Taking one sends `restart' with the name.
;; Taking one sends `restart-at' with the index, and the name as a receipt:
;; the index is the identity — two frames can offer `retry' — and the name is
;; what lets the daemon refuse a buffer that has gone stale.
(let ((sent nil))
(let ((flan-cnr-request-function
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
@ -1020,22 +1022,23 @@ would be overwritten. Look again and re-do the edit")
(goto-char (point-min))
(search-forward " 1: ")
(save-window-excursion (flan-cnr-take))
(test-flan--check "RET on a restart sends its name"
(equal sent '(:op "restart" :name "skip"))))))
(test-flan--check "RET on a restart sends its index, name as receipt"
(equal sent '(:op "restart-at" :index 1 :name "skip"))))))
;; And a shadowed one is refused here rather than sent, which is the bug in
;; today's `completing-read': it would send "retry" and the *inner* frame would
;; take it, silently.
;; And a shadowed one is *takeable* now — the choice goes out by number, so
;; the inner frame owning the name no longer matters. This is the bug
;; `completing-read' had: it sent "retry" and the inner frame took it,
;; silently.
(let ((sent nil))
(let ((flan-cnr-request-function (lambda (form) (setq sent form) '(:status "ok"))))
(let ((flan-cnr-request-function
(lambda (form) (setq sent form) (list :status "ok" :note "accepted"))))
(with-current-buffer (test-flan--cnr
(list :condition "Missing" :restarts '("retry" "a" "retry")))
(goto-char (point-min))
(search-forward " 2: ")
(let ((err (test-flan--caught #'flan-cnr-take)))
(test-flan--check "a shadowed restart refuses"
(and err (string-match-p "shadowed by 0" err)))
(test-flan--check "and nothing was sent" (null sent))))))
(save-window-excursion (flan-cnr-take))
(test-flan--check "a shadowed restart is taken by its own index"
(equal sent '(:op "restart-at" :index 2 :name "retry"))))))
;; A digit takes one, as it does in SBCL.
(let ((sent nil))
@ -1047,7 +1050,7 @@ would be overwritten. Look again and re-do the edit")
(let ((last-command-event ?0))
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
(test-flan--check "0 takes the innermost"
(equal sent '(:op "restart" :name "retry")))
(equal sent '(:op "restart-at" :index 0 :name "retry")))
(let ((last-command-event ?2))
(save-window-excursion (call-interactively #'flan-cnr-take-number)))
(test-flan--check "and the number past the last is abort"
@ -1147,14 +1150,93 @@ would be overwritten. Look again and re-do the edit")
(let ((text (with-current-buffer
(test-flan--cnr (list :condition "Missing" :restarts '("retry")
:fields '(("path" "string" nil)
("tried" "i32" "3"))))
("tried" "i32" "3"))
:fields-why "the stop's value was not readable"))
(buffer-string))))
(test-flan--check "a field is named and typed even with no value"
(string-match-p ":path *string *value not available" text))
(test-flan--check "and the missing value names the verb it needs"
(string-match-p "value not available.*agent verb: `condition'" text))
(string-match-p ":path *string *not read" text))
(test-flan--check "and the reason is one sentence, said once above the rows"
(and (string-match-p "not read — the stop's value" text)
(= 1 (seq-count
(lambda (l) (string-match-p "not read — " l))
(split-string text "\n")))))
(test-flan--check "a value that is there is simply shown"
(string-match-p ":tried *i32 *3" text)))
(string-match-p ":tried *i32 *3" text))
;; The headline reads the condition's own numbers, so what happened is the
;; first line rather than something assembled from the fields below.
(test-flan--check "the headline carries the fields that have values"
(string-match-p "\\`Missing — tried 3" text)))
;; The whole point of the `condition' verb: values beside the shape, read out
;; of the stopped program by a thunk the daemon builds, with nothing
;; special-casing any one condition type.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError"
:restarts '("continue")
:fields '(("low" "i64" "648") ("high" "i64" "648")
("length" "i64" "100"))
:site "/home/x/sand.flan:52:13"
:source " (set (at grid i) 1)"))
(buffer-string))))
(test-flan--check "the headline is the condition's own numbers"
(string-match-p "\\`BoundsError — low 648, high 648, length 100"
text))
(test-flan--check "the site is under the headline"
(string-match-p "at /home/x/sand.flan:52:13" text))
(test-flan--check "with the source line"
(string-match-p " 52| +(set (at grid i) 1)" text))
(test-flan--check "and a caret under the column"
(string-match-p "\n +\\^\n" text))
(test-flan--check "every field renders with its value"
(string-match-p ":length +i64 +100" text)))
;; A condition that declares no fields is an ordinary thing — Pause is one —
;; and saying "no struct has this name" about it would be false. The two
;; empties are told apart by the daemon's own count, not inferred from a list
;; that is empty in both cases.
(let ((text (with-current-buffer
(test-flan--cnr (list :condition "Pause" :restarts '("continue")
:fields nil :fields-empty t))
(buffer-string))))
(test-flan--check "a condition with no fields says so"
(string-match-p "this condition has no fields" text))
(test-flan--check "and is not reported as an unknown name"
(not (string-match-p "no struct has this name" text))))
(let ((text (with-current-buffer
(test-flan--cnr (list :condition "Whatsit" :restarts '("continue")
:fields nil))
(buffer-string))))
(test-flan--check "while a name with no struct behind it still says that"
(string-match-p "not available — no struct has this name" text)))
;; A tab-indented source line: the caret pads with the line's own whitespace,
;; so it lands under the column rather than a tab stop away from it.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "BoundsError" :restarts nil
:fields '(("low" "i64" "9"))
:site "/x/t.flan:3:9"
:source "\t\t(at g i)"))
(buffer-string))))
;; Six spaces for the " 3| " gutter, then the line's own two tabs, then
;; six spaces for "(at g " — the caret lands under column 9 whatever the
;; tab stop is.
(test-flan--check "the caret pads with the source's own tabs"
(string-match-p "\n \\{6\\}\t\t \\{6\\}\\^\n" text)))
;; No implementation note ever prints: the bracketed design asides used to
;; leak into the buffer, and the fix is pinned as a property of the whole
;; rendering rather than of one string.
(let ((text (with-current-buffer
(test-flan--cnr
(list :condition "Missing" :restarts '("retry" "a" "retry")
:fields '(("path" "string" nil))
:stack (list (list :fn "f" :fetched t :locals nil))))
(buffer-string))))
(test-flan--check "no bracketed implementation note leaks into the buffer"
(not (string-match-p "\\[needs\\|agent verb\\|Tast\\." text))))
;; Backwards through the buffer, for the same reason as in the inspector.
(with-current-buffer (test-flan--cnr
@ -1202,10 +1284,11 @@ would be overwritten. Look again and re-do the edit")
"sim/Missing"))
(test-flan--check "the fields are drawn, named and typed"
(string-match-p ":path *string" text))
;; Shape and contents are two different questions, and only the first is
;; answerable without the pointer the break loop discards.
;; Shape and contents are two different questions, and this stub's
;; daemon answers only the first — so the values fall back to the
;; layout, each row saying in one sentence why it is empty.
(test-flan--check "and every value still says why it is missing"
(string-match-p ":tried *i32 *value not available" text)))))
(string-match-p ":tried *i32 *not read" text)))))
;; A layout the daemon refuses — a bare name it will not guess between two
;; packages, or a type it cannot place — leaves the section drawing its reason
@ -1221,7 +1304,7 @@ would be overwritten. Look again and re-do the edit")
(let ((text (with-current-buffer (save-window-excursion (flan-cnr-show))
(buffer-string))))
(test-flan--check "a refused layout is a section that says so"
(string-match-p "not available.*needs a \\*qualified\\* name" text))
(string-match-p "not available — .*not a qualified name" text))
(test-flan--check "and the restarts are drawn anyway"
(string-match-p "\\[retry\\]" text))))
@ -1269,8 +1352,7 @@ would be overwritten. Look again and re-do the edit")
:stack (list (list :fn "f"))))
(buffer-string))))
(test-flan--check "an empty globals section says what empty means"
(string-match-p "not available.*union of what the frames reach"
text)))
(string-match-p "not available.*all in its locals" text)))
;; A frame the daemon could not attribute makes the union smaller than the real
;; one, and a list that is short without saying so is the failure this whole
@ -1384,7 +1466,7 @@ stopped program, which is the case where it should fire."
(lambda () (flan-cnr--insert-condition
(list :condition flan-cnr-breakpoint))))))
(test-flan--check "a breakpoint is called a breakpoint"
(string-match-p "a breakpoint; stopped where (pause)" text))
(string-match-p "stopped at (pause)" text))
(test-flan--check "and is not called unhandled"
(not (string-match-p "unhandled" text))))

9
emacs/test-flan.el
View File

@ -242,9 +242,14 @@ already rely on it — so nothing here is a stand-in for the real thing."
(require 'flan-cnr)
(let ((flan-cnr-request-function #'flan--request))
(test-flan--check "a struct's fields come back named and typed"
(equal (flan-cnr-layout "Missing") '(("id" "i32" nil))))
(equal (plist-get (flan-cnr-layout "Missing") :fields)
'(("id" "i32" nil))))
(test-flan--check "and a type the daemon cannot place is nil, not an error"
(null (flan-cnr-layout "Nonesuch"))))
(null (plist-get (flan-cnr-layout "Nonesuch") :fields)))
;; The refusal's own sentence rides along, because it is the one the
;; section draws and the daemon writes it better than this end could.
(test-flan--check "and its reason comes with it"
(stringp (plist-get (flan-cnr-layout "Nonesuch") :why))))
;; C-c C-c on the form at point: put point inside `step' and send it. The
;; text comes from the buffer, so this exercises `beginning-of-defun' against

192
lib/dev.ml
View File

@ -388,6 +388,34 @@ let restarts t =
end
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
(* Whether the break on top holds a condition value a render thunk can be
aimed at. [+] or [-]; the pointer itself never crosses the wire. *)
let condition_present t =
match ask t "condition" with
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
| text ->
let line = String.trim text in
if line = "+" then Ok true
else if line = "-" then Ok false
else Error line
(* Where the expression that trapped is written — file:line:col — or [None]
for a stop that has no site: a user (error ...), a (pause). The frame
lines say where each call was; this is the only record of the indexing or
the division itself. *)
let trap_site t =
match ask t "site" with
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
| text ->
let line = String.trim text in
(* ["err "] with the space, not ["err"]: every refusal the agent writes
has one, and a *site* is a path — [errors.flan:10:2] starts with those
three letters and is an answer, not a refusal. Testing the shorter
prefix dropped that site silently, which is the one failure this
whole section exists to avoid. *)
if String.length line >= 4 && String.sub line 0 4 = "err " then Error line
else Ok (if line = "-" || line = "" then None else Some line)
(* Where a stopped program is, one frame per line, innermost first — the same
framing [restarts] uses, terminated by a lone dot, because it comes back
over the same one-line-out socket.
@ -1355,6 +1383,54 @@ let layout t ~ty =
other, so an editor reads the same two keys whatever it asked. What this op
adds is the restart names, which cost a second round trip to the program and
are wanted only when someone is about to choose one. *)
(* The text of the line a site names, for the pointer the break buffer draws
under the headline. Best effort by design: the site is authoritative and a
file this end cannot read simply contributes no line — a build directory
moved, a program compiled on another machine. Parsed from the right,
because the path is the one piece that could contain a colon. *)
let source_line site =
match String.rindex_opt site ':' with
| None -> None
| Some c ->
(match String.rindex_from_opt site (c - 1) ':' with
| None -> None
| Some l ->
(match int_of_string_opt (String.sub site (l + 1) (c - l - 1)) with
| None -> None
| Some line when line > 0 ->
let path = String.sub site 0 l in
(match open_in path with
| exception Sys_error _ -> None
| ic ->
(* Every way out closes the handle, and every failure is [None].
[open_in] on a directory succeeds on Linux and it is the
*read* that raises [Sys_error] — which escaping from here
would take down the whole [break] reply over a cosmetic
line, and leak the handle on the way. A source line is a
nicety; the site above it is the answer. *)
let rec skip n =
match input_line ic with
| exception End_of_file -> None
| exception Sys_error _ -> None
| text -> if n <= 1 then Some text else skip (n - 1)
in
let r = match skip line with r -> r | exception _ -> None in
close_in_noerr ic;
r)
| Some _ -> None))
(* The two site fields [break] adds when the stop has one. [:site] is where
the expression that trapped is written; [:source] is that line's text, when
the file can be read from here. *)
let site_fields t =
match trap_site t with
| Error _ | Ok None -> []
| Ok (Some site) ->
(":site " ^ Wire.quote site)
:: (match source_line site with
| None -> []
| Some text -> [ ":source " ^ Wire.quote text ])
let break t =
match liveness t with
| Gone -> error gone
@ -1386,12 +1462,13 @@ let break t =
rather than filtered, because a client that quietly dropped them
would leave someone asking where their restart went. *)
ok
[ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs);
":unreachable "
^ Wire.ints
(List.filter_map
(fun (i, ok, _) -> if ok then None else Some i)
rs) ]
([ ":restarts " ^ Wire.strings (List.map (fun (_, _, n) -> n) rs);
":unreachable "
^ Wire.ints
(List.filter_map
(fun (i, ok, _) -> if ok then None else Some i)
rs) ]
@ site_fields t)
| Error m -> error ("the program refused to list its restarts: " ^ m))
(* [(:op "backtrace")] — the frames of a stopped program, innermost first.
@ -1714,9 +1791,7 @@ let locals t ~frame =
if Array.length fn.Tast.slots = 0 then
ok
[ ":frame " ^ Wire.quote name; ":locals ()"; ":refused ()";
":note "
^ Wire.quote
"that frame records no slots; every slot in it is one the compiler made up" ]
":note " ^ Wire.quote "this frame has no named locals" ]
else
(match bound_slots t ~frame with
| Error m -> error ("the program refused to say which slots are bound: " ^ m)
@ -1751,6 +1826,104 @@ let locals t ~frame =
(fun (n, why) -> Wire.list [ Wire.quote n; Wire.quote why ])
refused) ]))
(* [(:op "condition")] — the stopped condition's fields, with their values.
[layout] answers the *shape* out of [Tast.structs] with no program
involved; this is the other half. The break loop stashed the pointer it
was handed in the agent's snapshot, and this end knows the type at that
address — it compiled it, and [status] reports its qualified name. So it
is [locals] pointed at the condition: a thunk renders each field through
[flan/dev-cond], on the stopped thread, and the text comes back the same
way.
Delivered at-stop, and that is the correctness of it rather than a nicety.
The thunk reads whatever pointer the snapshot on top holds when it runs; a
program that resumed and stopped again holds a *different* condition, and
rendering the old stop's type over the new stop's pointer would be a
misread with a plausible shape. Naming the stop makes the agent drop the
thunk instead.
Refused, by name, for a stop that has no value to read: a trap like
[NullAllocator] is a name with no struct behind it, and a trap with no
transfer channel reached the break loop with no condition at all. *)
let condition_op t =
match liveness t with
| Gone -> error gone
| Parked when not (parked_break t) ->
parked "a parked program is not stopped on a condition"
| Live | Parked ->
match state t with
| Running ->
error "the program is running; a condition is read where it stopped"
| Unreachable m -> error ("cannot ask the program what it stopped on: " ^ m)
| Stopped cname ->
match
List.find_opt
(fun (s : Tast.structure) -> String.equal s.Tast.sname cname)
t.session.Session.program.Tast.structs
with
| None ->
error
(cname
^ " is not a struct this session knows, so there are no fields to \
read")
| Some st ->
match condition_present t with
| Error m -> error ("cannot ask the program for its condition: " ^ m)
| Ok false ->
error
("this stop was not handed a condition value; there is nothing to \
render for " ^ cname)
| Ok true ->
match stop_gen t with
| None | Some 0 ->
error "cannot pin the stop this condition belongs to; ask again"
| Some gen ->
let c, refused = Session.render_condition t.session ~st in
(match run_render_thunk ~at_stop:gen t ~tag:"c" ~c with
| Error m -> error m
| Ok v ->
(* One line per field — name, type, value, tab separated, and
safe because every string the renderer emits is escaped.
A line that is not three parts is *not* dropped. Nothing
should produce one, which is exactly why it must be visible
if anything ever does: a field silently in neither list
would read as a condition that has fewer fields than it
has. It joins the refusals, with what came back. *)
let entries = ref [] and strays = ref [] in
List.iter
(fun line ->
match String.split_on_char '\t' line with
| [ n; ty; value ] ->
entries :=
Wire.list
[ Wire.quote n; Wire.quote ty; Wire.quote value ]
:: !entries
| _ ->
if String.trim line <> "" then
strays :=
(line, "the renderer wrote a line this end could not \
read as a field")
:: !strays)
(String.split_on_char '\n' v);
let entries = List.rev !entries in
ok
[ ":type " ^ Wire.quote cname;
":fields " ^ Wire.list entries;
(* How many the *build* says this struct has, so a client
can tell "rendered nothing" from "has nothing to
render". A condition with no fields is an ordinary
thing — [Pause] is one — and it must not be reported
the way an unknown name is. *)
Printf.sprintf ":declared %d" (List.length st.Tast.fields);
":refused "
^ Wire.list
(List.map
(fun (n, why) ->
Wire.list [ Wire.quote n; Wire.quote why ])
(refused @ List.rev !strays)) ])
(* [(:op "inspect" :frame N :slot I :path (...))] — the inspector's second
rooting mode. [docs/BUILT.md]'s "Two ways to root a walk" says what each root
can and cannot do; this is the half that names a frame.
@ -3222,6 +3395,7 @@ let handle t req =
| Some "describe" -> describe t
| Some "defs" -> defs t
| Some "break" -> break t
| Some "condition" -> condition_op t
| Some "backtrace" -> backtrace_op t
| Some "locals" ->
locals t ~frame:(match Wire.int_field req "frame" with Some n -> n | None -> 0)

24
lib/render.ml
View File

@ -48,6 +48,12 @@ type emitter = {
registry to call. *)
type pointers = {
live : Tast.expr -> Tast.expr; (* a (Ptr a) -> bool: may it be read *)
(* The character half of a u8: emits " (\a)" beside the number, or nothing
for a byte with no spelling a reader would take back. It rides in this
record rather than in [emitter] because it belongs to exactly the side
that record already marks — the inspecting one. [println] passes [None]
here and a u8 stays a bare number there, which is what it is. *)
bytechar : Tast.expr -> Tast.expr; (* u8 -> unit *)
(* Emits what the registry remembers about a dead address, and emits nothing
at all for one it never saw — a stack local is not in it by design, and
inventing a sentence about one would be worse than the silence [<ptr>]
@ -105,6 +111,24 @@ let rec render c depth (e : Tast.expr) : Tast.expr list =
else
match e.Tast.ty with
| Types.Int Types.U64 -> [ c.emit.eu64 e ]
(* A byte, where the reader is inspecting rather than the program is
printing: the number and then the character it is, [97 (\a)]. [[u8]]
already renders as text, so a lone byte showing only 97 is the one
place the same data reads two ways — and this is the side where that
matters, because nobody is computing with what is on the screen.
[println] has no [ptrs] and is unchanged: a u8 is a number there. The
expression is bound to a slot first, for the pointer arm's reason —
it is named twice here, and the expression it came from may be a
call through a bounds check. *)
| Types.Int Types.U8 when c.ptrs <> None ->
let pt = Option.get c.ptrs in
let bv = c.alloc e.Tast.ty in
let b () = { Tast.e = Tast.Local bv; ty = e.Tast.ty; loc } in
[ unit_
(Tast.Let ([ (bv, e) ],
[ c.emit.ei64 (cast (Types.Int Types.I64) (b ()));
pt.bytechar (b ()) ])) ]
| Types.Int _ -> [ c.emit.ei64 (cast (Types.Int Types.I64) e) ]
| Types.Float _ -> [ c.emit.ef64 (cast (Types.Float Types.F64) e) ]
| Types.Bool ->

185
lib/session.ml
View File

@ -941,6 +941,16 @@ let externs : Tast.extern list =
{ Tast.ename = "flan/dev-slot"; esym = "flan_agent_frame_slot";
eparams = [ Types.Int Types.I64; Types.Int Types.I64 ];
eret = Types.Ptr (Types.Int Types.U8); eloc = Loc.unknown };
(* The condition the stopped program is holding, same contract: the agent
resolves it against the snapshot on top when the thunk runs, and NULL
when there is none. See [render_condition]. *)
{ Tast.ename = "flan/dev-cond"; esym = "flan_agent_condition";
eparams = []; eret = Types.Ptr (Types.Int Types.U8);
eloc = Loc.unknown };
(* The character beside a rendered byte. See [Render.pointers]. *)
{ Tast.ename = "flan/dev-emit-u8-char"; esym = "flan_dev_emit_u8_char";
eparams = [ Types.Int Types.I64 ]; eret = Types.Unit;
eloc = Loc.unknown };
{ Tast.ename = "flan/dev-begin"; esym = "flan_dev_result_begin";
eparams = []; eret = Types.Unit; eloc = Loc.unknown };
{ Tast.ename = "flan/dev-end"; esym = "flan_dev_result_end";
@ -1007,10 +1017,68 @@ let dev_pointers : Render.pointers =
{ Tast.e =
Tast.Do [ ask "flan/reg-emit" p;
{ Tast.e = Tast.Unit; ty = Types.Unit; loc } ];
ty = Types.Unit; loc });
(* Widened to i64 at the call, because every extern this file declares
that takes a number takes one, and the C reads the byte back out of
it. The spelling table is in flan_dev.c and answers to
lib/reader.ml's [read_byte]. *)
bytechar =
(fun b ->
let loc = b.Tast.loc in
let wide =
{ Tast.e = Tast.Prim (Tast.Cast (Types.Int Types.I64), [ b ]);
ty = Types.Int Types.I64; loc }
in
{ Tast.e = Tast.Call ("flan/dev-emit-u8-char", [ wide ]);
ty = Types.Unit; loc }) }
(* ── The locals of a stopped frame ─────────────────────────────────── *)
(* What a slot is *shown as*. Two departures from the raw [snames] entry,
both about keeping the listing in the words the person wrote.
A compiler temp — [dotimes]'s hidden bound, the slot a (min) evaluates an
operand into — has no name at all, and it is hidden rather than refused:
[s4] is not a variable anyone can find in the file, and a row explaining
its absence was noise on every frame that had one. [None] here means
"not shown".
A shadowing rebind — [check.ml]'s [bind] suffixes the repeat as [v~2] so
the debug info never claims one binding is the other — is shown under the
written name, because the depth is the compiler's bookkeeping. Only a
trailing [~N] is stripped: [~] is the reader's delimiter and a synthesized
name like [destructure~nth] carries it for a different reason. And when
stripping would put one name on two slots of this frame, both keep their
raw spelling — two rows called [v] with nothing to tell them apart is the
lie the suffix existed to prevent. *)
let strip_rebind name =
match String.rindex_opt name '~' with
| Some k when k > 0 && k < String.length name - 1 ->
let suffix = String.sub name (k + 1) (String.length name - k - 1) in
if String.for_all (fun c -> c >= '0' && c <= '9') suffix
then String.sub name 0 k
else name
| _ -> name
let shown_names (fn : Tast.fn) : string option array =
let n = Array.length fn.Tast.slots in
let raw =
Array.init n (fun i ->
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i) else None)
in
let stripped = Array.map (Option.map strip_rebind) raw in
let count name =
Array.fold_left
(fun acc s -> if s = Some name then acc + 1 else acc)
0 stripped
in
Array.mapi
(fun i s ->
match s with
| None -> None
| Some d -> if count d > 1 then raw.(i) else Some d)
stripped
(* The second half of what a break loop can show, and it is the same primitive
as [C-x C-e] pointed somewhere else.
@ -1095,27 +1163,20 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
refuse name why;
None
in
let names = shown_names fn in
let body =
List.concat
((List.filter_map
(fun i ->
let ty = fn.Tast.slots.(i) in
let name =
if i < Array.length fn.Tast.snames then fn.Tast.snames.(i)
else None
in
match name with
match names.(i) with
| None ->
(* A slot the compiler made up: [dotimes]'s hidden bound, the
temporary a (min) evaluates an operand into. There is no
name to show and inventing one would put a variable in the
list that nobody can find in the file. *)
refuse (Printf.sprintf "s%d" i)
"a slot the compiler made up; no name was written for it";
(* A slot the compiler made up — hidden, not refused; see
[shown_names]. *)
None
| Some name when not (List.mem i bound) ->
refuse name
"not bound yet at the point the program stopped";
"not bound yet where the program stopped";
None
| Some name -> one i ty name)
(List.init (Array.length fn.Tast.slots) (fun i -> i))))
@ -1142,6 +1203,90 @@ let render_locals ?(origin = "<locals>") t ~frame ~(fn : Tast.fn) ~bound
ignore origin;
({ ir; x86 = t.x86; names = []; fns = []; installs = true }, List.rev !refused)
(* ── The fields of the condition a break is holding ────────────────── *)
(* [render_locals] pointed at the condition instead of a frame. The break
loop stashes the pointer it was handed in the snapshot, the thunk reads it
back through [flan/dev-cond], and the type at that address is the struct
whose qualified name the agent reported as the condition — this end
compiled it, so the layout is its own to know. One line per field:
name, type, value, tab separated.
The thunk carries no address of its own — [flan/dev-cond] resolves against
the snapshot on top when it runs — but the *type* it reads with was chosen
against a particular stop, so the caller delivers it at-stop: a program
that resumed and stopped again holds a different condition, and rendering
the old type over the new pointer is the misread the at-stop check
refuses. *)
let render_condition t ~(st : Tast.structure) : change * (string * string) list =
let loc = Loc.unknown in
let extra = ref [] and nslots = ref 0 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
let nullary n = { Tast.e = Tast.Call (n, []); ty = Types.Unit; loc } in
let bytes_of str =
{ Tast.e =
Tast.Prim (Tast.Bytes, [ { Tast.e = Tast.Str str; ty = Types.String; loc } ]);
ty = Types.Slice (Types.Int Types.U8); loc }
in
let lit str = c.Render.emit.Render.ebytes (bytes_of str) in
let refused = ref [] in
let cty = Types.Named st.Tast.sname in
let address =
{ Tast.e = Tast.Call ("flan/dev-cond", []);
ty = Types.Ptr (Types.Int Types.U8); loc }
in
let typed =
{ Tast.e = Tast.Prim (Tast.Cast (Types.Ptr cty), [ address ]);
ty = Types.Ptr cty; loc }
in
let root = { Tast.e = Tast.Deref typed; ty = cty; loc } in
let one i (f : Tast.field) =
let v = { Tast.e = Tast.Field (root, i); ty = f.Tast.fty; loc } in
match Render.render c 0 v with
| parts ->
Some
((lit (f.Tast.fname ^ "\t" ^ Types.to_string f.Tast.fty ^ "\t") :: parts)
@ [ lit "\n" ])
| exception Loc.Error { Loc.dmsg = why; _ } ->
(* A field the structural printer has no arm for. Named with the
reason, so the buffer shows the field and says why its value is
not beside it. *)
refused := (f.Tast.fname, why) :: !refused;
None
in
let body =
List.concat
(List.filter_map Fun.id (List.mapi (fun i f -> one i f) st.Tast.fields))
in
t.thunks <- t.thunks + 1;
let name = Printf.sprintf "condition/%d" t.thunks in
let thunk : Tast.fn =
{ Tast.name; params = []; ret = Types.Unit;
body = (nullary "flan/dev-begin" :: body) @ [ nullary "flan/dev-end" ];
fdefers = []; fparent = None; floc = loc;
slots = Array.of_list (List.rev !extra);
snames = Array.make (List.length !extra) None }
in
let program =
{ t.program with
Tast.fns = t.program.Tast.fns @ [ thunk ];
externs = t.program.Tast.externs @ externs }
in
let ir = redefinition t ~call:name program ~fns:[ name ] in
({ ir; x86 = t.x86; names = []; fns = []; installs = true }, List.rev !refused)
(* ── One slot of a stopped frame, walked ───────────────────────────── *)
(* The inspector's second rooting mode, and the whole of what it needed.
@ -1327,15 +1472,13 @@ let render_slot ?(origin = "<inspect>") t ~frame ~(fn : Tast.fn) ~slot ~path
(Printf.sprintf "there is no slot %d in %s; it has %d" slot fn.Tast.name
nslots_of_fn)
else
let sname =
if slot < Array.length fn.Tast.snames then fn.Tast.snames.(slot) else None
in
let sname = (shown_names fn).(slot) 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 %d of %s has no name in the source; the listing does not \
show it and there is nothing here to inspect"
slot fn.Tast.name)
| Some name ->
let extra = ref [] and nslots = ref 0 in
@ -1529,15 +1672,13 @@ let write_slot ?(origin = "<set>") t ~frame ~(fn : Tast.fn) ~slot ~path
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
let sname = (shown_names fn).(slot) 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 %d of %s has no name in the source; the listing does not \
show it and there is nothing here to inspect"
slot fn.Tast.name)
| Some name ->
let where = name ^ path_text path in

54
runtime/flan_dev.c
View File

@ -351,6 +351,60 @@ void flan_dev_emit_str(const uint8_t *bytes, int64_t len) {
put_str(flan_dev_emit, bytes, len);
}
/* The character half of a u8, appended after the number: " (\a)", or nothing
* for a byte with no spelling a reader would accept.
*
* A u8 is a number and prints as one — [println] is unchanged. But a *reader*
* looking at a frame is in the asymmetric position the author named: [u8]
* already renders as text, so a lone byte showing 97 is the one place the
* same data reads two ways. This is the inspecting half, and only the
* inspecting renderers call it.
*
* The spellings are lib/reader.ml's [read_byte], which is the authority: the
* five named ones, and any single character that is not a delimiter there —
* so what is shown could be typed back. A delimiter has no single-character
* spelling and no name, and a control byte has neither; both get the number
* alone rather than an invented escape or a raw control byte written into a
* buffer someone is about to read. Done here rather than as emitted
* comparisons because the value is only known at run time: a chain over
* ninety-odd bytes per rendered u8 would be the walk paying for its own
* shape, and the table belongs in one place. */
/* No [check_shared] here, deliberately: that guard checks [flan_f64_format]
* and [flan_escape_char] are the functions this file declares, and this uses
* neither — same as [put_u64] and [put_i64], which do not call it either. */
void flan_dev_emit_u8_char(int64_t x) {
const char *name = NULL;
char one[2];
if (x < 0 || x > 255) return;
switch (x) {
case 32: name = "space"; break;
case 9: name = "tab"; break;
case 10: name = "newline"; break;
case 13: name = "return"; break;
case 0: name = "nul"; break;
default: break;
}
if (name == NULL) {
/* Printable and not one of the reader's delimiters. */
if (x < 33 || x > 126) return;
switch ((char)x) {
case '(': case ')': case '[': case ']': case '{': case '}':
case '"': case ';': case '`': case '~': case ',':
return;
default: break;
}
one[0] = (char)x;
one[1] = '\0';
name = one;
}
/* [put] and not [put_str]: this is punctuation around a spelling, not a
* string value, so it must not be quoted or escaped a second time. Every
* byte written here is one [read_byte] would accept back. */
put(flan_dev_emit, " (\\");
put(flan_dev_emit, name);
put(flan_dev_emit, ")");
}
void flan_dev_result_end(void) {
truncate_value(result, &result_len, RESULT_MAX, result_full);
close_value(&generation);

37
runtime/flan_rt.c
View File

@ -761,10 +761,24 @@ typedef struct { int64_t low, high, length; } flan_bounds_cond;
static const uint8_t flan_bounds_name[] = "BoundsError";
#define FLAN_BOUNDS_NAMELEN 11
/* Where the expression that trapped is written — the loc every checked site
* already passes for its unhandled message, published for the break hook.
* The frame chain says where each *call* was; this is the only record of the
* `at` or the division itself, which is the line a person wants pointed at.
*
* Set immediately before the hook runs and cleared when it returns, so the
* agent's snapshot (taken on entry to the break loop, on this same thread)
* reads it while it is true and a later break through [flan_error] — a user
* (error ...), which carries no loc — cannot inherit a stale one. NULL
* outside that window, and NULL is the honest answer for a signal that has
* no expression to point at. */
const uint8_t *flan_break_site;
int64_t flan_break_site_len;
/* Returns nonzero if something transferred, in which case the caller returns
* and its caller's guard carries the transfer out. */
static int flan_bounds_signal(void *xfer, int64_t low, int64_t high,
int64_t len) {
static int flan_bounds_signal(const uint8_t *loc, int64_t loclen, void *xfer,
int64_t low, int64_t high, int64_t len) {
flan_bounds_cond c;
uint32_t id = flan_name_id(flan_bounds_name, FLAN_BOUNDS_NAMELEN);
c.low = low;
@ -773,7 +787,11 @@ static int flan_bounds_signal(void *xfer, int64_t low, int64_t high,
flan_signal(id, &c, xfer);
if (*(void **)xfer != NULL) return 1;
if (flan_break_hook != NULL) {
flan_break_site = loc;
flan_break_site_len = loclen;
flan_break_hook(flan_bounds_name, FLAN_BOUNDS_NAMELEN, &c, xfer);
flan_break_site = NULL;
flan_break_site_len = 0;
if (*(void **)xfer != NULL) return 1;
}
return 0;
@ -781,13 +799,13 @@ static int flan_bounds_signal(void *xfer, int64_t low, int64_t high,
void flan_bounds_error(const uint8_t *loc, int64_t loclen, int64_t idx,
int64_t len, void *xfer) {
if (flan_bounds_signal(xfer, idx, idx, len)) return;
if (flan_bounds_signal(loc, loclen, xfer, idx, idx, len)) return;
flan_bounds_fail(loc, loclen, idx, len);
}
void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo,
int64_t hi, int64_t len, void *xfer) {
if (flan_bounds_signal(xfer, lo, hi, len)) return;
if (flan_bounds_signal(loc, loclen, xfer, lo, hi, len)) return;
flan_slice_fail(loc, loclen, lo, hi, len);
}
@ -832,7 +850,7 @@ _Noreturn void flan_slice_promise_fail(const uint8_t *loc, int64_t loclen,
void flan_slice_promise_error(const uint8_t *loc, int64_t loclen, int64_t n,
void *xfer) {
if (flan_bounds_signal(xfer, 0, n, 0)) return;
if (flan_bounds_signal(loc, loclen, xfer, 0, n, 0)) return;
flan_slice_promise_fail(loc, loclen, n);
}
@ -936,7 +954,11 @@ void flan_arith_error(const uint8_t *loc, int64_t loclen, int32_t op,
flan_signal(id, &c, xfer);
if (*(void **)xfer != NULL) return;
if (flan_break_hook != NULL) {
flan_break_site = loc;
flan_break_site_len = loclen;
flan_break_hook(flan_arith_name, FLAN_ARITH_NAMELEN, &c, xfer);
flan_break_site = NULL;
flan_break_site_len = 0;
if (*(void **)xfer != NULL) return;
}
flan_arith_fail(loc, loclen, op, lhs, rhs);
@ -1706,7 +1728,8 @@ void *flan_vec_at(flan_vec *v, int32_t i, int64_t size, const uint8_t *loc,
/* The same unsigned comparison the fixed-array bounds check uses: a negative
* index sign-extends to a huge unsigned and is caught by the one test. */
if ((uint64_t)(int64_t)i >= (uint64_t)v->len) {
if (flan_bounds_signal(xfer, (int64_t)i, (int64_t)i, v->len)) return NULL;
if (flan_bounds_signal(loc, loclen, xfer, (int64_t)i, (int64_t)i, v->len))
return NULL;
flan_vec_bounds_fail(loc, loclen, (int64_t)i, v->len);
}
return (uint8_t *)v->ptr + (int64_t)i * size;
@ -1723,7 +1746,7 @@ void flan_vec_as_slice(flan_vec *v, void *out, int32_t lo, int32_t hi,
/* Both ends, because both are what went wrong — the fixed-array slice
* check reports the same pair. [out] is left untouched on the transfer
* path; the caller's guard branches before it reads the slice. */
if (flan_bounds_signal(xfer, l, h, v->len)) return;
if (flan_bounds_signal(loc, loclen, xfer, l, h, v->len)) return;
flan_vec_bounds_fail(loc, loclen, l, v->len);
}
s.p = (uint8_t *)v->ptr + l * size;

11
test/programs/dev-break.flan
View File

@ -24,6 +24,17 @@
(set ticks (+ ticks 1))
ticks)
;;; A division under a restart-case, called from the editor rather than from
;;; main. It is here for the *other* condition the runtime builds by hand:
;;; ArithError's three fields are a C struct in flan_rt.c and a defstruct in
;;; the prelude, and the break loop's render now reads them field by field,
;;; padding and all. A layout that drifted would show the op in `lhs'.
;;; The operands are parameters so nothing constant-folds the division away.
(defn divide [a i64 b i64] i64
(restart-case
(/ a b)
(use-zero [] 0)))
(defn main [] i32
(agent/start "/tmp/flan-dev-break-fallback.sock")
(print (fetch 1)) (println "")

32
test/programs/dev-locals.flan
View File

@ -14,14 +14,30 @@
(defn look [n i64 label string] i64
(let [p (Point {.x 1.5 .y 2.5})
xs [10 20 30]
flag (> n 0)]
(restart-case
(do (error (Boom {.why 7}))
;; Never reached before the break, so [after] is a slot with nothing
;; in it: the frame records a null for it and this is what "not bound
;; yet" has to mean.
(let [after (i64 99)] after))
(carry-on [] 5))))
flag (> n 0)
;; Three bytes, for the three answers the character half has. A [u8]
;; already renders as text, so a lone byte showing only its number is
;; the one place the same data reads two ways — but only where a
;; person is inspecting. [println] of a u8 stays a number.
byte (u8 97) ; printable: 97 (\a)
gap (u8 32) ; one the reader names: 32 (\space)
ctl (u8 7)] ; no spelling: the number alone
;; A loop, for its hidden bound: [dotimes] allocates a slot nobody named,
;; and the listing must *hide* it rather than refuse it by an invented
;; name — [s6] is not a variable anyone can find in this file.
(dotimes [hop 0] (print ""))
;; And a shadowing rebind. The checker suffixes the repeat as [label~2]
;; so the debug info never claims one binding is the other; the listing
;; keeps both raw spellings, because two rows both called [label] with
;; nothing to tell them apart would be worse.
(let [label "inner"]
(restart-case
(do (error (Boom {.why 7}))
;; Never reached before the break, so [after] is a slot with nothing
;; in it: the frame records a null for it and this is what "not bound
;; yet" has to mean.
(let [after (i64 99)] after))
(carry-on [] 5)))))
(defvar ticks i64)

6
test/programs/generics.flan
View File

@ -175,6 +175,12 @@
(println (next-after (i64 10)))
(println (next-after 2.5))
(println (next-after (u8 254)))
;; A byte the reader *can* spell, printed rather than inspected. The
;; break loop and the inspector show this one as `97 (\a)' — a u8 is the
;; one type that reads two ways, and which way depends on who is looking.
;; Printing is the program talking, so it stays the number. 254 above
;; cannot tell the two apart, because 255 has no spelling either way.
(println (u8 97))
(println (plus-300 1))
;; And the prelude's own three, which are these bodies under their real

2
test/test_acceptance.ml
View File

@ -2662,7 +2662,7 @@ let () =
and which this does not second-guess. *)
let generics_out =
"3\n4.5\ntrue\n7\n5\n-1\n5\n42\n3\n1\n10\n1\n8\n\
true\ntrue\ntrue\ntrue\ntrue\ntrue\n4\n11\n3.5\n255\n301\n\
true\ntrue\ntrue\ntrue\ntrue\ntrue\n4\n11\n3.5\n255\n97\n301\n\
true\ntrue\nfalse\n\
3\n4.5\ntext\n1\n2.5\n9\n36\n2\n2.5\n0\n\
0\n-1\n2.5\n0\ntrue\nfalse\ntrue\n2\n0\n\

259
test/test_dev.ml
View File

@ -875,6 +875,21 @@ let () =
[ { Form.v = Form.Str "id"; _ }; { Form.v = Form.Str "i32"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "the stopped program's condition has the wrong layout");
(* And the value behind the shape: [fetch 1] built the condition, so
[.id] holds 1, and the daemon's thunk reads it out of the stopped
frame's own storage — a user [error], not a trap, so the same path
serves both. *)
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "condition values at a user error: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else
(match Wire.field r "fields" with
| Some { Form.v = Form.List [ { Form.v = Form.List
[ { Form.v = Form.Str "id"; _ }; { Form.v = Form.Str "i32"; _ };
{ Form.v = Form.Str "1"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "the condition's own field value did not render");
(* What is on offer, innermost first. [break] carries the names and
nothing else — the state is the annotation's business, so there is
one place in the daemon that decides it. *)
@ -1119,6 +1134,80 @@ let () =
(Option.value ~default:(status r) (Wire.string_field r "message"))
end
end;
(* ── ArithError, and the layout nobody can see both halves of ────
The other condition the runtime builds by hand. [flan_arith_cond]
is {i32 op; i64 lhs, rhs} in flan_rt.c and [(defstruct ArithError
[op i32 lhs i64 rhs i64])] in the prelude, and neither end can see
the other — the same hand-kept agreement [flan_name_id] has with
[Check.type_id]. It used to be read only by a handler that pulled
out one field; the break loop's render now walks all three, padding
included, so a drifted layout shows the op sitting in [lhs].
Driven from the editor rather than from main: [divide] holds a
restart-case, so the break has somewhere to go afterwards and the
daemon carries on. This is also the LLVM half of the site check —
an arith trap publishes its loc the same way a bounds trap does,
and the bad-index block below is x86. *)
(let r =
ask
"(:op \"eval-expr\" :code \"(divide (i64 1) (i64 0))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "a division by zero answered instead of stopping"
else if not (await (fun () -> stopped (ask "(:op \"describe\")"))) then
fail "a division by zero never stopped the program"
else begin
(match Wire.string_field (ask "(:op \"describe\")") "condition" with
| Some "ArithError" -> ()
| c ->
fail "a division by zero is reported as %S"
(Option.value ~default:"" c));
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "ArithError's fields: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
let fields =
match Wire.field r "fields" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
[ { Form.v = Form.Str n; _ };
{ Form.v = Form.Str ty; _ };
{ Form.v = Form.Str v; _ } ] -> Some (n, ty, v)
| _ -> None)
l
| _ -> []
in
(* op 0 is FLAN_ARITH_DIV_ZERO; lhs is the dividend and rhs the
divisor, which is the pair the unhandled message prints. Each
read at its own offset, so an i32 followed by two i64s is the
layout both ends have to agree on. *)
if
fields
<> [ ("op", "i32", "0"); ("lhs", "i64", "1"); ("rhs", "i64", "0") ]
then
fail "ArithError's rendered fields: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) fields))
end;
(* The site, on LLVM: an arith trap publishes its loc around the
hook exactly as a bounds trap does. *)
(match Wire.string_field (ask "(:op \"break\")") "site" with
| Some site when contains_sub site "dev-break.flan:" -> ()
| Some site -> fail "the arith site points at %s" site
| None -> fail "a division by zero carries no :site");
let r = ask "(:op \"restart\" :name \"use-zero\")" in
if status r <> "ok" then
fail "resuming past a division by zero: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program never resumed past a division by zero"
end);
(* ...and the other way out. Every check above is of an abort being
*refused*; the accepted path is the one that must not be left as code
that has never run, because it is the one that ends a program. Break
@ -1214,7 +1303,14 @@ let () =
in
let xpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-break-bounds.flan"; "-s"; xsock |]
(* [--x86] spelled out rather than taken from the default. It *is*
the default for [flan dev] (bin/main.ml), so this block has always
been the x86 side of the break loop — but the condition render,
the trap site and the nested-site check all live here, and which
backend they run under is the whole point of them. A default that
moves must not silently take this coverage with it; the LLVM side
of the same three is the break block above. *)
[| flan; "dev"; "programs/dev-break-bounds.flan"; "-s"; xsock; "--x86" |]
Unix.stdin xfd Unix.stderr
in
Unix.close xfd;
@ -1273,6 +1369,58 @@ let () =
if names <> [ "low"; "high"; "length" ] then
fail "BoundsError's fields: %s" (String.concat ", " names)
| _ -> fail "BoundsError's layout has no fields");
(* The values, not just the shape. The break loop stashed the pointer
it was handed, the daemon knows the type — it compiled it — and a
thunk it builds renders the fields in the stopped program. This is
what turns "BoundsError" into "9 is past the end of a length-4
array" in the buffer, with nothing special-casing BoundsError. *)
let r = ask "(:op \"condition\")" in
if status r <> "ok" then
fail "condition values: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
else begin
let fields =
match Wire.field r "fields" with
| Some { Form.v = Form.List l; _ } ->
List.filter_map
(fun (e : Form.t) ->
match e.Form.v with
| Form.List
[ { Form.v = Form.Str n; _ };
{ Form.v = Form.Str ty; _ };
{ Form.v = Form.Str v; _ } ] -> Some (n, ty, v)
| _ -> None)
l
| _ -> []
in
if
fields
<> [ ("low", "i64", "9"); ("high", "i64", "9");
("length", "i64", "4") ]
then
fail "the condition's fields: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) fields))
end;
(* Where the *expression* is. The frame lines say where each call was;
the trap's own loc is the only record of the indexing itself, and
[break] carries it with the line's text so a buffer can point at
the column Elm-style. *)
(let r = ask "(:op \"break\")" in
match Wire.string_field r "site" with
| None -> fail "break over a bad index carries no :site"
| Some site ->
let has hay needle =
let n = String.length hay and m = String.length needle in
let rec go i = i + m <= n && (String.sub hay i m = needle || go (i + 1)) in
m = 0 || go 0
in
if not (has site "dev-break-bounds.flan:") then
fail "the site does not point into the program: %s" site;
(match Wire.string_field r "source" with
| Some line when has line "(at grid i)" -> ()
| Some line -> fail "the site's source line reads %S" line
| None -> fail "break carries a :site but no :source line"));
(* Only the program's own restart is on offer. Nothing is pushed at the
failing index, so a list with anything else on it would mean a site
restart had been established after all. *)
@ -1289,6 +1437,34 @@ let () =
if names <> [ "continue" ] then
fail "restarts at a bad index: %s" (String.concat ", " names)
| _ -> fail "break over a bad index listed no restarts");
(* A break nested inside this one must not inherit the trap's site.
The fix-it-and-retry flow evaluates code *at* the bounds stop; if
that code raises its own error, its break has no trap behind it,
and a caret pointing at the outer stop's indexing under the inner
condition's name would be a plausible-looking lie. The site is
consumed by the snapshot that owns it. *)
let r =
ask
"(:op \"eval-expr\" :code \"(restart-case (do (error (BoundsError {.low 1 .high 2 .length 3})) (i64 0)) (back [] (i64 1)))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped inside the bounds break answered anyway";
(let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break inside the bounds break: %s" (status r)
else
match Wire.string_field r "site" with
| None -> ()
| Some site -> fail "the inner break inherited the trap's site: %s" site);
let r = ask "(:op \"restart\" :name \"back\")" in
if status r <> "ok" then
fail "resuming the inner break: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* Back on the outer break, whose own snapshot still holds its site. *)
if not
(await (fun () ->
let r = ask "(:op \"break\")" in
status r = "ok" && Wire.string_field r "site" <> None))
then fail "the outer bounds break lost its site after the inner one";
(* And the payoff: taking it resumes, which is the difference between a
stop you can recover from and a dead session. *)
let r = ask "(:op \"restart\" :name \"continue\")" in
@ -1573,12 +1749,41 @@ let () =
note here used to say was still owed. *)
("p", "Point", "(Point {.x 1.5 .y 2.5})");
("xs", "[3 i32]", "[ 10 20 30]");
("flag", "bool", "true") ]
("flag", "bool", "true");
(* The byte's character half, in the three shapes it has. The
spelling is one [lib/reader.ml]'s [read_byte] accepts, so
what is shown could be typed back; 7 has neither a name nor
a single-character spelling, so it stays a number rather
than growing an invented escape. *)
("byte", "u8", "97 (\\a)");
("gap", "u8", "32 (\\space)");
("ctl", "u8", "7");
(* [hop] is [dotimes]'s index and it is listed; the loop's
hidden bound sits in the very next slot and is *not* — a
compiler temp is hidden, not refused, because [s6] is not a
variable anyone can find in the file. *)
("hop", "i32", "0");
(* The shadowing rebind keeps its raw spelling here because the
outer [label] is on the same list: strip the suffix from one
and the frame shows two rows called [label] with nothing to
tell them apart. *)
("label~2", "string", "\"inner\"") ]
in
if got <> want then
fail "locals of the stopped frame: %s"
(String.concat ", "
(List.map (fun (n, ty, v) -> n ^ " " ^ ty ^ " = " ^ v) got));
(* No refusal mentions an invented name: the hidden bound must be
absent from both lists, not moved to the other one. *)
(match
List.filter
(fun (n, _, _) -> String.length n > 0 && n.[0] = 's')
(pairs r "refused")
with
| [] -> ()
| rs ->
fail "a compiler temp leaked into the refusals: %s"
(String.concat ", " (List.map (fun (n, _, _) -> n) rs)));
(* And the one that must not be rendered. [after] is bound inside
the restart-case *past* the error, so its slot is storage nothing
has written: the frame records a null for it, and a thunk that
@ -1629,7 +1834,11 @@ let () =
holding [p]'s value and nothing would say so. *)
let r =
ask
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0)] (restart-case (do (error (Boom {.why 7})) (let [after (i64 99)] after)) (carry-on [] 5))))\" :file \"/tmp/buf.flan\")"
(* Slot for slot with the body on the stack — three u8s included,
or the *count* would catch this and the fingerprint would go
untested. Every name differs and every type matches, which is
exactly what a count cannot see. *)
"(:op \"eval\" :code \"(defn look [n i64 label string] i64 (let [q (Point {.x 9.0 .y 9.0}) ys [1 2 3] mark (< n 0) ch (u8 98) sp (u8 33) cc (u8 8)] (dotimes [pip 0] (print \\\"\\\")) (let [tag \\\"x\\\"] (restart-case (do (error (Boom {.why 7})) (let [later (i64 99)] later)) (carry-on [] 5)))))\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing a renamed body while stopped: %s"
@ -4531,6 +4740,29 @@ let () =
l
| _ -> []
in
(* The condition's own fields, rendered under this backend. The thunk
reads them through [flan_agent_condition] at offsets the *x86*
backend laid out, and x86 tracks LLVM's observable behaviour: the
break block above renders a condition on LLVM, so this renders one
here, and the two must read alike. [look] signals (Boom {.why 7}),
so the number is the one the source wrote. *)
(let r = request c "(:op \"condition\")" in
if status r <> "ok" then fail "x86 condition: %s" (said r)
else
match Wire.field r "fields" with
| Some { Form.v = Form.List
[ { Form.v = Form.List
[ { Form.v = Form.Str "why"; _ };
{ Form.v = Form.Str "i32"; _ };
{ Form.v = Form.Str "7"; _ } ]; _ } ]; _ } -> ()
| _ -> fail "x86 condition did not render (Boom {.why 7})");
(* And a user [error] carries no site — there is no trapping
expression behind it — which is the same answer LLVM gives. Said
rather than left untested: the site is absent here for a reason,
not because this backend cannot produce one. *)
(match Wire.string_field (request c "(:op \"break\")") "site" with
| None -> ()
| Some site -> fail "an x86 user error carried a site: %s" site);
if status r <> "ok" then fail "x86 backtrace: %s" (said r)
else
(match frames with
@ -4574,7 +4806,18 @@ let () =
("label", "string", "\"hello\"");
("p", "Point", "(Point {.x 1.5 .y 2.5})");
("xs", "[3 i32]", "[ 10 20 30]");
("flag", "bool", "true") ]
("flag", "bool", "true");
(* And the byte's character half under this backend too: the
spelling table is the dev runtime's, but the slot the byte
is read from is x86's. *)
("byte", "u8", "97 (\\a)");
("gap", "u8", "32 (\\space)");
("ctl", "u8", "7");
(* Same two rows the LLVM listing pins: the loop index shown,
the loop's hidden bound hidden, the shadowing rebind kept
raw because the outer [label] is on the same list. *)
("hop", "i32", "0");
("label~2", "string", "\"inner\"") ]
in
let got = triples r "locals" in
if got <> want then
@ -4602,6 +4845,14 @@ 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 a byte by the same root: the inspector is the other place a
person is reading rather than the program printing, so it shows
the character half exactly as the listing does. Slot 5 is [byte]. *)
(let r = request c "(:op \"inspect\" :frame 0 :slot 5)" in
if status r <> "ok" then fail "x86 inspect of a byte: %s" (said r)
else if Wire.string_field r "value" <> Some "97 (\\a)" then
fail "x86 inspect of a byte 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

27
test/test_session.ml
View File

@ -1174,4 +1174,31 @@ let () =
| exception Loc.Error { Loc.dmsg = m; _ } ->
fail "a class and its caller evaluated together: %s" m);
(* ── What a slot is shown as ──────────────────────────────────────────
[strip_rebind] takes only a trailing ~N — [~] is the reader's delimiter
and a synthesized name like [destructure~nth] carries it for another
reason — and [shown_names] hides the unnamed temps while keeping both
raw spellings when a strip would put one name on two slots. The clean
strip is pinned here because end to end it is nearly unreachable: a
rebind's base name is almost always on the same list. *)
if Session.strip_rebind "r~2" <> "r" then
fail "r~2 did not strip to r";
if Session.strip_rebind "destructure~nth" <> "destructure~nth" then
fail "a non-numeric ~ suffix was stripped";
if Session.strip_rebind "r~" <> "r~" then fail "a bare trailing ~ was stripped";
if Session.strip_rebind "~2" <> "~2" then fail "a name that is only a suffix was stripped";
(let fn snames : Tast.fn =
{ Tast.name = "f"; params = []; ret = Types.Unit; body = [];
fdefers = []; fparent = None; floc = Loc.unknown;
slots = Array.make (Array.length snames) (Types.Int Types.I32);
snames }
in
(match Session.shown_names (fn [| Some "k~2"; None |]) with
| [| Some "k"; None |] -> ()
| _ -> fail "a lone rename did not show under its written name, temp hidden");
(match Session.shown_names (fn [| Some "v"; Some "v~2" |]) with
| [| Some "v"; Some "v~2" |] -> ()
| _ ->
fail "two slots that strip to one name did not keep their raw spellings"));
Test_support.report ~label:"session" ()

89
vendor/agent/flan_agent.c vendored
View File

@ -325,6 +325,12 @@ extern void *flan_dev_frame_slot(const void *frame, int32_t i);
extern const uint8_t *flan_restart_name(int32_t i, int64_t *len);
extern void *flan_restart_frame(int32_t i);
extern void flan_restart_take(void *frame, void *xfer);
/* Where the expression that trapped is written (runtime/flan_rt.c). Set by
* the trap sites around their call into the break hook and NULL otherwise,
* so it is read here exactly once, while the snapshot is being taken on the
* thread the trap stopped. */
extern const uint8_t *flan_break_site;
extern int64_t flan_break_site_len;
/* -- How far down a transfer can actually land ----------------------- */
@ -441,6 +447,18 @@ typedef struct {
int32_t fmine[FRAME_MAX]; /* 0 = the evaluation's, not the
* program's */
char ftext[FRAME_TEXT];
/* The condition this break was entered with, or NULL for a trap that
* carries none. An address into the signalling frame, which is live for
* exactly as long as this snapshot is on top — nothing unwound — so a
* render thunk aimed at it through [flan_agent_condition] reads storage
* that is still there. Never dereferenced here: its type is the daemon's
* to know, and rendering it is the daemon-built thunk's job. */
void *cond;
/* Where the expression that trapped is written, copied from the runtime's
* [flan_break_site] at the same held-still moment as everything else.
* Empty for a stop with no site — a user (error ...), a (pause). */
int32_t sitelen;
char site[512];
} snapshot;
/* One per nested break loop, because an inner break must not answer with the
@ -477,6 +495,17 @@ void *flan_agent_frame_slot(int64_t frame, int64_t slot) {
return flan_dev_frame_slot(s->fframe[frame], (int32_t)slot);
}
/* The condition this break holds, for the render thunk the daemon builds to
* show its fields. Same contract as [flan_agent_frame_slot]: called on the
* stopped game thread, resolved against the snapshot on top *when the thunk
* runs*, NULL for a break that carries none — and the daemon delivers the
* thunk at-stop, so a resume between the asking and the running drops it
* rather than rendering one break's type over another break's pointer. */
void *flan_agent_condition(void) {
snapshot *s = snap_top();
return s == NULL ? NULL : s->cond;
}
static snapshot *snap_top(void) {
int d = atomic_load(&snap_depth);
return d <= 0 ? NULL : &snaps[d - 1];
@ -486,13 +515,33 @@ static snapshot *snap_top(void) {
* to nest, which the caller reports rather than serving a stale one. */
static int32_t snap_gen; /* monotone; 0 is "no snapshot" */
static int snap_push(int resumable) {
static int snap_push(int resumable, void *cond) {
int d = atomic_load(&snap_depth);
if (d >= BREAK_MAX) return 0;
snapshot *s = &snaps[d];
int32_t n = flan_restart_count();
s->gen = ++snap_gen;
s->resumable = resumable;
s->cond = cond;
s->sitelen = 0;
if (flan_break_site != NULL && flan_break_site_len > 0) {
int64_t k = flan_break_site_len;
/* Truncation would be silent and would produce a *plausible* site — a
* path cut short still parses as one — so a site too long to hold is
* dropped instead. No site is a state the reader already handles; a
* wrong one is not. 512 is far past any real file:line:col. */
if (k > (int64_t)sizeof s->site) k = 0;
memcpy(s->site, flan_break_site, (size_t)k);
s->sitelen = (int32_t)k;
/* Consumed, not just read. The trap site clears the global when its hook
* returns — but this loop *is* the hook, so a break nested inside it (a
* fix candidate evaluated at a bounds stop raises its own error) would
* otherwise copy the outer trap's site under the inner condition's name,
* which is a caret pointing at an unrelated line. Each snapshot owns its
* copy; a nested entry that set no fresh site gets none. */
flan_break_site = NULL;
flan_break_site_len = 0;
}
s->total = n;
s->used = 0;
s->n = 0;
@ -563,10 +612,11 @@ static void snap_pop(void) {
if (d > 0) atomic_store(&snap_depth, d - 1);
}
/* The condition's class name, so an editor can say what stopped rather than
* only that something did. It is all there is to say: the hook is handed the
* name and an opaque pointer, and nothing at run time can render a value whose
* type it does not know. Written before [broken] is set and read only while
* [broken] is 1, so the listener never sees half of it. */
* only that something did. The pointer beside it goes into the snapshot: this
* side still cannot render a value whose type it does not know, but the
* daemon knows the type — it compiled it — and builds a thunk that reads the
* fields through [flan_agent_condition]. Written before [broken] is set and
* read only while [broken] is 1, so the listener never sees half of it. */
static char condition_name[128];
int32_t flan_agent_poll(void);
@ -651,7 +701,6 @@ static _Noreturn void die_now(void) {
static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
void *xfer, int resumable) {
struct timespec step = { 0, 2000000 }; /* 2ms */
(void)condition;
fflush(stdout);
fprintf(stderr, "\nflan: unhandled %.*s — stopped, not dead.\n",
(int)namelen, (const char *)name);
@ -660,7 +709,7 @@ static void break_loop_at(const uint8_t *name, int64_t namelen, void *condition,
* are then the same list, numbered the same way, and the numbers are what a
* choice is made of. */
int32_t my_gen;
if (!snap_push(resumable)) {
if (!snap_push(resumable, condition)) {
fflush(stdout);
fprintf(stderr, "flan: %d nested break loops - giving up rather than "
"spinning\n", BREAK_MAX);
@ -1010,6 +1059,32 @@ static void handle_line(char *line, sink *o) {
reply(o, "running\n");
return;
}
/* Whether the break on top holds a condition value a render thunk could be
* aimed at. [+] or [-] and nothing else: the pointer itself never crosses
* the wire — an address in another process's frame is not something the
* daemon can read — and the *type* is already answered by [status]. The
* daemon asks this before spending a build on a thunk that would render
* nothing. */
if (strcmp(line, "condition") == 0) {
if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; }
snapshot *s = snap_top();
if (s == NULL) { reply(o, "err no snapshot\n"); return; }
reply(o, s->cond != NULL ? "+\n" : "-\n");
return;
}
/* Where the expression that trapped is written — file:line:col, or [-] for
* a stop that has no site (a user (error ...), a (pause)). The frame lines
* say where each call was; this is the only record of the indexing or the
* division itself. */
if (strcmp(line, "site") == 0) {
if (!(atomic_load(&depth) > 0)) { reply(o, "err not stopped\n"); return; }
snapshot *s = snap_top();
if (s == NULL) { reply(o, "err no snapshot\n"); return; }
if (s->sitelen > 0) emit(o, s->site, (size_t)s->sitelen);
else reply(o, "-");
reply(o, "\n");
return;
}
/* One line per restart, innermost first: the index it is taken by, a flag
* for whether it can be taken at all, and the name. The index leads
* because it is the identity - two frames can offer [retry] and only one