diff --git a/lib/dev.ml b/lib/dev.ml index 01762a5..0d3ec30 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -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); diff --git a/runtime/flan_rt.c b/runtime/flan_rt.c index 3105bad..75ac84d 100644 --- a/runtime/flan_rt.c +++ b/runtime/flan_rt.c @@ -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 +#endif +#include + +/* 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 " diff --git a/spike/js/survey.sh b/spike/js/survey.sh index b1b79b9..646c7fa 100755 --- a/spike/js/survey.sh +++ b/spike/js/survey.sh @@ -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} diff --git a/spike/x86/survey.sh b/spike/x86/survey.sh index 1eb0fdd..85ac83d 100755 --- a/spike/x86/survey.sh +++ b/spike/x86/survey.sh @@ -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} diff --git a/test/programs/dev-chatty.flan b/test/programs/dev-chatty.flan new file mode 100644 index 0000000..d82764c --- /dev/null +++ b/test/programs/dev-chatty.flan @@ -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) diff --git a/test/test_dev.ml b/test/test_dev.ml index f366138..8f82476 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -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,