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

Merge: the pipe drains, the park flips first, and a trap cannot hang

Browse Source
This commit is contained in:
Joseph Ferano 2026-09-18 08:20:50 +07:00
commit c4b6bb9821
6 changed files with 353 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

115
lib/dev.ml
View File

@ -57,7 +57,14 @@ type t = {
(* The program's stdout is a pipe into this process, so that an editor can see
it. That makes draining it a *liveness* requirement and not a nicety: a pipe
nobody reads fills at 64K and the next write blocks the program forever. So
it is read from the accept loop's select, not only when someone asks. *)
it is read from the accept loop's select, not only when someone asks.
The accept loop is not enough on its own, and that is the other half of the
same requirement: it is not running while [serve] is handling a request, and
two of the things [serve] does are five-second waits for the game thread to
reach a frame boundary. A thread blocked in [fwrite] reaches none. So
[drain] is called from those waits as well — see [eval_expr], which carries
the argument. *)
let capacity = 256 * 1024
let drain t =
@ -737,6 +744,35 @@ let eval_expr t ~code ~origin ~pause =
pause && (match state t with Stopped "Pause" -> true | _ -> false)
in
let rec wait ms =
(* The pipe is drained on every tick, and that is what makes this
a wait rather than a deadlock.
In the merged build fd 1 is a 64K pipe back into this process,
and its only other reader is the select in [accept_loop] —
which is not running, because it is further up this very call
stack, inside [serve]. A program that prints as it goes (and a
game loop prints as it goes; sand.flan does) fills those 64K
while the module below was being built, and the game thread is
then stopped inside [flan_write_stdout], in an [fwrite] that
will not return until somebody reads. It never reaches the
frame boundary the thunk needs. Five seconds later this
answered "is it calling (agent/poll)?" — a true sentence about
a program that is calling it and cannot get there, which is the
worst kind of diagnostic there is.
[drain] and not [take]: the text belongs in [t.out] until
[with_output] puts it on this reply on the way out of [serve].
Taking it here would empty the buffer into nothing and lose
exactly the output the evaluation itself caused.
And the drain goes *beside* the sleep rather than into it.
Putting [t.stdout] in the select's read set is the obvious
shape and is wrong: a readable pipe returns from select
immediately, so a tick stops costing 5ms and [ms - 5] counts
the whole five seconds out in a fraction of one — the same
wrong sentence, arrived at faster. The timeout is a clock, so
the sleep has to stay a sleep. *)
drain t;
match result t with
| Some (g, v) when Int64.compare g before > 0 -> `Value v
| _ when stopped () -> `Stopped
@ -1112,6 +1148,15 @@ let run_render_thunk t ~tag ~(c : Session.change) : (string, string) result =
Error ("cannot reach the program: " ^ Unix.error_message e)
| "ok" ->
let rec wait ms =
(* Drained every tick for the reason [eval_expr]'s own wait spells
out: this loop is inside [serve], so the accept loop's select is
not reading the program's pipe, and a program that has filled it is
a program stopped in [fwrite] rather than one that is ignoring
[agent/poll]. A render thunk is asked for while the program is
*stopped* at a break, which is the state in which the last thing
printed matters most — so losing it to [take] would be worse here
than anywhere. *)
drain t;
match result t with
| Some (g, v) when Int64.compare g before > 0 -> Some v
| _ when ms <= 0 -> None
@ -3079,9 +3124,13 @@ static jmp_buf program_return; /* main()'s frame, from anywhere */
* instant after closing it (POSIX hands out the lowest free descriptor, so the
* compiler thread's next socket would have become this process's stdout, and
* the next llc would have inherited it) goes away with the close that caused
* it: fd 1 is never free. */
* it: fd 1 is never free.
*
* Nothing is flushed here either, and that is the same decision the park makes
* one function down: a flush of a pipe nobody is reading is an unbounded wait,
* and every line of it would be a line the compiler spends still believing the
* program is running. [flan_merged_park] flushes once it has said otherwise. */
static void flan_merged_exit(int32_t status) {
fflush(NULL);
program_status = status;
longjmp(program_return, 1);
}
@ -3094,10 +3143,35 @@ static void flan_merged_exit(int32_t status) {
*
* [while], not [if]: a condition variable may wake a waiter that nobody
* signalled, and [program_asked] is the fact — the wakeup is only a hint that
* it is worth looking again. */
* it is worth looking again.
*
* THE STATE IS FLIPPED BEFORE ANYTHING IS FLUSHED, and the order is the whole
* of a fix. stdout is a 64K pipe into this process, drained by the compiler
* thread, which stops draining for as long as it is answering a request. A
* program that printed as it ran leaves that pipe full when it finishes, so
* the flush below can wait for a reader that is busy — and every moment it
* waits is a moment [flan_merged_program_state] still answers RUNNING about a
* program that is over. Close a window, press the key that runs it again, and
* the answer was "the program is already running": the request itself was what
* kept the reader from draining. The state flip is two stores under a lock and
* cannot block on anything, so it goes first and the truth is available
* immediately; the flush and the notice follow, and they are courtesies.
*
* What that widens is the window in which the program is PARKED and not yet
* waiting. Nothing is lost in it: [flan_merged_rerun] sets [program_asked] and
* signals under the same lock, a signal delivered to nobody is discarded, and
* the [while] below reads the flag rather than the wakeup — so a request that
* lands in the window is taken and the wait falls straight through. The one
* visible cost is that two re-runs arriving in that window are both answered
* "ok" for a single run. That race existed before and was a microsecond wide;
* it is now as wide as a flush, which is the right trade against a refusal
* that was simply false. */
static void flan_merged_park(void) {
flan_condition_stacks_reset();
if (flan_dev_frames_reset) flan_dev_frames_reset();
pthread_mutex_lock(&program_lock);
program_state = PROGRAM_PARKED;
pthread_mutex_unlock(&program_lock);
fflush(NULL);
fprintf(stderr,
"flan dev: the program finished with %d; the process is parked and "
@ -3105,7 +3179,6 @@ static void flan_merged_park(void) {
(int)program_status);
fflush(stderr);
pthread_mutex_lock(&program_lock);
program_state = PROGRAM_PARKED;
while (!program_asked) pthread_cond_wait(&program_wake, &program_lock);
program_asked = 0;
program_state = PROGRAM_RUNNING;
@ -3120,10 +3193,12 @@ static void flan_merged_park(void) {
*
* [flan_merged_rerun] refuses a program that is already running rather than
* remembering the request, and that refusal is the only one there can be: the
* test and the signal are under the same lock, so a request that arrives in
* the microsecond between the finished run's longjmp and the park is either
* seen as running (refused, and the program parks a moment later) or seen as
* parked (taken). Queueing it instead would mean a second main starting the
* test and the signal are under the same lock, so a request that arrives
* between the finished run's longjmp and the park is either seen as running
* (refused, and the program parks a moment later) or seen as parked (taken).
* The park flips the state before it flushes, so the second is now the usual
* answer rather than the lucky one, and what that widens is written out
* there. Queueing it instead would mean a second main starting the
* instant the first finished, which is never what somebody pressing a key
* meant. */
int flan_merged_rerun(void) {
@ -3155,9 +3230,19 @@ int flan_merged_program_state(void) {
* message has already sent two investigations in this repository to the wrong
* place. Gone is the honest state, and the client already has words for it.
*
* [atexit] covers exit(3), which is what flan_rt.c's rt_die uses. _exit and
* abort skip it by design, so the places that take those routes unlink for
* themselves; see die_now in flan_agent.c. */
* [atexit] covers exit(3), and what is left taking exit(3) here is narrower
* than it was: the two places a program dies where it stands — rt_die in
* flan_rt.c and die_now in flan_agent.c — both take _exit, because the atexit
* chain and the ELF destructors want the loader lock a dlopening listener
* thread may be holding, and in this build that chain also holds OCaml's
* shutdown. Both therefore unlink this path by hand, so the same four lines
* exist in three places rather than one — sharing them would mean a runtime
* that links against the daemon, which is a worse trade than the repetition.
*
* What is left for this one is every exit(3) nobody planned — an OCaml fatal
* on the compiler thread most of all, since [Stdlib.exit] ends in the C one.
* Four lines on a path nobody means to take is the right price for a socket
* that never sits on disk refusing connects. */
static void flan_merged_unlink_sock(void) {
const char *s = getenv("FLAN_DEV_SOCK");
if (s != NULL && *s != '\0') unlink(s);
@ -3237,9 +3322,9 @@ int main(int argc, char **argv) {
* own shutdown to that chain. The hand-written [flan_merged_unlink_sock] that
* used to sit under this function's _exit went with it for the same reason —
* there is no way out of here any more to unlink on. The [atexit]
* registration above stays, because it is not for this path: it is for
* exit(3), which is what flan_rt.c's rt_die takes, and a merged daemon that
* dies through a trap must not leave a socket refusing connects behind it. */
* registration above stays, and no longer because of the trap: rt_die takes
* _exit now and unlinks for itself, exactly as die_now does. What is left
* for it is written at [flan_merged_unlink_sock]. */
for (;;) {
if (setjmp(program_return) == 0) {
rc = flan_program_main(argc, argv);

121
runtime/flan_rt.c
View File

@ -158,8 +158,11 @@ void flan_rt_init(int32_t argc, char **argv) {
}
/* Defined below with the rest of the non-local exits, and forward-declared
* here because the argument vector is built long before them. */
* here because the argument vector is built long before them. [rt_flush_out]
* is the flush every one of those paths does first; its own note says why it
* is not [fflush(stdout)]. */
static _Noreturn void rt_die(void);
static void rt_flush_out(void);
/* The one malloc in this file that is not an allocator's, because the argument
* vector belongs to the process rather than to any region a Flan program named.
@ -172,7 +175,7 @@ void flan_argv(flan_slice *out) {
if (rt_args == NULL && rt_argc > 0) {
rt_args = (flan_slice *)malloc(sizeof(flan_slice) * (size_t)rt_argc);
if (rt_args == NULL) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"flan: out of memory building the argument vector for %d "
"arguments\n",
@ -199,11 +202,21 @@ void flan_write_stdout(const uint8_t *p, int64_t n) {
* That is fine when the program is its own process and wrong when the compiler
* is in the same one — [exit] would take the session down with the program.
* The merged entry point installs a hook that flushes, tells the compiler the
* program is done, and parks instead. See lib/dev.ml. */
* program is done, and parks instead. See lib/dev.ml.
*
* There is no fflush before the hook, and its absence is the fix to a hang
* rather than a saving. [exit] flushes every stream itself, so the call was
* doing nothing at all for a program that is its own process; the only path it
* ever ran on was the hook's. And on that path stdout is a 64K pipe into the
* compiler thread, which is not reading it while it is answering a request —
* so this flush was the first thing to block when a printing program finished,
* and it blocked *before* the hook could say the program had. The compiler
* then answered "the program is already running" to the one key the person
* had just pressed to run it again. The hook flushes after it has said so;
* see flan_merged_park in lib/dev.ml, which carries the rest of the argument. */
void (*flan_exit_hook)(int32_t status) = 0;
void flan_exit(int32_t status) {
fflush(stdout);
if (flan_exit_hook) flan_exit_hook(status); /* does not return */
exit((int)status);
}
@ -381,15 +394,81 @@ void flan_escape_bytes(const uint8_t *p, int64_t n, flan_slice *out) {
* redirected stdout is not, so without this the error appears above the output
* that led to it. */
#if !defined(__wasm__)
#include <fcntl.h>
#endif
#include <unistd.h>
/* That flush, made incapable of waiting.
*
* Under a merged `flan dev' stdout is a 64K pipe into the compiler thread,
* which is not reading it while it is answering a request. A trap taken by a
* program that had filled that pipe therefore began by blocking in the flush
* meant to order its own last words — and a bounds failure that hangs instead
* of dying is the worst shape a trap can take, because the person watching has
* no message and no exit status and no reason to think anything happened.
*
* So fd 1 is put into non-blocking mode first and the flush is best-effort.
* What that costs is a truncated tail: whatever no longer fits in the pipe is
* dropped rather than waited for. What it buys is that the trap always reaches
* its message and its exit. On a terminal, a file, or a pipe with room —
* which is every run that is not this one pathological case — O_NONBLOCK
* changes nothing at all, and the acceptance corpus diffs this output.
*
* The return value is ignored deliberately, twice over: a failed fcntl leaves
* the old blocking behaviour, which is what this code did before, and a flush
* that reports EAGAIN has done as much as it is going to. There is nothing a
* dying process can do about either.
*
* Guarded on __wasm__, which this file otherwise does only for the valgrind
* client request below. The hazard is a pipe whose reader is
* the compiler thread of a merged `flan dev', which is a native host and only
* ever a native host — a wasm32 module has no compiler beside it and no such
* pipe. So the guard is not a portability apology: it says where the problem
* can exist, and keeps wasm32 from having to answer for a descriptor mode its
* runtime may model differently. */
#if defined(__wasm__)
static void rt_flush_out(void) { (void)fflush(stdout); }
#else
static void rt_flush_out(void) {
int flags = fcntl(1, F_GETFL, 0);
if (flags >= 0) (void)fcntl(1, F_SETFL, flags | O_NONBLOCK);
(void)fflush(stdout);
}
#endif
/* [_exit] and not [exit], for the reason die_now gives in
* vendor/agent/flan_agent.c and gives at length: this runs on the game thread,
* the dev agent's listener thread may be inside [dlopen] holding the loader
* lock, and [exit] runs the atexit chain and the ELF destructors, which want
* that same lock. In a merged build that chain also holds OCaml's shutdown,
* and it would be run from a thread that is not OCaml's. A trap that deadlocks
* in the runtime's teardown is the same failure as a trap that hangs on a full
* pipe, reached a few instructions later.
*
* What [_exit] skips is the atexit handler that removes the editor's socket —
* so, exactly as die_now does, this removes it by hand. A socket file left on
* disk with nothing accepting on it answers the next client with
* ECONNREFUSED, which reads like a daemon that is there and refusing rather
* than one that died; that message has already sent two investigations in this
* repository to the wrong place. FLAN_DEV_SOCK is unset in an ordinary run and
* then this does nothing.
*
* The two functions are kept saying the same thing on purpose. They are the
* two ways a Flan program dies where it stands, and a difference between them
* would be a difference nobody could predict from the outside. */
static _Noreturn void rt_die(void) {
fflush(stdout);
const char *sock;
rt_flush_out();
fflush(stderr);
exit(134);
sock = getenv("FLAN_DEV_SOCK");
if (sock != NULL && *sock != '\0') unlink(sock);
_exit(134);
}
_Noreturn void flan_bounds_fail(const uint8_t *loc, int64_t loclen,
int64_t idx, int64_t len) {
fflush(stdout);
rt_flush_out();
fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n",
(int)loclen, (const char *)loc, (long long)idx, (long long)len);
rt_die();
@ -448,7 +527,7 @@ void flan_error(uint32_t type_id, void *condition, void *xfer,
flan_break_hook(name, namelen, condition, xfer);
if (*(void **)xfer != NULL) return;
}
fflush(stdout);
rt_flush_out();
fprintf(stderr, "unhandled %.*s\n", (int)namelen, (const char *)name);
rt_die();
}
@ -458,7 +537,7 @@ void flan_error(uint32_t type_id, void *condition, void *xfer,
* there is nowhere to resume, so there is nothing else to do. */
_Noreturn void flan_restart_fail(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr, "%.*s: no restart named %.*s is active\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name);
rt_die();
@ -473,7 +552,7 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen,
const uint8_t *want, int64_t wantlen,
const uint8_t *got, int64_t gotlen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr, "%.*s: restart %.*s takes %.*s, given %.*s\n",
(int)loclen, (const char *)loc, (int)namelen, (const char *)name,
(int)wantlen, (const char *)want, (int)gotlen, (const char *)got);
@ -488,7 +567,7 @@ _Noreturn void flan_restart_args_fail(const uint8_t *loc, int64_t loclen,
_Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
const uint8_t *name, int64_t namelen,
const uint8_t *want, int64_t wantlen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: restart %.*s takes %.*s, and whatever took it supplied no "
"arguments — a restart with parameters cannot be taken from the "
@ -504,7 +583,7 @@ _Noreturn void flan_restart_unarmed(const uint8_t *loc, int64_t loclen,
* lexical case is refused by the checker; this is the one that reaches a
* function through a call, where nothing static could see it. */
_Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: a defer invoked a restart, which a defer may not do — it is "
"the cleanup a transfer runs on its way out\n",
@ -514,7 +593,7 @@ _Noreturn void flan_transfer_fail(const uint8_t *loc, int64_t loclen) {
_Noreturn void flan_slice_fail(const uint8_t *loc, int64_t loclen,
int64_t lo, int64_t hi, int64_t len) {
fflush(stdout);
rt_flush_out();
fprintf(stderr, "%.*s: slice [%lld %lld) is out of bounds for length %lld\n",
(int)loclen, (const char *)loc, (long long)lo, (long long)hi,
(long long)len);
@ -622,7 +701,7 @@ void flan_slice_error(const uint8_t *loc, int64_t loclen, int64_t lo,
* testing high <= length would wave the failure through. */
_Noreturn void flan_slice_promise_fail(const uint8_t *loc, int64_t loclen,
int64_t n) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: slice-from-ptr was promised %lld elements behind the pointer, "
"and a count of elements is never negative\n",
@ -696,7 +775,7 @@ static const uint8_t flan_arith_name[] = "ArithError";
* formatting is the unhandled path's job, and this is the unhandled path. */
static void flan_arith_fail(const uint8_t *loc, int64_t loclen, int32_t op,
int64_t lhs, int64_t rhs) {
fflush(stdout);
rt_flush_out();
switch (op) {
case FLAN_ARITH_DIV_ZERO:
fprintf(stderr, "%.*s: divide by zero: (/ %lld 0)\n", (int)loclen,
@ -1196,7 +1275,7 @@ void flan_alloc_free_all(flan_allocator *a, const uint8_t *loc, int64_t loclen)
}
_Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator is null — a zeroed Allocator was never given "
"one\n",
@ -1205,7 +1284,7 @@ _Noreturn void flan_null_alloc_fail(const uint8_t *loc, int64_t loclen) {
}
_Noreturn void flan_free_all_fail(const uint8_t *loc, int64_t loclen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: this allocator does not offer free-all — it has no region to "
"release, and releasing nothing is not the same as releasing "
@ -1261,7 +1340,7 @@ void flan_alloc_region_only(flan_allocator *a, const uint8_t *loc,
}
_Noreturn void flan_region_only_fail(const uint8_t *loc, int64_t loclen) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: this container's elements own storage, and this allocator can "
"free one block — so a free here would release the slots and leak "
@ -1339,7 +1418,7 @@ int64_t flan_alloc_id(flan_allocator *a) { return (int64_t)(intptr_t)a; }
_Noreturn void flan_vec_stale_fail(const uint8_t *loc, int64_t loclen,
int64_t was, int64_t now) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%.*s: this container's allocator was released — it was made at "
"epoch %lld and the allocator is at %lld now\n",
@ -1349,7 +1428,7 @@ _Noreturn void flan_vec_stale_fail(const uint8_t *loc, int64_t loclen,
_Noreturn void flan_vec_bounds_fail(const uint8_t *loc, int64_t loclen,
int64_t i, int64_t len) {
fflush(stdout);
rt_flush_out();
fprintf(stderr, "%.*s: index %lld is out of bounds for length %lld\n",
(int)loclen, (const char *)loc, (long long)i, (long long)len);
rt_die();
@ -2842,7 +2921,7 @@ int64_t flan_file_fail_reason(void) { return flan_file_fail; }
* so this traps naming the declare-c that was called, the way an out-of-bounds
* index traps naming its site. See lib/shim.ml, which emits the call. */
_Noreturn void flan_shim_nul_fail(const char *site) {
fflush(stdout);
rt_flush_out();
fprintf(stderr,
"%s: a string passed to C contains a NUL byte — C reads to the "
"first one, so the value this function would act on is a prefix of "

8
spike/js/survey.sh
View File

@ -59,9 +59,11 @@ fi
corpus=${SURVEY_CORPUS:-$root}
out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
# The two that run until something stops them, excluded by name for the reason
# the x86 sweep excludes them: a timeout cannot tell them from a hang.
forever="dev-loop dev-watch"
# The ones that run until something stops them, excluded by name for the reason
# the x86 sweep excludes them: a timeout cannot tell them from a hang -- and in
# dev-chatty's case cannot even give the two sides the same truncation, since
# it prints 4K a frame for as long as it is allowed to.
forever="dev-loop dev-watch dev-chatty"
TIMEOUT=${TIMEOUT:-20}

13
spike/x86/survey.sh
View File

@ -64,10 +64,19 @@ corpus=${SURVEY_CORPUS:-$root}
out=$(mktemp -d); trap 'rm -rf "$out"' EXIT
# The two that run until something stops them. Not a failure and not a match;
# The ones that run until something stops them. Not a failure and not a match;
# they are excluded by name because a timeout cannot tell them apart from a
# backend that hung.
forever="dev-loop dev-watch"
#
# dev-chatty is the third and is here for a sharper reason than the other two.
# It also outlives the timeout -- it is sized to outlast test_dev's checks and
# is killed with the connection -- but what makes it unusable here is that it
# *prints* while it does, 4K a frame. Two backends stopped by a clock stop at
# different lines, so the diff is a report about scheduling rather than about
# lowering, and it fails the alias every run. dev-repl outlives the timeout in
# the same way and is not listed, because it prints nothing and the two
# truncations are both empty.
forever="dev-loop dev-watch dev-chatty"
TIMEOUT=${TIMEOUT:-20}

41
test/programs/dev-chatty.flan Normal file
View File

@ -0,0 +1,41 @@
;;;; A program that prints far more than a pipe holds, for the one failure a
;;;; quiet fixture cannot reach.
;;;;
;;;; In a merged `flan dev' the program's stdout is a 64K pipe back into the
;;;; same process, and the only thing reading it is the daemon's accept loop —
;;;; which is not running while the daemon is answering a request. Every other
;;;; fixture here prints a line or two per frame, so the pipe never fills and
;;;; the arrangement looks sound. This one prints 4K per frame, which fills 64K
;;;; in sixteen frames: less time than a module takes to build. By the time an
;;;; evaluation is delivered the game thread is stopped inside fwrite, and it
;;;; stays there until somebody reads — so a daemon that waits for a frame
;;;; boundary without draining waits for one that cannot arrive, and then says
;;;; the program is not calling (agent/poll).
;;;;
;;;; It is calling it. See lib/dev.ml's [eval_expr], which drains every tick.
(import agent "vendor:agent")
;;; Counted so that an evaluation has something of the program's own to read,
;;; and so a transcript can be checked for progress rather than only for text.
(defvar frames i64)
(defn chatter [] i64
;; Sixty-four lines of sixty-three characters and a newline: 4096 bytes a
;; frame, written through the line buffer flan_rt.c asks for, so each line
;; is its own write and the block happens in the middle of a frame rather
;; than at a flush somewhere else.
(dotimes [i 64]
(println "..............................................................."))
(set frames (+ frames 1))
frames)
(defn main [] i32
(agent/start "/tmp/flan-dev-chatty-fallback.sock")
;; 24000 for dev-repl.flan's reason: the test closes the connection when it
;; is done and the daemon takes the program with it, so the count only has
;; to outlast the checks. A program that reached its last frame mid-test
;; would fail honestly and for the wrong reason.
(dotimes [i 24000]
(chatter)
(agent/wait 1))
0)

96
test/test_dev.ml
View File

@ -2329,6 +2329,102 @@ let () =
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ ssock; sout ];
(* ── A program that prints more than the pipe holds ─────────────── *)
(* The one thing every other fixture in this file is too quiet to reach.
In a merged build the program's stdout is a 64K pipe back into the
daemon's own process, and the only reader is the select in
[Dev.accept_loop] — which is not running while [serve] is answering a
request. [programs/dev-chatty.flan] prints 4K a frame, so those 64K are
full within sixteen frames, which is far less than a module takes to
build. The game thread is then stopped inside [fwrite] and reaches no
frame boundary at all; the thunk this evaluation delivers has nowhere to
run.
What that used to produce was five seconds of polling and then "the
program did not reach a frame boundary; is it calling (agent/poll)?" —
about a program whose every frame calls it. A diagnostic that names the
wrong cause is worse than none, because it is believed.
Three claims, and the third is not decoration. The value comes back, so
the thunk ran. The reply is not the frame-boundary sentence, so the
timeout is not being reached by some other route. And the program's text
rides on the reply as [:output] — which is the claim that the drain went
through [Dev.drain] and not [Dev.take]: a wait that took the buffer and
threw it away would satisfy the first two and silently delete the output
the evaluation itself caused, which is the output anyone wants to see. *)
let csock = tmp "chatty.sock" and cout = tmp "chatty.out" in
(try Sys.remove csock with Sys_error _ -> ());
let cfd = Unix.openfile cout [ Unix.O_WRONLY; Unix.O_CREAT; Unix.O_TRUNC ] 0o600 in
let cpid =
Unix.create_process flan
[| flan; "dev"; "programs/dev-chatty.flan"; "-s"; csock |]
Unix.stdin cfd Unix.stderr
in
Unix.close cfd;
if not (listening ~pid:cpid csock) then begin
fail "the chatty daemon %s" !listen_why;
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ())
end
else begin
let c = connect csock in
(* Long enough for the program to have run the sixteen frames that fill
the pipe before anything is asked of the daemon. It prints at 4K a
frame with a 1ms wait between them, so this is an order of magnitude
more than it needs — the point is only that the pipe is full when the
request lands, not how full. *)
ignore (Unix.select [] [] [] 0.3);
let started = Unix.gettimeofday () in
let r =
request c "(:op \"eval-expr\" :code \"(+ 20 22)\" :file \"/tmp/chatty.flan\")"
in
let took = Unix.gettimeofday () -. started in
let said = Option.value ~default:"" (Wire.string_field r "message") in
if status r <> "ok" then
fail "evaluating against a program that is printing: %s" said
else if Wire.string_field r "value" <> Some "42" then
fail "the value from a printing program is %s"
(Option.value ~default:"none" (Wire.string_field r "value"));
if contains_sub said "agent/poll" then
fail
"a printing program was diagnosed as one that is not polling, which \
is the defect and not the symptom";
(* The only job this number has is to sit under the daemon's own
five-second wait, so that "it answered" and "it gave up" cannot be
confused. It is not a measurement of how fast a module builds, and it
is deliberately not tightened into one: [listening] above records 6.8s
for a cold build under dune's parallelism, and a suite that goes red
on a loaded machine teaches whoever is running it to skim past red.
The two assertions that actually discriminate are the status and the
absence of the frame-boundary sentence; this one only rules out a
timeout that somehow reported success. *)
if took > 4.5 then
fail "evaluating against a printing program took %.1fs" took;
(* And the program's own text came back on the reply rather than being
drained into nothing. *)
(match Wire.string_field r "output" with
| Some o when contains_sub o "......" -> ()
| Some _ -> fail "the reply carried output, but not the program's"
| None ->
fail
"the evaluation drained the program's pipe and kept none of it, so \
the output it caused is gone");
ignore (request c "(:op \"close\")");
(try Unix.close c with Unix.Unix_error _ -> ());
if not
(await ~ms:5000 (fun () ->
match Unix.waitpid [ Unix.WNOHANG ] cpid with
| 0, _ -> false
| _ -> true
| exception Unix.Unix_error _ -> true))
then begin
(try Unix.kill cpid Sys.sigkill with Unix.Unix_error _ -> ());
(try ignore (Unix.waitpid [] cpid) with Unix.Unix_error _ -> ())
end
end;
List.iter (fun f -> try Sys.remove f with Sys_error _ -> ()) [ csock; cout ];
(* --debug, and the half the IR cannot show.
[test_session.ml] asserts that a debug session *emits* the metadata,