diff --git a/lib/dev.ml b/lib/dev.ml index c671d76..b13b8e1 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 = @@ -657,6 +664,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 @@ -1023,6 +1059,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 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 32c67df..6416766 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -2293,6 +2293,97 @@ 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 wait is five seconds, so anything near it is the timeout being + reached rather than a slow machine. Two is the compromise: a cold + [llc] under dune's own parallelism is comfortably inside it, and a + run that blocked is comfortably outside. *) + if took > 2.0 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,