From 8a94f16acde0a0d70a7ac02f12771794f684cff7 Mon Sep 17 00:00:00 2001 From: Joseph Ferano Date: Fri, 11 Sep 2026 07:05:50 +0700 Subject: [PATCH] The program's output goes where someone is looking at it Its stdout is a pipe into the daemon now, and whatever it printed since the last reply rides along with the next one into *flan-output*. Arriving with a reply rather than by a separate request is the point: the output an evaluation itself caused is the output anyone wants to see. Draining that pipe is a liveness requirement, 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 whether or not an editor is asking, and the buffer is capped - a program printing every frame must not grow the daemon without limit, and the newest text is the useful end. test_dev read the program's transcript off the daemon's stdout, which is no longer where it goes; it collects :output from replies instead, which is also what the editor does. The emacs test moved to a fixture that keeps running, since it now evaluates more times than the old one had reloads to give. --- NEXT.md | 11 ++++++ emacs/flan-dev.el | 33 ++++++++++++++++-- emacs/flan-mode.el | 2 ++ emacs/test-flan-dev.el | 10 ++++++ lib/dev.ml | 67 ++++++++++++++++++++++++++++++++++--- test/programs/dev-repl.flan | 2 +- test/test_dev.ml | 39 ++++++++++++++------- test/test_emacs.ml | 4 +-- 8 files changed, 146 insertions(+), 22 deletions(-) diff --git a/NEXT.md b/NEXT.md index 1f33afe..9b8ce36 100644 --- a/NEXT.md +++ b/NEXT.md @@ -686,6 +686,7 @@ of the protocol choice: `prin1` writes a request and `read` reads a reply. | `C-c C-k` | the whole buffer, as **one** module | | `C-x C-e` | the expression before point, evaluated *in the running program* | | `C-c C-z` / `C-c C-q` | connect (finds `.flan-dev.sock` upward) / disconnect | +| `C-c C-o` | the running program's own output, in `*flan-output*` | | `C-c C-d` | what the running program currently defines | `C-c C-k` sends one module rather than a form at a time on purpose: a `defvar` @@ -704,6 +705,16 @@ syntax table, or in the reply reader passes `test_dev.ml` and fails here. An error comes back with a location and the client moves point to it when it is this buffer. +**The program's stdout is a pipe into the daemon**, and whatever it printed +since the last reply rides along with the next one into `*flan-output*`. Having +it arrive *with* a reply rather than by a separate request is the point: the +output an evaluation itself caused is the output anyone wants to see. Draining +that pipe is 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 an editor asks, and the buffer is +capped so a program printing every frame cannot grow the daemon without +limit. + ### `C-x C-e` — evaluating an expression A different primitive from redefining a name, and the difference is the whole diff --git a/emacs/flan-dev.el b/emacs/flan-dev.el index 065fa67..d5c8736 100644 --- a/emacs/flan-dev.el +++ b/emacs/flan-dev.el @@ -37,6 +37,10 @@ "Whether a successful evaluation reports in the echo area." :type 'boolean) +(defcustom flan-dev-output-buffer "*flan-output*" + "Buffer the running program's own output is appended to." + :type 'string) + (defvar flan-dev--connection nil "The open connection, or nil.") @@ -84,11 +88,27 @@ (delete-region (point-min) end) form))))) +(defun flan-dev--append-output (text) + "Append TEXT, the running program's own output, to its buffer." + (when (and text (> (length text) 0)) + (with-current-buffer (get-buffer-create flan-dev-output-buffer) + (let ((at-end (= (point) (point-max)))) + (save-excursion + (goto-char (point-max)) + (insert text)) + ;; Follow the tail only for someone who was already at it; a reader + ;; scrolled back is reading something. + (when at-end (goto-char (point-max))))))) + (defun flan-dev--request (form) "Send FORM to the connected program and return its reply." - (let ((proc (flan-dev--live-connection))) - (flan-dev--send proc form) - (flan-dev--read-reply proc))) + (let* ((proc (flan-dev--live-connection)) + (reply (progn (flan-dev--send proc form) + (flan-dev--read-reply proc)))) + ;; Whatever the program printed since the last reply rides along with this + ;; one, so the output an evaluation itself caused arrives with its result. + (flan-dev--append-output (plist-get reply :output)) + reply)) ;;; Connection @@ -138,6 +158,13 @@ With no argument, look for `flan-dev-socket-name' up from this buffer." (setq flan-dev--connection nil) (message "flan dev: disconnected")) +;;;###autoload +(defun flan-show-output () + "Show the running program's output, after collecting anything pending." + (interactive) + (ignore-errors (flan-dev--request '(:op "describe"))) + (display-buffer (get-buffer-create flan-dev-output-buffer))) + (defun flan-describe () "Report what the running program currently defines." (interactive) diff --git a/emacs/flan-mode.el b/emacs/flan-mode.el index 8e2156d..e5287df 100644 --- a/emacs/flan-mode.el +++ b/emacs/flan-mode.el @@ -17,6 +17,7 @@ (declare-function flan-connect "flan-dev") (declare-function flan-disconnect "flan-dev") (declare-function flan-describe "flan-dev") +(declare-function flan-show-output "flan-dev") (defgroup flan nil "Editing and evaluating Flan." @@ -76,6 +77,7 @@ (define-key map (kbd "C-c C-z") #'flan-connect) (define-key map (kbd "C-c C-q") #'flan-disconnect) (define-key map (kbd "C-c C-d") #'flan-describe) + (define-key map (kbd "C-c C-o") #'flan-show-output) map) "Keymap for `flan-mode'.") diff --git a/emacs/test-flan-dev.el b/emacs/test-flan-dev.el index ce9277b..c77eae5 100644 --- a/emacs/test-flan-dev.el +++ b/emacs/test-flan-dev.el @@ -65,6 +65,16 @@ ;; The session is not poisoned by that: a good form still lands. (flan-dev--eval "(defn step [] i64 (set ticks (+ ticks 100)) ticks)" "form") + ;; The program's own output arrives on replies and lands in its buffer, so + ;; a long-running program is not writing into a terminal nobody is watching. + (flan-dev--eval "(defn step [] i64 (do (print-line \"HELLO\") ticks))" "form") + (let ((seen nil) (deadline (+ (float-time) 10))) + (while (and (not seen) (< (float-time) deadline)) + (ignore-errors (flan-dev--request '(:op "describe"))) + (setq seen (with-current-buffer (get-buffer-create flan-dev-output-buffer) + (string-match-p "HELLO" (buffer-string))))) + (test-flan--check "the program's output reaches its buffer" seen)) + (flan-disconnect) (test-flan--check "disconnected" (not (process-live-p flan-dev--connection))) diff --git a/lib/dev.ml b/lib/dev.ml index e7bc3ce..b6ec136 100644 --- a/lib/dev.ml +++ b/lib/dev.ml @@ -18,9 +18,47 @@ type t = { child : int; (* the running program *) agent : string; (* where it listens for modules *) dir : string; (* modules are built here, one per eval *) + stdout : Unix.file_descr; (* the program's output, on its way to here *) + out : Buffer.t; (* ...buffered until an editor asks for it *) mutable n : int; (* dlopen caches by path: never reuse one *) } +(* 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. *) +let capacity = 256 * 1024 + +let drain t = + let b = Bytes.create 8192 in + let rec go () = + match Unix.select [ t.stdout ] [] [] 0. with + | [], _, _ -> () + | _ -> + (match Unix.read t.stdout b 0 8192 with + | 0 -> () + | n -> + Buffer.add_subbytes t.out b 0 n; + (* Bounded: a program that prints every frame must not grow this + process without limit. The newest text is the useful end. *) + if Buffer.length t.out > capacity then begin + let keep = Buffer.sub t.out (Buffer.length t.out - capacity) capacity in + Buffer.clear t.out; + Buffer.add_string t.out keep + end; + go () + | exception Unix.Unix_error (Unix.EAGAIN, _, _) -> () + | exception Unix.Unix_error (Unix.EWOULDBLOCK, _, _) -> () + | exception Unix.Unix_error _ -> ()) + in + go () + +let take t = + drain t; + let s = Buffer.contents t.out in + Buffer.clear t.out; + s + let await ?(ms = 5000) f = let rec go ms = if f () then true @@ -101,6 +139,16 @@ let alive t = let ok fields = "(:status \"ok\"" ^ String.concat "" (List.map (fun f -> " " ^ f) fields) ^ ")" +(* Anything the program printed since the last reply rides along with this one. + An editor that had to ask separately would miss the output an evaluation + itself caused, which is the output anyone actually wants to see. *) +let with_output t reply = + match take t with + | "" -> reply + | text -> + let i = String.length reply - 1 in + String.sub reply 0 i ^ " :output " ^ Wire.quote text ^ ")" + let error ?loc msg = "(:status \"error\" :message " ^ Wire.quote msg ^ (match loc with None -> "" | Some l -> " :loc " ^ Wire.quote l) @@ -229,7 +277,7 @@ let serve t fd = | req -> (Wire.string_field req "op", handle t req) | exception Loc.Error (_, m) -> (None, error ("bad request: " ^ m)) in - Wire.send fd reply; + Wire.send fd (with_output t reply); if op = Some "close" then true else go () | exception Wire.Closed -> false | exception Unix.Unix_error _ -> false @@ -255,7 +303,12 @@ let start ~file ~sock = environment. Guessing instead would fail silently — everything compiles, the module is built, and nothing ever receives it. *) Unix.putenv "FLAN_AGENT_SOCKET" agent; - let child = Unix.create_process exe [| exe |] Unix.stdin Unix.stdout Unix.stderr in + (* Through a pipe, so the program's own output can reach an editor instead of + only the terminal the daemon was started in. *) + let rd, wr = Unix.pipe ~cloexec:false () in + let child = Unix.create_process exe [| exe |] Unix.stdin wr Unix.stderr in + Unix.close wr; + Unix.set_nonblock rd; (* Wait for it to bind before accepting an evaluation. One that arrives first would fail for a reason that reads like a compiler bug. *) @@ -266,7 +319,9 @@ let start ~file ~sock = ^ " — does it call (agent/start ...)?") end; - let t = { session; child; agent; dir; n = 0 } in + let t = + { session; child; agent; dir; stdout = rd; out = Buffer.create 4096; n = 0 } + in (try Unix.unlink sock with Unix.Unix_error _ -> ()); let ls = Unix.socket Unix.PF_UNIX Unix.SOCK_STREAM 0 in Unix.bind ls (Unix.ADDR_UNIX sock); @@ -279,8 +334,11 @@ let start ~file ~sock = wait forever. *) let rec accept_loop () = if alive t then - match Unix.select [ ls ] [] [] 0.2 with + (* The program's pipe is in the same select as the listening socket: it + has to be drained whether or not an editor is asking for anything. *) + match Unix.select [ ls; t.stdout ] [] [] 0.2 with | [], _, _ -> accept_loop () + | ready, _, _ when not (List.mem ls ready) -> drain t; accept_loop () | _ -> (match Unix.accept ls with | fd, _ -> @@ -294,5 +352,6 @@ let start ~file ~sock = ~finally:(fun () -> (try Unix.kill child Sys.sigterm with Unix.Unix_error _ -> ()); (try Unix.close ls with Unix.Unix_error _ -> ()); + (try Unix.close rd with Unix.Unix_error _ -> ()); (try Unix.unlink sock with Unix.Unix_error _ -> ())) accept_loop diff --git a/test/programs/dev-repl.flan b/test/programs/dev-repl.flan index 6813383..a5da7ec 100644 --- a/test/programs/dev-repl.flan +++ b/test/programs/dev-repl.flan @@ -10,7 +10,7 @@ (defconst step-by i64 3) (defn step [] i64 - (set ticks (+ ticks step-by)) + (set ticks (+ ticks 1)) ticks) (defn main [] i32 diff --git a/test/test_dev.ml b/test/test_dev.ml index 1383a69..1bdc2d3 100644 --- a/test/test_dev.ml +++ b/test/test_dev.ml @@ -28,7 +28,17 @@ let rec connect ?(ms = 5000) path = ignore (Unix.select [] [] [] 0.005); connect ~ms:(ms - 5) path -let request fd sexp = Wire.send fd sexp; Wire.parse (Wire.recv fd) +(* The program's own output arrives on the replies, not on a file: the daemon + reads its stdout through a pipe so an editor can see it. Every reply is + drained into here, which is also what an editor does. *) +let output = Buffer.create 256 + +let request fd sexp = + let r = Wire.parse (Wire.send fd sexp; Wire.recv fd) in + (match Wire.string_field r "output" with + | Some t -> Buffer.add_string output t + | None -> ()); + r let status r = match Wire.string_field r "status" with Some s -> s | None -> "" @@ -57,13 +67,20 @@ let () = (* The daemon owns the program's lifetime and kills it on [close], so every step waits for the program to have got there. "ok" from an eval means the module was queued, not that it has been installed. *) - let lines () = - List.length - (String.split_on_char '\n' - (In_channel.with_open_bin out In_channel.input_all)) - - 1 - in let c = connect sock in + (* The daemon owns the program's lifetime and kills it on [close], so + every step waits for the program to have got there. "ok" from an eval + means the module was queued, not that it has been installed. Output + only rides along with a reply, so asking is how it is collected, and + [describe] is the cheapest question there is. *) + let lines () = + List.length (String.split_on_char '\n' (Buffer.contents output)) - 1 + in + let settle n = + await (fun () -> + ignore (request c "(:op \"describe\")"); + lines () >= n) + in (* describe: what the daemon believes about the program it launched. *) let r = request c "(:op \"describe\")" in @@ -91,8 +108,7 @@ let () = Both queued at once is a legitimate thing for the agent to do — one poll installs everything pending — but then only the last is observed and the sequencing is not what was tested. *) - if not (await (fun () -> lines () >= 2)) then - fail "the first reload was never installed"; + if not (settle 2) then fail "the first reload was never installed"; let r = request c "(:op \"eval\" :code \"(defn step [] i64 (set extra (+ extra 100)) extra)\" :file \"/tmp/buf.flan\")" @@ -111,8 +127,7 @@ let () = | None -> false) then fail "retyping a global was not refused"; - if not (await (fun () -> lines () >= 3)) then - fail "the second reload was never installed"; + if not (settle 3) then fail "the second reload was never installed"; (* Expression evaluation, which is a different primitive: no name to install a body into, so a thunk runs at a frame boundary and the value @@ -127,7 +142,7 @@ let () = proof: 1 before any reload, 5 from a body over a var that did not exist when it started, 105 from a second body reading the same one. *) ignore (Unix.waitpid [] pid); - let text = In_channel.with_open_bin out In_channel.input_all in + let text = Buffer.contents output in if text <> "1\n5\n105\n" then fail "program transcript\n got: %S\n wanted: %S" text "1\n5\n105\n" end; diff --git a/test/test_emacs.ml b/test/test_emacs.ml index 963f3a4..79119a6 100644 --- a/test/test_emacs.ml +++ b/test/test_emacs.ml @@ -29,7 +29,7 @@ let () = let flan = "../bin/main.exe" in let pid = Unix.create_process flan - [| flan; "dev"; "programs/dev-loop.flan"; "-s"; sock |] + [| flan; "dev"; "programs/dev-repl.flan"; "-s"; sock |] Unix.stdin fd Unix.stderr in Unix.close fd; @@ -46,7 +46,7 @@ let () = (try Sys.remove buf with Sys_error _ -> ()); ignore (Sys.command - (Printf.sprintf "cp %s %s" (Filename.quote "programs/dev-loop.flan") + (Printf.sprintf "cp %s %s" (Filename.quote "programs/dev-repl.flan") (Filename.quote buf))); (try Unix.chmod buf 0o644 with Unix.Unix_error _ -> ()); let code =