diff --git a/lib/dev.ml b/lib/dev.ml index b3d6709..5e2ab4f 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -52,6 +52,18 @@ type t = { The merged build keeps fd 1 open across runs now and is asked instead — see [liveness] and [Program.state]. *) 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 @@ -106,6 +118,48 @@ let await ?(ms = 5000) f = in 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 ──────────────────────────────────────────────── *) (* 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" 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 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. @@ -706,6 +814,12 @@ let refusal ~parked reply = let eval t ~code ~origin ~pause = let now = liveness t 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 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 @@ -779,15 +893,7 @@ let eval t ~code ~origin ~pause = | Some (l, c) -> [ ":pause " ^ Wire.quote (Printf.sprintf "%d:%d" l c) ] | None -> []) - @ (if parked_now then - [ ":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 [])) + @ install_note t ~parked:parked_now) | reply -> refused (refusal ~parked:parked_now reply) | exception Unix.Unix_error (e, _, _) -> refused @@ -968,6 +1074,21 @@ let eval_expr t ~code ~origin ~pause = program is parked, so nothing is competing with it: the \ thunk is most likely stopped on a condition inside the \ 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 error "the program did not reach a frame boundary; is it calling \ @@ -2574,6 +2695,12 @@ let rerun t = | Live | Parked -> (match Program.rerun () with | 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 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 @@ -2588,8 +2715,8 @@ let rerun t = the break loop, so main starts once that is resumed or aborted" else "running main again; the globals are as the last run left them, and \ - anything delivered while it was parked installs at the first frame \ - boundary" + anything delivered while it was parked is installed before this \ + run starts" in ok [ ":note " ^ Wire.quote note ] | Error m -> error m) @@ -3357,6 +3484,10 @@ let serve t fd = let rec go () = match Wire.recv fd with | 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 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] @@ -3508,6 +3639,9 @@ let accept_loop ?grace t ls = is held for an hour is an hour of the clock not running. *) let served = ref false and since = ref (Unix.gettimeofday ()) in 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 | Gone -> () | (Live | Parked) as live -> @@ -3634,7 +3768,8 @@ let two_process ?(debug = false) ?(x86 = true) ~file ~sock () = let t = { session; child = Some child; agent; dir; stdout = rd; 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 ignore_sigpipe (); (try Unix.unlink sock with Unix.Unix_error _ -> ()); @@ -3891,11 +4026,12 @@ static void flan_merged_exit(int32_t status) { * from the same poll. * * 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] - * drains the ring and waits again. The program stays PROGRAM_PARKED across the - * whole of the second — a thunk is not a run, and 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. + * what the thread does next: [program_asked] leaves the park and + * [program_poll] waits again. What they no longer differ about is the ring, + * which is drained on the way round either way — see the loop. The program + * stays PROGRAM_PARKED across the whole of a poll — a thunk is not a run, and + * 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 * 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 (;;) { while (!program_asked && !program_poll) 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; pthread_mutex_unlock(&program_lock); if (flan_agent_poll) flan_agent_poll(); @@ -3935,6 +4093,7 @@ static void flan_merged_park(void) { * a thunk that printed after both. */ fflush(NULL); pthread_mutex_lock(&program_lock); + if (leaving) break; } program_asked = 0; program_state = PROGRAM_RUNNING; @@ -4384,7 +4543,8 @@ let merged_setup () = let t = { session; child = None; agent; dir; stdout = rd; 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 ignore_sigpipe (); (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 | Some (t, ls, sock) -> (* 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 - *after* it is already serving. An editor connecting in the meantime is - 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 - the daemon would have killed for it is this process. *) - if not (await ~ms:10000 (fun () -> Sys.file_exists t.agent)) then - Printf.eprintf - "flan dev: the program is not listening on %s — does it call \ - (agent/start ...)?\n%!" t.agent; + once [merged_setup] has returned. So this does not wait for it: it arms + the clock that eventually says it never came, and serves. + + That was the bug. The wait used to be here, in front of [accept_loop], + so the listening socket was up — an editor connected fine — and nothing + answered until the program bound its own socket or ten seconds ran out. + A program that calls [(agent/start ...)] after something slow (a window + being created) or never at all made that the cost of the *first* thing + 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 | () -> () | exception e -> diff --git a/test/programs/dev-lateagent.flan b/test/programs/dev-lateagent.flan new file mode 100644 index 0000000..dd9eea4 --- /dev/null +++ b/test/programs/dev-lateagent.flan @@ -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) diff --git a/test/programs/dev-parknote.flan b/test/programs/dev-parknote.flan new file mode 100644 index 0000000..b139048 --- /dev/null +++ b/test/programs/dev-parknote.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index 45ea562..0f578f3 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -709,9 +709,9 @@ let () = fail "the program did not stay parked across an evaluation"; (* [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 - thread next reaches a frame boundary, and the next frame boundary a - parked program reaches is in its next run. Having to run the program + queues and waits for nothing: the module sits in the ring until the + parked thread next looks at it, which is when it is woken — to run an + 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 this feature exists to remove. *) let r = @@ -736,19 +736,27 @@ let () = if status r <> "ok" then fail "rerun: %s" (Option.value ~default:"" (Wire.string_field r "message")); - (* Two lines, and between them the whole claim. The first is [step] as - the third reload left it, printed before the new run has reached a - frame boundary; the second is the body delivered while it was parked, - installed at the first [agent/wait] of the new run — and its value is - 106 rather than 1, because [extra] is a global of a process that never - died and the second run reads what the first left in it. Nothing is - zeroed between runs, deliberately: a clean slate is one evaluation - away, and cannot be had back once a re-run has wiped something. + (* One line, and the whole claim is in which body printed it. It is the + body delivered while the program was parked — installed before the + re-run re-entered [main] rather than at the first [agent/wait] after + it — and its value is 106 rather than 1, because [extra] is a global + of a process that never died and the second run reads what the first + left in it. Nothing is zeroed between runs, deliberately: a clean + slate is one evaluation away, and cannot be had back once a re-run + 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 - run printed. Six would be satisfied by the first of these two. *) - if not (settle 7) then fail "the program did not run again"; + run printed. *) + 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 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 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 - again, from the body the first run ended with, and 106 from the one - delivered while it was parked. 106 and not 1 is the line that says - the globals are the finished run's — the process never died, so - [extra] is where the first run left it. + Then the same [main], run a second time in the same process: 106, + from the body delivered while it was parked. There is no second 777 + in front of it any more, and that absence is the claim — the park + drains its ring on the way out, so the re-run starts with the body + 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 thunk evaluated against the park, on the parked thread, flushed there @@ -786,7 +796,7 @@ let () = before anything the second did. *) ignore (Unix.waitpid [] pid); 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 fail "program transcript\n got: %S\n wanted: %S" text wanted end; @@ -3737,17 +3747,25 @@ let () = without an agent into a session that dies at startup, silently, because no test would have noticed. - So what is asserted is the policy and not the sentence: the session is - still answering after the wait ran out. The warning text is checked - second, as the evidence that this is the branch that produced it and - not some other path that happened to work. + So what is asserted is the policy and not the sentence: the session + answers. The warning text is checked second, as the evidence that this + is the branch that produced it and not some other path that happened to + work. - The block costs the full ten seconds of [merged_serve]'s [await] - ([lib/dev.ml]) and there is no way to spend less: [accept_loop] is not - reached until the wait expires, so the reply cannot arrive sooner. - Shortening it would mean a timeout override in [lib/dev.ml] that exists - for the test and for nothing else, which is a worse trade than ten - seconds in a suite that already takes minutes. *) + WHEN it answers is asserted too, and that is the newer half. The wait + for the agent socket used to sit in front of [accept_loop], so this + [describe] could not arrive until the ten seconds had run out — the + block's cost, and every real session's first keystroke. The wait is a + deadline the session passes now ([Dev.agent_check]), so the reply comes + 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 (try Sys.remove nsock with Sys_error _ -> ()); (* Its own stderr, unlike every other daemon here: the warning is the @@ -3783,11 +3801,12 @@ let () = if Sys.file_exists (nhost "s") then fail "flan dev --llvm left an x86 listing at %s" (nhost "s"); let nc = connect nsock in - (* Blocks for the whole of [merged_serve]'s wait, by construction. The - exception arm is not defensive: a session that adopted the daemon's - policy would exit here, and the connection would come back ECONNRESET - rather than with a status. Reported by name because an uncaught - [Unix_error] out of a test binary says nothing about which test. *) + (* The exception arm is not defensive: a session that adopted the + daemon's policy would exit here, and the connection would come back + ECONNRESET rather than with a status. Reported by name because an + uncaught [Unix_error] out of a test binary says nothing about which + test. *) + let nt0 = Unix.gettimeofday () in (match Wire.parse (Wire.send nc "(:op \"describe\")"; Wire.recv nc) with | r when status r = "ok" -> () | r -> @@ -3797,22 +3816,43 @@ let () = fail "a program without (agent/start ...) ended the session instead of \ drawing a warning: %s" (Printexc.to_string e)); - (try - ignore (Wire.send nc "(:op \"close\")"); - ignore (Wire.recv nc) - with _ -> ()); + let ndt = Unix.gettimeofday () -. nt0 in + (* Two seconds, against a stall that was ten and a reply that is a + fraction of one. The threshold is loose on purpose: what is being + 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 _ -> ()) 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 ignore (Unix.waitpid [] npid) with Unix.Unix_error _ -> ()); - let nlog_text = - 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 + if not (nlog_says ()) then fail "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 _ -> ()) [ nsock; nlog ]; @@ -5061,6 +5101,222 @@ let () = List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ 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 _ -> ()) [ sock; out; bsock; bout ]; Test_support.report ~label:"dev" ()