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

The editor protocol never waits for the agent, and a parked delivery installs first

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-20 19:27:12 +07:00
commit b87ae11fa8
4 changed files with 559 additions and 73 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

225
lib/dev.ml
View File

@ -52,6 +52,18 @@ type t = {
The merged build keeps fd 1 open across runs now and is asked instead — The merged build keeps fd 1 open across runs now and is asked instead —
see [liveness] and [Program.state]. *) see [liveness] and [Program.state]. *)
mutable finished : bool; mutable finished : bool;
(* When to start saying that the program has not bound [agent] — and [None]
once it has, or once that has been said. The merged session arms it and
nothing gates on it: see [agent_check] for why this is a clock a reply
passes rather than a wait the session does before it serves anything. *)
mutable agent_watch : float option;
(* Whether the long note about a delivery to a parked program has been said
for *this* park. A finished program is parked, so re-evaluating while one
is on the screen says it on every C-c C-c; the explanation is worth one
reading and not twenty. Cleared whenever the program is seen running
again ([eval]) and when a re-run is accepted ([rerun]), so the next park
is a new one and gets the whole sentence. *)
mutable park_noted : bool;
} }
(* The program's stdout is a pipe into this process, so that an editor can see (* The program's stdout is a pipe into this process, so that an editor can see
@ -106,6 +118,48 @@ let await ?(ms = 5000) f =
in in
go ms go ms
(* Whether the program has bound the socket it receives modules on.
Cheap enough to ask on every reply — one [stat] — and asked rather than
remembered because the answer moves in one direction at a moment this side
does not get to see: [agent/start] runs on the program's own thread. *)
let agent_bound t = Sys.file_exists t.agent
(* And the clock that says so out loud, once.
This used to be a [await ~ms:10000] in [merged_serve], *before* the accept
loop was started — so a program that called [agent/start] late, or not at
all, cost every editor request up to ten seconds of silence at the start of
a session. The wait was never what made the editor protocol work: nothing
the editor asks needs the program's socket, because in one process the
compiler reaches the agent by calling it ([Agent.request]), and the
two-process daemon has already waited for the bind in [two_process] and
fails if it never comes. What the wait was for is the *sentence* — a
program with no [(agent/start ...)] in it should say so rather than look
idle — and a sentence does not need to be in front of the loop to be said.
So it is a deadline the session passes rather than a wait it does. Checked
from the accept loop between connections and from [serve] before each
request, which are the two places this thread can be: an editor holds one
connection for a whole session, so the loop is not cycling while it is
attached, and the request is then the only tick there is. The cost of that
is the warning landing on the first request after the deadline rather than
on the deadline itself; the alternative is a thread, and [lib/dune] has a
comment about what the merged link does to a library that grows one. *)
let agent_check t =
match t.agent_watch with
| None -> ()
| Some deadline ->
if agent_bound t then t.agent_watch <- None
else if Unix.gettimeofday () >= deadline then begin
(* Said once. A program that is never going to start an agent would
otherwise repeat this on every keystroke's worth of polling. *)
t.agent_watch <- None;
Printf.eprintf
"flan dev: the program is not listening on %s — does it call \
(agent/start ...)?\n%!" t.agent
end
(* ── Asking the agent ──────────────────────────────────────────────── *) (* ── Asking the agent ──────────────────────────────────────────────── *)
(* One line out, one line back. The agent is not a protocol and must not become (* One line out, one line back. The agent is not a protocol and must not become
@ -687,6 +741,60 @@ let refusal ~parked reply =
one was not taken, so send it again after that run" one was not taken, so send it again after that run"
else "the program refused the module: " ^ reply else "the program refused the module: " ^ reply
(* What a taken module still has to say about itself. The delivery succeeded —
the agent dlopened it and published it to its ring — so this is never a
refusal; it is the difference between "queued" and "running", which is a
difference only the program can close and only at a moment of its choosing.
Three of them, in the order of how far the module is from being live:
A PARKED program has finished [main] and is asleep in [flan_merged_park].
Its ring is drained whenever that sleep ends — for an expression to run, or
to start the next run — so the module lands no later than that run, and
before its first frame rather than at one. An expression evaluated in the
meantime takes it first, because the poll that runs a thunk installs
whatever is queued ahead of it. That is the whole
sentence, and it is worth reading once. It is not worth reading on every
C-c C-c, and a finished program is parked, so every redefinition while a
run's output is still on the screen used to repeat it. [park_noted] is what
makes the second one a line instead of a paragraph; the rule is per park,
not per session, because the reader of a *new* park may not be the reader
of the last one.
A RUNNING program that has not bound its agent socket has not called
[(agent/start ...)] yet — it may be about to, ahead of a window that is
still being created, or it may have no such call at all. Either way the
module is in the ring and the ring is drained by [(agent/poll)], so what
can honestly be promised is the poll and not a frame: a program with no
poll in it never installs this, and saying "at its next frame boundary"
would be the reply that made a redefinition look applied when it was not.
A RUNNING program that has bound it needs no note: the reply already says
queued, and the frame boundary is the next one it reaches. *)
let install_note t ~parked =
if parked then begin
let first = not t.park_noted in
t.park_noted <- true;
[ ":note "
^ Wire.quote
(if first then
"queued; the program is parked, so this installs no later than \
its next run rather than at its next frame boundary — an \
expression evaluated in the meantime takes it first, because \
the poll that runs a thunk installs whatever is queued ahead \
of it"
else "queued; installs no later than the parked program's next run")
]
end
else if not (agent_bound t) then
[ ":note "
^ Wire.quote
"queued, but the program has not called (agent/start ...) yet, so \
this installs when it next reaches an (agent/poll) — and not at \
all if it never does"
]
else []
(* [pause], when given, is the position of the form to stop at — §9. It rides (* [pause], when given, is the position of the form to stop at — §9. It rides
beside the code rather than in it, and the reply echoes it back so an editor beside the code rather than in it, and the reply echoes it back so an editor
marks the buffer only for a mark the session actually applied. marks the buffer only for a mark the session actually applied.
@ -706,6 +814,12 @@ let refusal ~parked reply =
let eval t ~code ~origin ~pause = let eval t ~code ~origin ~pause =
let now = liveness t in let now = liveness t in
let parked_now = now = Parked in let parked_now = now = Parked in
(* A park that is over takes its note with it: the long sentence below is
said once per park, and this is where a new one starts being possible.
Written on every eval rather than on the transition, because there is no
transition to hook — the program parks itself on its own thread and this
side finds out by asking. *)
if not parked_now then t.park_noted <- false;
(* What the session was before the form was checked, and every failure below (* What the session was before the form was checked, and every failure below
puts it back. [Session.eval] commits as soon as the check succeeds, which puts it back. [Session.eval] commits as soon as the check succeeds, which
is two fallible steps too early: the build can fail and the agent can is two fallible steps too early: the build can fail and the agent can
@ -779,15 +893,7 @@ let eval t ~code ~origin ~pause =
| Some (l, c) -> | Some (l, c) ->
[ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ]
| None -> []) | None -> [])
@ (if parked_now then @ install_note t ~parked:parked_now)
[ ":note "
^ Wire.quote
"queued; the program is parked, so this installs no \
later than its next run rather than at its next \
frame boundary — an expression evaluated in the \
meantime takes it first, because the poll that runs \
a thunk installs whatever is queued ahead of it" ]
else []))
| reply -> refused (refusal ~parked:parked_now reply) | reply -> refused (refusal ~parked:parked_now reply)
| exception Unix.Unix_error (e, _, _) -> | exception Unix.Unix_error (e, _, _) ->
refused refused
@ -968,6 +1074,21 @@ let eval_expr t ~code ~origin ~pause =
program is parked, so nothing is competing with it: the \ program is parked, so nothing is competing with it: the \
thunk is most likely stopped on a condition inside the \ thunk is most likely stopped on a condition inside the \
break loop, which restart or abort answers" break loop, which restart or abort answers"
(* And a third cause, which is the one a session now reaches
early enough to hit: the program has not bound its agent
socket, so it is still ahead of its own [(agent/start ...)]
— inside whatever it does first, a window being created —
and asking whether it calls [(agent/poll)] would send the
reader to look at a loop it has not got to yet. Said only
where it is a fact about *this* program: the socket is
missing, which is a stat, not a guess. *)
else if not (agent_bound t) then
error
"the program has not called (agent/start ...) yet, so \
nothing has run the expression. It is queued and will run \
at the program's first (agent/poll); this reply cannot \
carry its value, so evaluate it again once the program is \
up"
else else
error error
"the program did not reach a frame boundary; is it calling \ "the program did not reach a frame boundary; is it calling \
@ -2574,6 +2695,12 @@ let rerun t =
| Live | Parked -> | Live | Parked ->
(match Program.rerun () with (match Program.rerun () with
| Ok () -> | Ok () ->
(* The park this session was explaining is over, so the park after it
gets the explanation again — see [install_note]. Cleared here as
well as in [eval] because a run can start and finish with nothing
evaluated in between, and the next park would otherwise inherit a
flag set by the last one. *)
t.park_noted <- false;
(* Taken is not always started, and the one case where it is not needs (* Taken is not always started, and the one case where it is not needs
saying rather than a mechanism. A thunk evaluated against the park saying rather than a mechanism. A thunk evaluated against the park
can stop in the break loop, and the parked thread is then inside that can stop in the break loop, and the parked thread is then inside that
@ -2588,8 +2715,8 @@ let rerun t =
the break loop, so main starts once that is resumed or aborted" the break loop, so main starts once that is resumed or aborted"
else else
"running main again; the globals are as the last run left them, and \ "running main again; the globals are as the last run left them, and \
anything delivered while it was parked installs at the first frame \ anything delivered while it was parked is installed before this \
boundary" run starts"
in in
ok [ ":note " ^ Wire.quote note ] ok [ ":note " ^ Wire.quote note ]
| Error m -> error m) | Error m -> error m)
@ -3357,6 +3484,10 @@ let serve t fd =
let rec go () = let rec go () =
match Wire.recv fd with match Wire.recv fd with
| src -> | src ->
(* One of the two places the agent clock is read — see [agent_check].
An attached editor keeps this loop, and not the accept loop, running
for the whole of a session. *)
agent_check t;
(* Parsed once, and the verb taken out of it before anything that can (* Parsed once, and the verb taken out of it before anything that can
fail: [close] has to be honoured even when the handler for it did not fail: [close] has to be honoured even when the handler for it did not
return normally, and a tuple whose two halves are [Wire.string_field] return normally, and a tuple whose two halves are [Wire.string_field]
@ -3508,6 +3639,9 @@ let accept_loop ?grace t ls =
is held for an hour is an hour of the clock not running. *) is held for an hour is an hour of the clock not running. *)
let served = ref false and since = ref (Unix.gettimeofday ()) in let served = ref false and since = ref (Unix.gettimeofday ()) in
let rec go () = let rec go () =
(* The other place the agent clock is read: between connections, which is
where a session with no editor attached spends its time. *)
agent_check t;
match liveness t with match liveness t with
| Gone -> () | Gone -> ()
| (Live | Parked) as live -> | (Live | Parked) as live ->
@ -3634,7 +3768,8 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () =
let t = let t =
{ session; child = Some child; agent; dir; stdout = rd; { session; child = Some child; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false } host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false }
in in
ignore_sigpipe (); ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -3891,11 +4026,12 @@ static void flan_merged_exit(int32_t status) {
* from the same poll. * from the same poll.
* *
* So the wait has two flags and not one, and the difference between them is * So the wait has two flags and not one, and the difference between them is
* what the thread does next. [program_asked] leaves the park; [program_poll] * what the thread does next: [program_asked] leaves the park and
* drains the ring and waits again. The program stays PROGRAM_PARKED across the * [program_poll] waits again. What they no longer differ about is the ring,
* whole of the second — a thunk is not a run, and an editor that saw [:parked * which is drained on the way round either way — see the loop. The program
* nil] for the duration of a C-x C-e would show the program as live for a * stays PROGRAM_PARKED across the whole of a poll — a thunk is not a run, and
* moment that has no frames in it. * an editor that saw [:parked nil] for the duration of a C-x C-e would show
* the program as live for a moment that has no frames in it.
* *
* A re-run is tested first, so a stream of evaluations cannot starve one. The * A re-run is tested first, so a stream of evaluations cannot starve one. The
* poll flag is cleared BEFORE the lock is dropped, which is what makes a * poll flag is cleared BEFORE the lock is dropped, which is what makes a
@ -3925,7 +4061,29 @@ static void flan_merged_park(void) {
for (;;) { for (;;) {
while (!program_asked && !program_poll) while (!program_asked && !program_poll)
pthread_cond_wait(&program_wake, &program_lock); pthread_cond_wait(&program_wake, &program_lock);
if (program_asked) break; /* Which flag woke this, latched before the lock is dropped — and the ring
* is drained on BOTH paths, which is the whole of the fix below.
*
* A re-run used to [break] here, leaving the ring untouched. A plain
* redefinition does not set [program_poll] (only an expression does, by
* way of [Program.wake]), so a body redefined against the park was still
* sitting in the queue when this thread re-entered
* [flan_program_main] — and it installed at the coming run's first frame
* boundary, which is *after* main has been entered and after everything
* main calls before its first [(agent/poll)]. The run that was asked for
* in order to see the change ran the old body, and the change appeared in
* the run after it. A redefined [main] is the sharpest case, because
* nothing about that run is in front of it.
*
* So the drain goes in front of the exit as well: a delivery made while
* the program was parked is installed before the re-run starts, which is
* what "installs no later than its next run" means in the reply that
* accepted it.
*
* The re-run is still tested first and cannot be starved by a stream of
* evaluations: [leaving] is read at the top of the round and nothing in
* the round can clear it. */
int leaving = program_asked;
program_poll = 0; program_poll = 0;
pthread_mutex_unlock(&program_lock); pthread_mutex_unlock(&program_lock);
if (flan_agent_poll) flan_agent_poll(); if (flan_agent_poll) flan_agent_poll();
@ -3935,6 +4093,7 @@ static void flan_merged_park(void) {
* a thunk that printed after both. */ * a thunk that printed after both. */
fflush(NULL); fflush(NULL);
pthread_mutex_lock(&program_lock); pthread_mutex_lock(&program_lock);
if (leaving) break;
} }
program_asked = 0; program_asked = 0;
program_state = PROGRAM_RUNNING; program_state = PROGRAM_RUNNING;
@ -4384,7 +4543,8 @@ let merged_setup () =
let t = let t =
{ session; child = None; agent; dir; stdout = rd; { session; child = None; agent; dir; stdout = rd;
out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32; out = Buffer.create 4096; n = 0; gen = 0; owners = Hashtbl.create 32;
host_ll; host_exe = exe; finished = false } host_ll; host_exe = exe; finished = false; agent_watch = None;
park_noted = false }
in in
ignore_sigpipe (); ignore_sigpipe ();
(try Unix.unlink sock with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ());
@ -4422,15 +4582,24 @@ let merged_serve () =
| None -> prerr_endline "flan dev: serve was called before setup"; exit 1 | None -> prerr_endline "flan dev: serve was called before setup"; exit 1
| Some (t, ls, sock) -> | Some (t, ls, sock) ->
(* The agent is bound by the program on the main thread, which only starts (* The agent is bound by the program on the main thread, which only starts
once [merged_setup] has returned — so unlike the daemon, this waits once [merged_setup] has returned. So this does not wait for it: it arms
*after* it is already serving. An editor connecting in the meantime is the clock that eventually says it never came, and serves.
answered; only a delivery needs the agent. A program that never calls
[agent/start] is a warning rather than a failure now, because the thing That was the bug. The wait used to be here, in front of [accept_loop],
the daemon would have killed for it is this process. *) so the listening socket was up — an editor connected fine — and nothing
if not (await ~ms:10000 (fun () -> Sys.file_exists t.agent)) then answered until the program bound its own socket or ten seconds ran out.
Printf.eprintf A program that calls [(agent/start ...)] after something slow (a window
"flan dev: the program is not listening on %s — does it call \ being created) or never at all made that the cost of the *first* thing
(agent/start ...)?\n%!" t.agent; anybody asked the session, every session. Nothing the editor asks needs
the program's socket — in one process a delivery is a call, not a
connect — so the wait was gating the whole protocol on a fact only the
agent's own verbs care about.
A program that never calls [agent/start] is still a warning rather than
a failure, because the thing the daemon would have killed for it is
this process. See [agent_check] for where the sentence is said now, and
[eval] for what a delivery to such a program honestly reports. *)
t.agent_watch <- Some (Unix.gettimeofday () +. 10.);
(match accept_loop t ls with (match accept_loop t ls with
| () -> () | () -> ()
| exception e -> | exception e ->

36
test/programs/dev-lateagent.flan Normal file
View File

@ -0,0 +1,36 @@
;;;; A program that does call (agent/start ...) — but only after something
;;;; slow, which is the shape a real one has.
;;;;
;;;; sand.flan opens a window first and starts the agent afterwards, so on a
;;;; machine where window setup takes a while the socket appears seconds into
;;;; the run. [merged_serve] used to wait up to ten seconds for that socket
;;;; *before* starting its accept loop, so those seconds were charged to the
;;;; first thing the editor asked, every session. This fixture is that delay
;;;; with the window taken out: a sleep, then the agent, then an ordinary
;;;; poll loop.
;;;;
;;;; Two claims are checked against it in test_dev.ml: the session answers
;;;; while the sleep is still running, and a redefinition sent during the
;;;; sleep is installed once the program is up.
(import agent "vendor:agent")
(defvar frames i64)
(defn step [] i64 7)
(defn tick [] i64
(set frames (+ frames 1))
frames)
(defn main [] i32
;; Long enough for a test to connect, ask something and evaluate inside it,
;; and short enough that the rest of the test is not waiting on it.
(sleep-seconds 3.0)
(agent/start "/tmp/flan-dev-lateagent-fallback.sock")
;; dev-chatty.flan's count, for its reason: the test ends the session when
;; it is done, and a program that ran out of frames first would fail for
;; the wrong reason.
(dotimes [i 24000]
(tick)
(agent/wait 1))
0)

25
test/programs/dev-parknote.flan Normal file
View File

@ -0,0 +1,25 @@
;;;; A program that parks the moment it is up: an agent, a line of output and
;;;; a return from main.
;;;;
;;;; Every other fixture here has to be driven to its park through the run it
;;;; was written for. What the note test needs is the park itself, repeatedly
;;;; and cheaply — a redefinition sent to a parked program is answered with an
;;;; explanation of what "queued" means for one, and the claim under test is
;;;; that the explanation is given once per park rather than once per
;;;; keystroke. So the run is as short as a run can be, and [rerun] gets it
;;;; back to a fresh park in one op.
(import agent "vendor:agent")
(defvar runs i64)
(defn step [] i64 7)
;;; Called by main before the run reaches any (agent/poll), which is what
;;; makes it the probe for *when* a parked delivery installs: a body queued
;;; while the program was parked either got into the ring before main was
;;; re-entered or it did not, and this is the print that says which.
(defn main [] i32
(agent/start "/tmp/flan-dev-parknote-fallback.sock")
(set runs (+ runs 1))
(print (step)) (println "")
0)

346
test/test_dev.ml
View File

@ -709,9 +709,9 @@ let () =
fail "the program did not stay parked across an evaluation"; fail "the program did not stay parked across an evaluation";
(* [eval] is the one op a parked program took before this, because it (* [eval] is the one op a parked program took before this, because it
queues and waits for nothing: the module sits in the ring until the game queues and waits for nothing: the module sits in the ring until the
thread next reaches a frame boundary, and the next frame boundary a parked thread next looks at it, which is when it is woken — to run an
parked program reaches is in its next run. Having to run the program expression, or to start the run below. Having to run the program
before being allowed to fix the thing you closed it over is the loop before being allowed to fix the thing you closed it over is the loop
this feature exists to remove. *) this feature exists to remove. *)
let r = let r =
@ -736,19 +736,27 @@ let () =
if status r <> "ok" then if status r <> "ok" then
fail "rerun: %s" (Option.value ~default:"" (Wire.string_field r "message")); fail "rerun: %s" (Option.value ~default:"" (Wire.string_field r "message"));
(* Two lines, and between them the whole claim. The first is [step] as (* One line, and the whole claim is in which body printed it. It is the
the third reload left it, printed before the new run has reached a body delivered while the program was parked — installed before the
frame boundary; the second is the body delivered while it was parked, re-run re-entered [main] rather than at the first [agent/wait] after
installed at the first [agent/wait] of the new run — and its value is it — and its value is 106 rather than 1, because [extra] is a global
106 rather than 1, because [extra] is a global of a process that never of a process that never died and the second run reads what the first
died and the second run reads what the first left in it. Nothing is left in it. Nothing is zeroed between runs, deliberately: a clean
zeroed between runs, deliberately: a clean slate is one evaluation slate is one evaluation away, and cannot be had back once a re-run
away, and cannot be had back once a re-run has wiped something. has wiped something.
Seven and not six, because [settle] counts every line the daemon has This used to be two lines, and the first of them was the defect:
[flan_merged_park] left on the re-run flag without draining its ring,
so the new run printed the *old* [step] and the queued body did not
land until the [agent/wait] after it. Everything a run does before
its first poll ran a body the person had already replaced, and a
redefined [main] — which is all of that run — would have had to be
asked for twice.
Six and not five, because [settle] counts every line the daemon has
handed over and the printing expression above contributed one that no handed over and the printing expression above contributed one that no
run printed. Six would be satisfied by the first of these two. *) run printed. *)
if not (settle 7) then fail "the program did not run again"; if not (settle 6) then fail "the program did not run again";
(* And a re-run while it is running is refused rather than queued: two (* And a re-run while it is running is refused rather than queued: two
mains in one process would be writing the same globals at once. *) mains in one process would be writing the same globals at once. *)
@ -773,11 +781,13 @@ let () =
and 777 from a restart clause in a third — reached by a transfer that and 777 from a restart clause in a third — reached by a transfer that
started in a handler and crossed a function the host was built with. started in a handler and crossed a function the host was built with.
Then the same [main], run a second time in the same process: 777 Then the same [main], run a second time in the same process: 106,
again, from the body the first run ended with, and 106 from the one from the body delivered while it was parked. There is no second 777
delivered while it was parked. 106 and not 1 is the line that says in front of it any more, and that absence is the claim — the park
the globals are the finished run's — the process never died, so drains its ring on the way out, so the re-run starts with the body
[extra] is where the first run left it. the person last sent rather than with the one they replaced. 106 and
not 1 is the other half: the globals are the finished run's, the
process never died, so [extra] is where the first run left it.
And [pk] between the two, which is a line no run printed: it is the And [pk] between the two, which is a line no run printed: it is the
thunk evaluated against the park, on the parked thread, flushed there thunk evaluated against the park, on the parked thread, flushed there
@ -786,7 +796,7 @@ let () =
before anything the second did. *) before anything the second did. *)
ignore (Unix.waitpid [] pid); ignore (Unix.waitpid [] pid);
let text = Buffer.contents output in let text = Buffer.contents output in
let wanted = "1\n5\n105\n777\npk\n777\n106\n" in let wanted = "1\n5\n105\n777\npk\n106\n" in
if text <> wanted then if text <> wanted then
fail "program transcript\n got: %S\n wanted: %S" text wanted fail "program transcript\n got: %S\n wanted: %S" text wanted
end; end;
@ -3737,17 +3747,25 @@ let () =
without an agent into a session that dies at startup, silently, because without an agent into a session that dies at startup, silently, because
no test would have noticed. no test would have noticed.
So what is asserted is the policy and not the sentence: the session is So what is asserted is the policy and not the sentence: the session
still answering after the wait ran out. The warning text is checked answers. The warning text is checked second, as the evidence that this
second, as the evidence that this is the branch that produced it and is the branch that produced it and not some other path that happened to
not some other path that happened to work. work.
The block costs the full ten seconds of [merged_serve]'s [await] WHEN it answers is asserted too, and that is the newer half. The wait
([lib/dev.ml]) and there is no way to spend less: [accept_loop] is not for the agent socket used to sit in front of [accept_loop], so this
reached until the wait expires, so the reply cannot arrive sooner. [describe] could not arrive until the ten seconds had run out — the
Shortening it would mean a timeout override in [lib/dev.ml] that exists block's cost, and every real session's first keystroke. The wait is a
for the test and for nothing else, which is a worse trade than ten deadline the session passes now ([Dev.agent_check]), so the reply comes
seconds in a suite that already takes minutes. *) back immediately and the sentence is said later, by the accept loop,
once the deadline is behind it. The second half is what still costs ten
seconds here: a warning about a program that is never going to start an
agent cannot honestly be said before waiting for one.
[describe] and not a cheaper op on purpose: it is what
[emacs/flan.el] sends straight after [flan--open] (flan.el:646) and
what its poll sends after that, so this is the stall a person would
actually have felt. *)
let nsock = tmp "noagent.sock" and nlog = tmp "noagent.log" in let nsock = tmp "noagent.sock" and nlog = tmp "noagent.log" in
(try Sys.remove nsock with Sys_error _ -> ()); (try Sys.remove nsock with Sys_error _ -> ());
(* Its own stderr, unlike every other daemon here: the warning is the (* Its own stderr, unlike every other daemon here: the warning is the
@ -3783,11 +3801,12 @@ let () =
if Sys.file_exists (nhost "s") then if Sys.file_exists (nhost "s") then
fail "flan dev --llvm left an x86 listing at %s" (nhost "s"); fail "flan dev --llvm left an x86 listing at %s" (nhost "s");
let nc = connect nsock in let nc = connect nsock in
(* Blocks for the whole of [merged_serve]'s wait, by construction. The (* The exception arm is not defensive: a session that adopted the
exception arm is not defensive: a session that adopted the daemon's daemon's policy would exit here, and the connection would come back
policy would exit here, and the connection would come back ECONNRESET ECONNRESET rather than with a status. Reported by name because an
rather than with a status. Reported by name because an uncaught uncaught [Unix_error] out of a test binary says nothing about which
[Unix_error] out of a test binary says nothing about which test. *) test. *)
let nt0 = Unix.gettimeofday () in
(match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with (match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with
| r when status r = "ok" -> () | r when status r = "ok" -> ()
| r -> | r ->
@ -3797,22 +3816,43 @@ let () =
fail fail
"a program without (agent/start ...) ended the session instead of \ "a program without (agent/start ...) ended the session instead of \
drawing a warning: %s" (Printexc.to_string e)); drawing a warning: %s" (Printexc.to_string e));
(try let ndt = Unix.gettimeofday () -. nt0 in
ignore (Wire.send nc "(:op \"close\")"); (* Two seconds, against a stall that was ten and a reply that is a
ignore (Wire.recv nc) fraction of one. The threshold is loose on purpose: what is being
with _ -> ()); held is "the session does not wait for the program's socket before
answering", and a number close to the real cost would fail on a
loaded machine for a reason that has nothing to do with the wait. *)
if ndt > 2. then
fail
"the first editor request waited %.1fs on a program without \
(agent/start ...); the accept loop is gated on the agent again"
ndt;
(* Dropped rather than closed with [(:op "close")], and the difference
is the rest of this row: [close] ends the session, the process
[_exit]s, and the deadline below would be waited out by nobody. A
dropped connection leaves the accept loop cycling, which is where
the sentence is said from. *)
(try Unix.close nc with Unix.Unix_error _ -> ()) (try Unix.close nc with Unix.Unix_error _ -> ())
end; end;
(* And the sentence, which arrives after the deadline rather than before
the loop. Awaited with the daemon still alive — the accept loop is what
says it, so killing first would be testing that a dead process does not
print. Generous against the ten-second deadline for the reason the
threshold above is loose. *)
let nlog_says () =
contains_sub
(try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "")
"does it call (agent/start ...)?"
in
ignore (await ~ms:30000 nlog_says);
(try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ()); (try Unix.kill npid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()); (try ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ());
let nlog_text = if not (nlog_says ()) then
try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> ""
in
if not (contains_sub nlog_text "does it call (agent/start ...)?") then
fail fail
"a program without (agent/start ...) drew no warning from flan dev:\n%s" "a program without (agent/start ...) drew no warning from flan dev:\n%s"
nlog_text; (try In_channel.with_open_bin nlog In_channel.input_all
with Sys_error _ -> "");
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ nsock; nlog ]; [ nsock; nlog ];
@ -5061,6 +5101,222 @@ let () =
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ csock; cout ]; [ csock; cout ];
(* ══ The agent socket is not the editor protocol ══════════════════
Two daemons of their own, both about what a session owes an editor
before the program has bound the socket it receives modules on. The
row above about a program with *no* [(agent/start ...)] is the other
half of the same claim and lives where it always did. *)
(* ── A program that starts its agent late ──────────────────────────
The shape a real one has: sand.flan opens a window and starts the
agent afterwards, so the socket appears seconds into the run. The
merged session used to wait up to ten seconds for it *before* running
its accept loop, which charged those seconds to the first thing the
editor asked. Two claims, and the second is what stops the first from
being bought with a lie: the session answers during the delay, and a
redefinition sent during it is really installed once the program is
up. *)
let lsock = tmp "lateagent.sock" and lout = tmp "lateagent.out" in
(try Sys.remove lsock with Sys_error _ -> ());
let lfd =
Unix.openfile lout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let lpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-lateagent.flan"; "-s"; lsock |]
Unix.stdin lfd Unix.stderr
in
Unix.close lfd;
if not (listening ~pid:lpid lsock) then begin
fail "the late-agent daemon %s (%S)" !listen_why
(In_channel.with_open_bin lout In_channel.input_all);
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let lc = connect lsock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
(* The program sleeps for three seconds before [agent/start], so this is
asked inside the delay. Two seconds is the threshold for the reason
the agentless row gives: the reply is a fraction of one and the bug
was ten, so anything in between is a loaded machine rather than a
regression. *)
let lt0 = Unix.gettimeofday () in
let r = request lc "(:op \"describe\")" in
let ldt = Unix.gettimeofday () -. lt0 in
if status r <> "ok" then
fail "a program whose agent starts late was not described: %s" (said r);
if ldt > 2. then
fail
"the first editor request waited %.1fs on a program whose agent \
starts late; the accept loop is gated on the agent again" ldt;
(* And the delivery, also inside the delay. It is taken — in one process
the agent's ring is reachable whether or not the program has bound a
socket — and the note says what "queued" means for a program that has
not got to its poll yet. Asserted because the alternative was the
reply this whole area exists to prevent: an "ok" that reads as
installed. *)
let r =
request lc
"(:op \"eval\" :code \"(defn step [] i64 9)\" :file \
\"programs/dev-lateagent.flan\")"
in
if status r <> "ok" then
fail "a redefinition sent before (agent/start ...): %s" (said r)
else begin
let note = Option.value ~default:"" (Wire.string_field r "note") in
if not (contains_sub note "(agent/start ...)") then
fail
"a redefinition delivered before the program's agent was up said \
nothing about it: %S" note
end;
(* The claim the note makes, checked against the program rather than
against the reply: once the sleep is over and the program is polling,
the body that was queued is the one that runs. [await] because the
moment the agent comes up is the program's to choose, and each
[eval-expr] already waits five seconds of its own. *)
let answered = ref "" in
let installed () =
let r =
request lc
"(:op \"eval-expr\" :code \"(step)\" :file \
\"programs/dev-lateagent.flan\")"
in
answered := Option.value ~default:(said r) (Wire.string_field r "value");
!answered = "9"
in
if not (await ~ms:20000 installed) then
fail
"a redefinition queued before (agent/start ...) never installed: \
(step) answered %S" !answered;
(try
ignore (Wire.send lc "(:op \"close\")");
ignore (Wire.recv lc)
with _ -> ());
(try Unix.close lc with Unix.Unix_error _ -> ());
(try Unix.kill lpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] lpid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ lsock; lout ];
(* ── The parked note, once per park ────────────────────────────────
A finished program is parked, so re-evaluating while a run's output is
still on the screen is the commonest thing there is — and it used to
repeat a paragraph about what "queued" means for a park on every one.
The explanation is kept for the first delivery of each park and
shortened after it, which is a claim with two halves: the second note
is smaller than the first, and a *new* park gets the long one back.
The second half is why [rerun] clears the flag as well as [eval]: a run
can start and finish with nothing evaluated in between. *)
let psock = tmp "parknote.sock" and pout = tmp "parknote.out" in
(try Sys.remove psock with Sys_error _ -> ());
let pfd =
Unix.openfile pout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600
in
let ppid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-parknote.flan"; "-s"; psock |]
Unix.stdin pfd Unix.stderr
in
Unix.close pfd;
if not (listening ~pid:ppid psock) then begin
fail "the park-note daemon %s (%S)" !listen_why
(In_channel.with_open_bin pout In_channel.input_all);
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let pc = connect psock in
let said r = Option.value ~default:"" (Wire.string_field r "message") in
let parked () =
match Wire.field (request pc "(:op \"describe\")") "parked" with
| Some { Form.v = Form.Sym "t"; _ } -> true
| _ -> false
in
let redefine n =
let r =
request pc
(Printf.sprintf
"(:op \"eval\" :code \"(defn step [] i64 %d)\" :file \
\"programs/dev-parknote.flan\")" n)
in
if status r <> "ok" then begin
fail "a redefinition of a parked program: %s" (said r); ""
end
else Option.value ~default:"" (Wire.string_field r "note")
in
(* [main] returns as soon as it has printed, so this is a wait on the
park rather than on anything this test does. *)
if not (await parked) then
fail "the park-note program never parked"
else begin
let first = redefine 4241 in
let second = redefine 4242 in
(* The long one by what it explains and not by its length: the
sentence about an expression taking the module first is the part
that is worth reading once. *)
if not (contains_sub first "an expression evaluated in the meantime") then
fail "the first delivery to a park did not explain itself: %S" first;
if second = "" then
fail "the second delivery to a park said nothing at all"
else if String.length second >= String.length first then
fail
"the second delivery to the same park repeated the explanation: \
%S" second;
(* Still true, and that is the point of shortening rather than
dropping it: what the reader is told is smaller, not different. *)
if not (contains_sub second "next run") then
fail "the short park note stopped saying when it installs: %S" second;
(* ── And the note has to be true, which is a claim about the run ──
What the note promises is that a body delivered to a park installs
no later than the next run. It did not: [flan_merged_park] drained
the agent's ring only on the flag an *expression* sets, and left on
the re-run flag without draining at all — so a redefinition sent
while parked was still in the queue when the thread re-entered
[flan_program_main], and installed at the coming run's first frame
boundary instead. Everything main did before its first
[(agent/poll)] ran the old body, and the change turned up one run
late.
[programs/dev-parknote.flan]'s main prints [(step)] before it polls
at all, so the first run after a parked redefinition either shows
the new body or shows the lag. The output arrives on a reply rather
than in a file — [request] collects [:output] into [output] — so
the window is measured round the ops that follow the re-run.
A new park is a new reader, so the note's own reset is checked on
the far side of the same op: main runs and parks straight away with
nothing evaluated in between, which is the case [eval]'s clearing
cannot reach and [rerun]'s can. *)
let before = Buffer.length output in
let r = request pc "(:op \"rerun\")" in
if status r <> "ok" then fail "the park-note rerun: %s" (said r)
else if not (await parked) then
fail "the park-note program never parked a second time"
else begin
let printed = Buffer.sub output before (Buffer.length output - before) in
if not (contains_sub printed "4242") then
fail
"the run after a parked redefinition printed %S, so the module \
was still in the ring when main was re-entered" printed;
let again = redefine 4243 in
if not (contains_sub again "an expression evaluated in the meantime")
then
fail "a second park did not get the explanation back: %S" again
end
end;
(try
ignore (Wire.send pc "(:op \"close\")");
ignore (Wire.recv pc)
with _ -> ());
(try Unix.close pc with Unix.Unix_error _ -> ());
(try Unix.kill ppid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] ppid) with Unix.Unix_error _ -> ())
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ psock; pout ];
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) List.iter (fun f -> try Sys.remove f with Sys_error _ -> ())
[ sock; out; bsock; bout ]; [ sock; out; bsock; bout ];
Test_support.report ~label:"dev" () Test_support.report ~label:"dev" ()