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

A stopped program, driven from Emacs

Browse Source 
The break loop was reachable from a raw socket. This is the half that makes
it reachable from an editor, and it all follows from one fact: a program
stops at a moment nobody asked about.

So the state is learned twice, on purpose. It rides on every reply, beside
the program's output and for the same reason -- the likeliest instant for a
program to stop is the one just after an evaluation, which is a reply the
client is already reading, and learning it a second later from a poll would
mean learning it after the echo area had said the evaluation was fine. And a
timer asks anyway, once a second with `describe', because a program that
stops in a frame of its own game loop produces no reply at all and folding
state into replies that never come says nothing. The timer never reconnects
-- that would quietly erase the `lost' state that exists to be seen -- and
skips while a request is in flight, since accept-process-output runs timers
and a poll firing inside a read would eat that read's reply.

Three ops: `break' for the restart names, `restart' and `abort'. The
annotation owns :stopped and :condition rather than the ops, so one place in
the daemon decides whether the program is stopped and the poll and the prompt
cannot disagree. "ok" from `restart' means accepted, not resumed: the choice
is validated against the stopped stack and taken when that thread next comes
round, so it says so and the client clears its own flag rather than polling
once, finding it stopped, and re-opening the prompt it just answered.

The agent grew one verb, `status', answered in both states. Everything else
the break loop offers is refused while running, rightly; but the question an
editor asks without already knowing had to have an answer either way or there
would be nothing to poll.

And flan_agent_poll had to become re-entrant, which was a bug rather than an
addition. A C-x C-e thunk may itself error, and the break loop that catches
it polls again from inside that call. The old loop cached both indices and
stored tail at the end, rewinding over everything the nested poll consumed --
re-running the thunk that had just stopped the program, which is an unbounded
recursion of breaks. Each job is now claimed before it is run. test_dev.ml
evaluates an expression that errors and resumes it, which fails against the
old shape.
This commit is contained in:
Joseph Ferano 2026-09-11 19:39:29 +07:00
parent 386d9e0372
commit 5f4005e61d
9 changed files with 750 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

78
NEXT.md
View File

@ -874,6 +874,7 @@ of the protocol choice: `prin1` writes a request and `read` reads a reply.
| `C-c C-z` / `C-c C-q` | connect (finds `.flan-dev.sock` upward) / disconnect |
| `C-c C-o` | the running program's own output, in `*flan-output*` |
| `C-c C-r` | a prompt on the running program (`*flan-repl*`) |
| `C-c C-b` | what a **stopped** program is offering, and which to take |
| `C-c C-d` | what the running program currently defines |
| `M-.` / `M-,` | where a name is written, through an `xref` backend |
@ -1174,6 +1175,83 @@ restart stack to walk from a running one. `test/programs/break.flan` errors
twice and the test takes a *different* restart each time, so a loop that always
resumed the same way could not pass.
### The break loop in the editor — conditions step 3, the other half
The loop above is reachable from a raw socket. This is the half that makes it
reachable from Emacs, and the whole of it follows from one fact: **a program
stops at a moment nobody asked about.** Every other op in the protocol answers
a question an editor chose to ask.
So the state is learned **twice, deliberately**:
- **It rides on every reply**, beside the program's output and for the same
reason. `:stopped t :condition "Missing"`, or `:stopped nil`. The likeliest
instant for a program to stop is the one just after an evaluation — a body
that now errors — and that is a reply the client is already reading. Finding
out a second later from a poll would mean finding out *after* the echo area
had said the evaluation was fine.
- **And a timer asks anyway**, once a second, with `describe` — the cheap op,
which is also how the output pipe is drained. A program that stops in a frame
of its own game loop produces no reply at all, and folding state into replies
that never come says nothing. The timer never *reconnects*: `flan-dev--request`
reopens a socket a restarted daemon left behind, which is right for something
a person did and wrong for a background poll, because it would quietly erase
the `lost` state that exists to be seen. It also skips while another request
is in flight — `accept-process-output` runs timers, so a poll firing inside a
read would eat the reply that read was waiting for.
Three ops, and the *annotation* owns `:stopped`, not the ops — one place in the
daemon decides whether the program is stopped, so the poll and the prompt
cannot disagree.
```
(:op "break") → (:status "ok" :restarts ("retry" …) :stopped t :condition "Missing")
(:op "restart" :name "retry") → (:status "ok" :restart "retry" :note "accepted; …")
(:op "abort") → (:status "ok" :note "the program is exiting; …")
```
`break` carries only the restart names, because those cost a second round trip
to the program and are wanted only by someone about to choose one.
**`ok` from `restart` means accepted, not resumed.** The choice is validated on
the program's listener thread against the stopped stack, then taken when that
thread next comes round its loop. A client that read it as "running again"
would poll once, find it still stopped, and re-open the prompt it had just
answered — so the client clears its own flag and lets the next poll settle it.
The modeline is a fourth state, `flan:stopped(Missing)`, before `live`: a
stopped program looks exactly like a running one from anywhere else in Emacs.
The prompt is a `completing-read` over the names with `require-match`, which is
exactly right for a closed set the program computed, and `abort` is the last
entry on that same list rather than a second key — it is the thing you pick
when none of the restarts is the answer.
**`flan_agent_poll` had to become re-entrant**, and that is the one thing here
that was a bug rather than an addition. A `C-x C-e` thunk may itself error; the
break loop that catches it polls again from inside that very call. The old loop
cached `head` and `tail` and wrote `tail` back at the end, so the outer call
rewound the index over everything the nested one had consumed — and re-ran the
thunk that had just stopped the program, which is an unbounded recursion of
breaks rather than a stumble. It now claims each job by advancing `tail` before
running it, and re-reads both indices each time round. Still single-consumer:
only the game thread writes `tail`, nesting included. `test_dev.ml` evaluates an
expression that errors and resumes it, which fails against the old shape.
The agent grew one verb, `status`, answered in **both** states — `running` or
`stopped <condition>`. Everything else the break loop offers is refused while
running, and rightly; but the question an editor asks *without already knowing*
had to have an answer either way, or there would be nothing to poll. The
condition is its class name and nothing more: the hook is handed a name and an
opaque pointer, and nothing at run time can render a value whose type it does
not know.
`test/programs/dev-break.flan` stops on its first frame, so the daemon meets a
program that is *already* stopped — the state an editor has to cope with and the
hardest one to arrange later. The Emacs test breaks a program the other way
round, by installing a `step` that errors into a loop that calls it, fixes it
while stopped, and then resumes: `C-x C-e` answering while the program sits in
the break loop is checked there against the real client, not only in OCaml.
### Conditions — step 2: `restart-case` and `invoke-restart`
`spec-conditions.md` §3 to §6: the transfer. A handler runs where the signal

190
emacs/flan-dev.el
View File

@ -59,6 +59,17 @@ that quietly did nothing, which is why it is on."
(defvar flan-dev--socket nil
"Path of the socket `flan-dev--connection' is connected to.")
(defvar flan-dev--stopped nil
"Name of the condition the program is stopped on, or nil if it is running.
Set from every reply the daemon sends, which is how a stop that nothing
asked about is noticed at all.")
(defvar flan-dev--busy nil
"Non-nil while a request is waiting for its reply.
`flan-dev--read-reply' runs `accept-process-output', which runs timers, so
without this the poll timer could fire inside another request and read the
reply that request was waiting for.")
;;; Wire
;; Framing is a decimal byte count, a newline, then that many bytes. A message
@ -121,15 +132,87 @@ that quietly did nothing, which is why it is on."
;; scrolled back is reading something.
(when at-end (goto-char (point-max)))))))
(defun flan-dev--absorb (reply)
"Take from REPLY the two things every reply carries, and return it.
The program's output, and whether it is stopped. Both are read here rather
than at each call site because `flan-dev--report' signals on a rejection —
state attached to a reply that turns out to be an error would be thrown away
with it, and a rejected evaluation is a likely moment to *become* stopped."
(flan-dev--append-output (plist-get reply :output))
(let ((was flan-dev--stopped)
(now (and (plist-get reply :stopped)
(or (plist-get reply :condition) "a condition"))))
(setq flan-dev--stopped now)
(unless (equal was now)
(force-mode-line-update t)
;; Once, on the edge. A message every poll would bury whatever else the
;; echo area was saying, every second, for as long as the program sat
;; there.
(when now
(message "flan: stopped on %s — C-c C-b to choose a restart" now))))
reply)
(defun flan-dev--request (form)
"Send FORM to the connected program and return its reply."
(let* ((proc (flan-dev--live-connection))
(reply (progn (flan-dev--send proc form)
(flan-dev--read-reply proc))))
;; Whatever the program printed since the last reply rides along with this
;; one, so the output an evaluation itself caused arrives with its result.
(flan-dev--append-output (plist-get reply :output))
reply))
(flan-dev--busy t))
(flan-dev--absorb (progn (flan-dev--send proc form)
(flan-dev--read-reply proc)))))
;;; Noticing that the program stopped
;; A program can stop at any moment — that is the point of the break loop — and
;; nothing in a request/response protocol will say so unless something asks.
;; Both halves of the answer are here, and they are for two different moments:
;;
;; the state rides on every reply, because the likeliest instant for a
;; program to stop is the one just after an evaluation, and that is a reply
;; the client is already reading. Finding out a second later, from a poll,
;; would be finding out after the echo area had already said the evaluation
;; was fine;
;;
;; and a timer, because a program that stops while nobody is evaluating
;; anything — the ordinary way, in a frame of its own game loop — produces no
;; reply at all, and folding state into replies that never come says nothing.
;;
;; The timer does not reconnect. `flan-dev--request' reopens a socket the
;; daemon restarted under it, which is right for something a person did and
;; wrong for a background timer: it would quietly erase the `lost' state that
;; exists to be seen. So the timer sends on the live process or does nothing.
(defcustom flan-dev-poll-interval 1.0
"Seconds between background checks of whether the program has stopped.
Set to nil to leave the program's state to whatever replies happen to say."
:type '(choice number (const :tag "Never" nil)))
(defvar flan-dev--timer nil
"The background poll, or nil.")
(defun flan-dev--poll ()
"Ask the daemon how the program is, if it is safe to ask right now."
(when (and (not flan-dev--busy)
(process-live-p flan-dev--connection))
(let ((proc flan-dev--connection)
(flan-dev--busy t))
(ignore-errors
;; `describe' rather than `break': it is the cheap op, it is what
;; drains the program's output, and the state is on every reply anyway.
;; Asking `break' would fetch restart names nobody is choosing from.
(flan-dev--send proc '(:op "describe"))
(flan-dev--absorb (flan-dev--read-reply proc))))))
(defun flan-dev--start-polling ()
"Begin watching for the program stopping."
(flan-dev--stop-polling)
(when flan-dev-poll-interval
(setq flan-dev--timer
(run-with-timer flan-dev-poll-interval flan-dev-poll-interval
#'flan-dev--poll))))
(defun flan-dev--stop-polling ()
"Stop watching."
(when flan-dev--timer (cancel-timer flan-dev--timer))
(setq flan-dev--timer nil))
;;; Connection
@ -153,6 +236,8 @@ that quietly did nothing, which is why it is on."
:name "flan-dev" :buffer buf :family 'local :service socket
:coding 'binary :noquery t))
(setq flan-dev--socket socket))
(setq flan-dev--stopped nil)
(flan-dev--start-polling)
(force-mode-line-update t)
flan-dev--connection)
@ -221,6 +306,8 @@ With no argument, look for `flan-dev-socket-name' up from this buffer."
;; Forgotten, not kept: this was a deliberate disconnect, so the next
;; request should say so rather than quietly reopening what was just closed.
(setq flan-dev--socket nil)
(setq flan-dev--stopped nil)
(flan-dev--stop-polling)
(flan-dev--forget-defs)
(force-mode-line-update t)
(message "flan dev: disconnected"))
@ -239,11 +326,18 @@ With no argument, look for `flan-dev-socket-name' up from this buffer."
"Face for the modeline indicator when the daemon has gone away."
:group 'flan-dev)
(defface flan-dev-stopped-face '((t :inherit error))
"Face for the modeline indicator when the program is stopped at a break."
:group 'flan-dev)
(defun flan-dev-state ()
"Whether a program is connected: `live', `lost', or `off'.
"Whether a program is connected: `stopped', `live', `lost', or `off'.
`lost' means there was one and the daemon is gone — a restart away, not a
mistake, so it is distinguished from never having connected."
(cond ((process-live-p flan-dev--connection) 'live)
mistake, so it is distinguished from never having connected. `stopped' is a
live program sitting in the break loop on an unhandled condition, which is
every bit as connected and nothing like running."
(cond ((and (process-live-p flan-dev--connection) flan-dev--stopped) 'stopped)
((process-live-p flan-dev--connection) 'live)
(flan-dev--socket 'lost)
(t 'off)))
@ -251,6 +345,13 @@ mistake, so it is distinguished from never having connected."
"The Flan connection indicator, for `mode-line-misc-info'."
(when (derived-mode-p 'flan-mode 'flan-repl-mode)
(pcase (flan-dev-state)
;; First, and it names the condition: a stopped program looks exactly
;; like a running one from anywhere else in Emacs, and the whole reason
;; the break loop is worth having is that someone notices it.
('stopped (propertize (format " flan:stopped(%s)" flan-dev--stopped)
'face 'flan-dev-stopped-face
'help-echo
"Stopped on an unhandled condition; C-c C-b to choose a restart"))
('live (propertize " flan:live" 'face 'flan-dev-live-face
'help-echo (format "Connected to %s" flan-dev--socket)))
('lost (propertize " flan:lost" 'face 'flan-dev-lost-face
@ -266,6 +367,77 @@ mistake, so it is distinguished from never having connected."
;; file at all. The `derived-mode-p' guard above stays anyway: cheap, and it
;; keeps the function honest wherever it is called from.
;;; The break loop
;; What a stopped program is for. The condition is the class name and nothing
;; more — the hook is handed a name and an opaque pointer, and nothing at run
;; time can render a value whose type it does not know — and the restarts are
;; the names the frames between the error and the top are offering, innermost
;; first. `completing-read' over them is the natural shape: they are a closed
;; set the program computed, so require-match is exactly right.
;;
;; `abort' is on the same list rather than on a separate key, because it is the
;; same decision: it is what you pick when none of the restarts is the answer.
;; It is last, and it is not the default.
(defun flan-dev-restart (name)
"Resume the stopped program at the restart called NAME."
(interactive (list (completing-read "Restart: " (flan-dev-restarts) nil t)))
(let ((r (flan-dev--request (list :op "restart" :name name))))
(if (equal (plist-get r :status) "ok")
(progn
;; Accepted, not resumed: the choice is validated against the stopped
;; thread's stack and taken when that thread next comes round its
;; loop. It is therefore still stopped as this reply is written, and
;; believing the reply's `:stopped' would leave the modeline saying
;; so until the poll after the one that agreed. Cleared here and
;; re-established by the next poll if the program is somehow still
;; there.
(setq flan-dev--stopped nil)
(force-mode-line-update t)
(message "flan: %s — %s" name
(or (plist-get r :note) "accepted")))
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
(defun flan-dev-abort ()
"Let the stopped program die where it stopped.
This ends `flan dev' too: the daemon owns the program's lifetime and has
nothing left to serve once it has gone."
(interactive)
(let ((r (flan-dev--request '(:op "abort"))))
(if (equal (plist-get r :status) "ok")
(progn (setq flan-dev--stopped nil)
(force-mode-line-update t)
(message "flan: %s" (or (plist-get r :note) "aborted")))
(user-error "flan: %s" (or (plist-get r :message) "refused")))))
(defun flan-dev-restarts ()
"The restart names the stopped program is offering, innermost first."
(let ((r (flan-dev--request '(:op "break"))))
(unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "refused")))
(plist-get r :restarts)))
;;;###autoload
(defun flan-break ()
"Show what the stopped program is offering, and choose one.
Refuses while the program is running, by name: there is no restart stack to
walk from a running program, and a prompt with nothing behind it is worse
than being told so."
(interactive)
(let* ((r (flan-dev--request '(:op "break"))))
(unless (equal (plist-get r :status) "ok")
(user-error "flan: %s" (or (plist-get r :message) "refused")))
(unless flan-dev--stopped
(user-error "flan: the program is running; nothing is stopped"))
(let* ((restarts (plist-get r :restarts))
(choice
(completing-read
(format "flan: stopped on %s%s — " flan-dev--stopped
(if restarts "" " (no restarts are active)"))
(append restarts '("abort")) nil t)))
(if (equal choice "abort") (flan-dev-abort) (flan-dev-restart choice)))))
;;;###autoload
(defun flan-show-output ()
"Show the running program's output, after collecting anything pending."

1
emacs/flan-mode.el
View File

@ -80,6 +80,7 @@
(define-key map (kbd "C-c C-d") #'flan-describe)
(define-key map (kbd "C-c C-o") #'flan-show-output)
(define-key map (kbd "C-c C-r") #'flan-repl)
(define-key map (kbd "C-c C-b") #'flan-break)
map)
"Keymap for `flan-mode'.")

92
emacs/test-flan-dev.el
View File

@ -367,8 +367,100 @@ is written instead — the real `message' call the real command makes."
(test-flan--check "and the prompt got the value, not the text"
(string-match-p "()" (buffer-string))))
;; ── The break loop ────────────────────────────────────────────────────
;;
;; An unhandled `error' stops the program on the frame that erred instead of
;; killing it, and this is the half of that an editor sees: it has to notice
;; without being told, say what stopped it, offer the restarts, and keep
;; working while the program sits there. Last in this file because the
;; program is left running afterwards but its `step' has been through a
;; break, and nothing above should have to reason about that.
;; Refused while it is running, by name. There is no restart stack to walk
;; from a running program, and an empty prompt would be worse than a refusal.
(let ((raised nil))
(condition-case err (flan-break)
(user-error (setq raised (error-message-string err))))
(test-flan--check "the prompt refuses while the program is running"
(and raised (string-match-p "running" raised))))
;; The poll is a real timer, registered on connect. What it *does* is
;; checked below by calling it; that it is scheduled at all is checked here,
;; because a background discovery that nothing ever runs discovers nothing.
(test-flan--check "a poll timer is running"
(and (timerp flan-dev--timer)
(eq (timer--function flan-dev--timer) #'flan-dev--poll)))
;; 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.
(flan-dev--eval
"(defn step [] i64 (restart-case (do (error (Missing {:id 7})) 0) (use-placeholder [] -1)))"
"form")
(let ((deadline (+ (float-time) 20)))
(while (and (not flan-dev--stopped) (< (float-time) deadline))
(flan-dev--poll)
(accept-process-output nil 0.05)))
(test-flan--check "the client notices a stop nobody asked about"
(equal flan-dev--stopped "Missing"))
(test-flan--check "and the modeline says so, with the condition"
(and (eq (flan-dev-state) 'stopped)
(string-match-p "stopped" (flan-dev-mode-line))
(string-match-p "Missing" (flan-dev-mode-line))))
;; What the prompt would offer. `completing-read' is not driven here — a
;; minibuffer in a batch run is a hang waiting to happen — so the list it
;; reads and the two commands it dispatches to are exercised instead.
(test-flan--check "the restarts on offer are the ones the frame declared"
(equal (flan-dev-restarts) '("use-placeholder")))
;; The payoff. The break loop *is* the poll loop, so an expression sent now
;; runs on the stopped thread and comes back — which is the one moment
;; anybody actually wants C-x C-e to work.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 20 3)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "C-x C-e works while the program is stopped"
(and said (string-match-p "23" said))))
(delete-region beg (point-max)))
;; 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
;; replaced here, and the resume below returns into the old one for the last
;; time before every later call reaches the new body through its cell.
(let ((said (test-flan--said
(flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 1)) ticks)"
"form"))))
(test-flan--check "a fix installs while the program is stopped"
(and said (string-match-p "\\_<step\\_>" said))))
;; Choosing one. "ok" from the daemon means accepted — the stopped thread
;; takes it on its next pass — so the client stops claiming a break and lets
;; the next poll settle it.
(flan-dev-restart "use-placeholder")
(let ((deadline (+ (float-time) 20)))
(while (and (not (eq (flan-dev-state) 'live)) (< (float-time) deadline))
(flan-dev--poll)
(accept-process-output nil 0.05)))
(test-flan--check "choosing a restart resumes the program"
(and (null flan-dev--stopped)
(eq (flan-dev-state) 'live)))
;; ...and the client is an ordinary client again on the far side of it.
(goto-char (point-max))
(let ((beg (point)))
(insert "\n(+ 1 1)")
(let ((said (test-flan--said (flan-eval-last-sexp))))
(test-flan--check "and everything works again afterwards"
(and said (string-match-p "2" said))))
(delete-region beg (point-max)))
(flan-disconnect)
(test-flan--check "disconnected" (not (process-live-p flan-dev--connection)))
(test-flan--check "and the poll timer is cancelled with it"
(null flan-dev--timer))
(if (zerop test-flan--failures)
(message "flan-dev.el: all tests passed")

148
lib/dev.ml
View File

@ -126,6 +126,73 @@ let result t =
| None -> None)
| _ -> None))
(* ── The break state ───────────────────────────────────────────────── *)
(* Everything above is about changing a *running* program. This is the other
half: an unhandled [error] does not kill a dev build, it stops the game
thread on the frame that erred and waits. The agent's socket is where that
shows, and the daemon is the only thing holding that socket — so an editor
asks here or not at all.
One line out, one line back, exactly like [result]: the agent is not a
protocol and must not become one. *)
let ask t verb =
let s = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in
Fun.protect
~finally:(fun () -> try Unix.close s with Unix.Unix_error _ -> ())
(fun () ->
Unix.connect s (Unix.ADDR_UNIX t.agent);
let msg = verb ^ "\n" in
ignore (Unix.write_substring s msg 0 (String.length msg));
let b = Bytes.create 4096 in
let buf = Buffer.create 128 in
let rec drain () =
match Unix.read s b 0 4096 with
| 0 -> ()
| n -> Buffer.add_subbytes buf b 0 n; drain ()
| exception Unix.Unix_error _ -> ()
in
drain ();
Buffer.contents buf)
type state =
| Running
| Stopped of string (* the condition's class name *)
| Unreachable of string (* no answer: exited, or never listened *)
(* [status] is answered whether or not the program is stopped — "running" is an
answer, not a refusal. Everything else the break loop offers is refused
while running, and rightly: there is no restart stack to walk. But the
question an editor asks *without already knowing* is this one, so it had to
have an answer in both states or there would be nothing to poll. *)
let state t =
match ask t "status" with
| "" -> Unreachable "the program is not answering on its socket"
| text ->
let line = String.trim (List.hd (String.split_on_char '\n' text)) in
if line = "running" then Running
else if String.length line > 8 && String.sub line 0 8 = "stopped " then
Stopped (String.sub line 8 (String.length line - 8))
else Unreachable ("the program answered " ^ line)
| exception Unix.Unix_error (e, _, _) -> Unreachable (Unix.error_message e)
(* Innermost first, terminated by a line that is a single dot — the agent's
framing, not this one's. A refusal comes back as a line starting "err ", and
is passed on rather than turned into an empty list: no restarts and cannot
say are different answers. *)
let restarts t =
match ask t "restarts" with
| text ->
let lines = String.split_on_char '\n' text in
if List.exists (fun l -> String.length l >= 3 && String.sub l 0 3 = "err") lines
then Error (String.trim text)
else
Ok
(List.filter
(fun l -> l <> "" && l <> ".")
(List.map String.trim lines))
| exception Unix.Unix_error (e, _, _) -> Error (Unix.error_message e)
let alive t =
match Unix.waitpid [ Unix.WNOHANG ] t.child with
| 0, _ -> true
@ -149,6 +216,28 @@ let with_output t reply =
let i = String.length reply - 1 in
String.sub reply 0 i ^ " :output " ^ Wire.quote text ^ ")"
(* The break state rides along with every reply, exactly as the program's own
output does, and for the same reason: a program can stop at any moment and
nothing in a request/response protocol will mention it unless every response
does. An editor that had to *ask* would find out about a stop only when it
happened to wonder — and the most common moment for a program to stop is the
instant after an evaluation, which is a reply it is already reading.
It is the annotation, not the ops, that decides these two fields, so that
there is one place in the daemon that says whether the program is stopped
and the break ops cannot disagree with the poll. *)
let with_break t reply =
let fields =
match state t with
| Stopped c -> " :stopped t :condition " ^ Wire.quote c
| Running -> " :stopped nil"
(* Unreachable is not "running": the honest shape of "it exited" is
[:alive nil] from [describe], and claiming a state we could not read
would be the [ok]-means-probably failure in miniature. *)
| Unreachable _ -> " :stopped nil"
in
String.sub reply 0 (String.length reply - 1) ^ fields ^ ")"
let error ?loc msg =
"(:status \"error\" :message " ^ Wire.quote msg
^ (match loc with None -> "" | Some l -> " :loc " ^ Wire.quote l)
@ -294,6 +383,57 @@ let defs t =
in
ok [ ":defs " ^ Wire.list (fns @ globals @ externs) ]
(* What is on offer where the program stopped. [:stopped] and [:condition] are
not here: the annotation puts them on this reply as it puts them on every
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. *)
let break t =
if not (alive t) then error "the program exited; restart flan dev"
else
match state t with
| Running -> ok []
| Unreachable m -> error ("cannot ask the program whether it stopped: " ^ m)
| Stopped _ ->
(match restarts t with
| Ok names -> ok [ ":restarts " ^ Wire.strings names ]
| Error m -> error ("the program refused to list its restarts: " ^ m))
(* A choice is validated by the *program*, on its listener thread, against a
stack the stopped game thread is holding still — not here. The daemon has no
copy of that stack and anything it checked would be a guess that was true a
moment ago.
"ok" therefore means accepted, and says so: the resume happens when the
stopped thread next comes round its loop, which is microseconds away and
still not now. An editor that read [ok] as "running again" would poll once,
find it stopped, and re-open the prompt it had just answered. *)
let choose t ~name =
if not (alive t) then error "the program exited; restart flan dev"
else
match ask t ("restart " ^ name) with
| reply when String.trim reply = "ok" ->
ok
[ ":restart " ^ Wire.quote name;
":note "
^ Wire.quote "accepted; the program resumes at its next pass of the break loop" ]
| reply -> error (String.trim reply)
| exception Unix.Unix_error (e, _, _) ->
error ("cannot reach the program: " ^ Unix.error_message e)
(* The other way out. The program exits 134 where it stopped, which ends this
daemon too — it owns the program's lifetime and has nothing left to serve.
Refused while running, by the program, for the same reason a restart is. *)
let abort t =
if not (alive t) then error "the program exited; restart flan dev"
else
match ask t "abort" with
| reply when String.trim reply = "ok" ->
ok [ ":note " ^ Wire.quote "the program is exiting; flan dev ends with it" ]
| reply -> error (String.trim reply)
| exception Unix.Unix_error (e, _, _) ->
error ("cannot reach the program: " ^ Unix.error_message e)
let handle t req =
match Wire.string_field req "op" with
| Some "eval" ->
@ -314,6 +454,12 @@ let handle t req =
| None -> error "eval-expr needs :code")
| Some "describe" -> describe t
| Some "defs" -> defs t
| Some "break" -> break t
| Some "restart" ->
(match Wire.string_field req "name" with
| Some name -> choose t ~name
| None -> error "restart needs :name")
| Some "abort" -> abort t
| Some "close" -> ok []
| Some op -> error ("unknown op: " ^ op)
| None -> error "no :op"
@ -336,7 +482,7 @@ let serve t fd =
| req -> (Wire.string_field req "op", handle t req)
| exception Loc.Error (_, m) -> (None, error ("bad request: " ^ m))
in
Wire.send fd (with_output t reply);
Wire.send fd (with_output t (with_break t reply));
if op = Some "close" then true else go ()
| exception Wire.Closed -> false
| exception Unix.Unix_error _ -> false

33
test/programs/dev-break.flan Normal file
View File

@ -0,0 +1,33 @@
;;;; A program that stops, for driving the break loop from an editor.
;;;;
;;;; It errors on its first frame, with nothing having handled the condition,
;;;; so [flan dev] meets a program that is already stopped — which is the state
;;;; an editor has to cope with, and the one that is hardest to arrange on
;;;; purpose later. Two restarts are on offer and they return different values,
;;;; so the transcript says which one was chosen.
;;;;
;;;; After resuming it keeps polling, because the claim worth testing is that
;;;; everything else still works on either side of a break.
(import agent "vendor:agent")
(defstruct Missing [id i32])
(defn fetch [n i32] i32
(restart-case
(do (error (Missing {:id n})) 0)
(use-placeholder [] -1)
(retry [] 7)))
(defvar ticks i64)
(defn step [] i64
(set ticks (+ ticks 1))
ticks)
(defn main [] i32
(agent/start "/tmp/flan-dev-break-fallback.sock")
(print-i64 (i64 (fetch 1))) (newline)
(dotimes [i 4000]
(agent/wait 5)
(set ticks (step)))
0)

5
test/programs/dev-repl.flan
View File

@ -6,6 +6,11 @@
;;;; of nothing, which is what a frame is when there is no frame.
(import agent "vendor:agent")
;;; A condition, so that a body typed in later can error and stop the program
;;; where an editor can see it. It is here rather than in the evaluated form
;;; because the break loop matches on a class the *host* was compiled with.
(defstruct Missing [id i32])
(defvar ticks i64)
(defn step [] i64
(set ticks (+ ticks 1))

174
test/test_dev.ml
View File

@ -204,7 +204,179 @@ let () =
fail "program transcript\n got: %S\n wanted: %S" text wanted
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ sock; out ];
(* ── The break loop, from the editor's side ────────────────────── *)
(* A second daemon, over a program that stops on its first frame. The
claims are that an editor can find out it stopped without having been
told, that everything an editor does still works while it is stopped —
C-x C-e most of all, since the break loop *is* the poll loop — and that
a choice comes back refused or accepted, never "probably".
Its own daemon, its own program and its own output buffer: the block
above ends by checking a transcript, and sharing either with this would
make that check about two programs at once. *)
let bsock = tmp "break.sock" and bout = tmp "break.out" in
(try Sys.remove bsock with Sys_error _ -> ());
let bfd = Unix.openfile bout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let bpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-break.flan"; "-s"; bsock |]
Unix.stdin bfd Unix.stderr
in
Unix.close bfd;
if not (await (fun () -> Sys.file_exists bsock)) then begin
fail "the break daemon never listened";
(try Unix.kill bpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let boutput = Buffer.create 256 in
let c = connect bsock in
let ask sexp =
let r = Wire.parse (Wire.send c sexp; Wire.recv c) in
(match Wire.string_field r "output" with
| Some t -> Buffer.add_string boutput t
| None -> ());
r
in
(* [:stopped] is on every reply, whatever was asked. An editor that had
to ask would find out only when it happened to wonder, and a program
stops at moments nobody is wondering about. *)
let stopped r =
match Wire.field r "stopped" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let condition r =
match Wire.string_field r "condition" with Some c -> c | None -> ""
in
let last = ref (ask "(:op \"describe\")") in
if not (await (fun () -> last := ask "(:op \"describe\")"; stopped !last))
then fail "a stopped program never said so on a reply it was already sending"
else begin
if condition !last <> "Missing" then
fail "the condition is reported as %S, wanted %S" (condition !last)
"Missing";
(* 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. *)
let r = ask "(:op \"break\")" in
if status r <> "ok" then fail "break: %s" (status r);
(match Wire.field r "restarts" with
| Some { Form.v = Form.List names; _ } ->
let names =
List.filter_map
(fun (n : Form.t) ->
match n.Form.v with Form.Str s -> Some s | _ -> None)
names
in
if names <> [ "retry"; "use-placeholder" ] then
fail "restarts on offer: %s" (String.concat ", " names)
| _ -> fail "break did not list the restarts");
(* The payoff. The break loop is the poll loop, so an expression
evaluated here is a module the listener queues and the *stopped*
thread runs — which is the only reason C-x C-e works at the one
moment anybody wants it to. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 20 3)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "23" then
fail "C-x C-e while stopped: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* And installing, which the break loop deliberately allows: there is
no frame in progress, so the rule about swapping a body that is on
the stack does not apply. This is the fix-it-and-retry loop. *)
let r =
ask
"(:op \"eval\" :code \"(defn step [] i64 (set ticks (+ ticks 100)) ticks)\" :file \"/tmp/buf.flan\")"
in
if status r <> "ok" then
fail "installing while stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* A name nothing offers is refused against the live stack, on the
program's listener thread, before the reply. *)
let r = ask "(:op \"restart\" :name \"nonesuch\")" in
if status r <> "error" then fail "a restart nobody offers was accepted";
let r = ask "(:op \"restart\" :name \"retry\")" in
if status r <> "ok" then
fail "choosing a restart: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
(* [retry] returns 7 and [use-placeholder] returns -1, so the number in
the transcript is the proof that this choice and not the other one
was taken. *)
let printed () =
ignore (ask "(:op \"describe\")");
List.exists (String.equal "7")
(String.split_on_char '\n' (Buffer.contents boutput))
in
if not (await printed) then fail "the chosen restart never resumed";
(* Running again, and now every break verb is refused by name. There is
no restart stack to walk from a running program, and answering an
empty list would read as "no restarts are active". *)
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the program still reads as stopped after resuming"
else begin
let r = ask "(:op \"restart\" :name \"retry\")" in
if status r <> "error" then
fail "a restart was accepted by a running program";
let r = ask "(:op \"abort\")" in
if status r <> "error" then
fail "an abort was accepted by a running program";
(* ...and an ordinary evaluation works again on the far side of it. *)
let r =
ask "(:op \"eval-expr\" :code \"(+ 1 1)\" :file \"/tmp/buf.flan\")"
in
if Wire.string_field r "value" <> Some "2" then
fail "an expression after the break: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"));
(* An expression that stops *itself*. The thunk runs on the game
thread from inside a poll, and the break loop it lands in polls
again from inside that very call — so the agent's poll has to be
re-entrant. One that cached its indices and wrote them back at the
end would rewind over everything the nested poll consumed and run
this same thunk again, which is not a stumble but an unbounded
recursion of breaks.
The evaluation cannot answer from in there and says so, with the
reason, rather than waiting forever or claiming a value. *)
let r =
ask
"(:op \"eval-expr\" :code \"(i64 (fetch 2))\" :file \"/tmp/buf.flan\")"
in
if status r <> "error" then
fail "an expression that stopped the program answered anyway";
if not (stopped r) then
fail "an expression that stopped the program did not report it";
let r = ask "(:op \"restart\" :name \"use-placeholder\")" in
if status r <> "ok" then
fail "resuming an expression that stopped: %s"
(Option.value ~default:"" (Wire.string_field r "message"));
if not (await (fun () -> not (stopped (ask "(:op \"describe\")")))) then
fail "the stopped expression never resumed"
else
let r =
ask "(:op \"eval-expr\" :code \"(+ 2 2)\" :file \"/tmp/buf.flan\")"
in
(* Still there, and evaluating once per evaluation: a thunk run
twice by a rewound queue would have broken a second time. *)
if Wire.string_field r "value" <> Some "4" then
fail "an expression after a break inside a thunk: %s"
(Option.value ~default:(status r) (Wire.string_field r "message"))
end
end;
ignore (ask "(:op \"close\")");
Unix.close c;
ignore (Unix.waitpid [] bpid)
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ];
if !failures = 0 then print_endline "dev: all tests passed"
else begin
Printf.printf "\n%d failure(s)\n" !failures;

46
vendor/agent/flan_agent.c vendored
View File

@ -110,6 +110,12 @@ static _Atomic int broken; /* the game thread is in the loop */
static char chosen[128];
static _Atomic int chosen_ready;
static _Atomic int aborting;
/* 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. */
static char condition_name[128];
int32_t flan_agent_poll(void);
@ -132,6 +138,14 @@ static void break_loop(const uint8_t *name, int64_t namelen, void *condition,
}
}
fflush(stderr);
{
size_t k = namelen < 0 ? 0 : (size_t)namelen;
if (k >= sizeof condition_name) k = sizeof condition_name - 1;
memcpy(condition_name, name, k);
condition_name[k] = '\0';
}
/* Published last: the name has to be whole before anything advertises that
* there is one to read. */
atomic_store(&broken, 1);
for (;;) {
flan_agent_poll();
@ -157,20 +171,27 @@ static void break_loop(const uint8_t *name, int64_t namelen, void *condition,
}
}
/* Re-entrant, and it has to be: a thunk this runs may itself error, and the
* break loop that catches it polls again from inside that very call. So a job
* is *claimed* — tail advanced past it — before it is run, and both indices
* are re-read each time round rather than cached across the work. Caching them
* and storing tail at the end would rewind it over everything the nested poll
* consumed, and running a C-x C-e thunk a second time is the one thing the
* whole dev loop is careful never to do. Still single-consumer: only the game
* thread writes tail, nesting included. */
int32_t flan_agent_poll(void) {
unsigned t = atomic_load_explicit(&tail, memory_order_relaxed);
unsigned h = atomic_load_explicit(&head, memory_order_acquire);
int32_t n = 0;
while (t != h) {
for (;;) {
unsigned t = atomic_load_explicit(&tail, memory_order_relaxed);
unsigned h = atomic_load_explicit(&head, memory_order_acquire);
if (t == h) return n;
job j = queue[t % QUEUE];
t++;
atomic_store_explicit(&tail, t + 1, memory_order_relaxed);
if (j.install != NULL) { j.install(); n++; }
/* After the install, so a thunk sees the bodies its own module published. */
if (j.call != NULL) { j.call(); }
if (j.handle != NULL) { dlclose(j.handle); }
}
atomic_store_explicit(&tail, t, memory_order_relaxed);
return n;
}
/* The same, but waits up to [ms] for something to arrive first. A game loop
@ -225,6 +246,19 @@ static void serve(int fd) {
/* Only while stopped: what is on offer, and which one to take. Both are
* refused when the program is running, by name, rather than silently
* doing nothing — there is no restart stack to walk from here. */
/* Whether the program is stopped, and on what. Answered while it is
* running too — "running" is an answer, not a refusal — because this is
* the one question an editor asks without knowing the state already, and
* refusing it would leave nothing to poll. */
if (strcmp(line, "status") == 0) {
if (atomic_load(&broken)) {
reply(fd, "stopped ");
reply(fd, condition_name);
reply(fd, "\n");
} else
reply(fd, "running\n");
return;
}
if (strcmp(line, "restarts") == 0) {
if (!atomic_load(&broken)) { reply(fd, "err not stopped\n"); return; }
int32_t n = flan_restart_count();