perf(subprocess): read process output in chunks, preserving C-g
ober
7f011b5ef76423efad3e15940a40217a6ee43790
--- a/src/jerboa-emacs/repl.ss +++ b/src/jerboa-emacs/repl.ss @@ -66,8 +66,9 @@ "")) (cmd (string-append "scheme -q" libdirs-arg))) ;; Chez open-process-ports returns: (write-stdin read-stdout read-stderr pid) + ;; block buffering lets repl-read-available read whole buffers via get-string-some (let-values (((p-stdin p-stdout p-stderr pid) - (open-process-ports cmd (buffer-mode none) (native-transcoder)))) + (open-process-ports cmd (buffer-mode block) (native-transcoder)))) (close-port p-stderr) (let ((rs (make-repl-state (cons p-stdout p-stdin) 0 '()))) ;; Boot the jerboa REPL: import and start it @@ -142,15 +143,17 @@ (def (repl-read-available rs) "Read all available output from the Jerboa REPL subprocess (non-blocking). - Strips ANSI escape codes. Returns a string, or #f if nothing available." + Strips ANSI escape codes. Returns a string, or #f if nothing available. + Reads in chunks via get-string-some; the char-ready? guard never blocks + waiting for a full buffer, keeping the REPL responsive to C-g." (let ((in-port (car (repl-state-process rs)))) (if (char-ready? in-port) (let ((out (open-output-string))) (let loop () (when (char-ready? in-port) - (let ((ch (read-char in-port))) - (unless (eof-object? ch) - (write-char ch out) + (let ((s (get-string-some in-port))) + (unless (eof-object? s) + (put-string out s) (loop))))) (let ((s (strip-ansi (get-output-string out)))) (if (string-empty? s) #f s))) --- a/src/jerboa-emacs/subprocess.ss +++ b/src/jerboa-emacs/subprocess.ss @@ -32,14 +32,17 @@ ;;;============================================================================ (def (drain-available! proc out) - "Read all immediately available chars from PROC into OUT. - Returns #t if EOF was reached, #f otherwise." + "Read all immediately available output from PROC into OUT in chunks. + Returns #t if EOF was reached, #f otherwise. Uses get-string-some so each + step pulls a whole buffer of ready chars instead of one char at a time; the + char-ready? guard means we never block waiting for a full buffer, so the + caller's C-g check between drains stays responsive." (let loop () (if (char-ready? proc) - (let ((ch (read-char proc))) - (if (eof-object? ch) + (let ((s (get-string-some proc))) + (if (eof-object? s) #t - (begin (write-char ch out) (loop)))) + (begin (put-string out s) (loop)))) #f))) ;;;============================================================================ @@ -57,8 +60,9 @@ Returns (values output-string exit-status). Raises keyboard-quit-exception on C-g." ;; open-process-ports returns (write-stdin read-stdout read-stderr pid) + ;; block buffering lets drain-available! read whole buffers via get-string-some (let-values (((p-stdin p-stdout p-stderr pid) - (open-process-ports cmd (buffer-mode none) (native-transcoder)))) + (open-process-ports cmd (buffer-mode block) (native-transcoder)))) (dynamic-wind (lambda () (set! *active-subprocess* (cons p-stdin p-stdout))) (lambda () @@ -100,8 +104,9 @@ Raises keyboard-quit-exception on C-g. NOTE: Omits process-status (hangs in Qt due to SIGCHLD race)." ;; open-process-ports returns (write-stdin read-stdout read-stderr pid) + ;; block buffering lets drain-available! read whole buffers via get-string-some (let-values (((p-stdin p-stdout p-stderr pid) - (open-process-ports cmd (buffer-mode none) (native-transcoder)))) + (open-process-ports cmd (buffer-mode block) (native-transcoder)))) (dynamic-wind (lambda () (set! *active-subprocess* (cons p-stdin p-stdout))) (lambda () --- a/tests/test-term-hang.ss +++ b/tests/test-term-hang.ss @@ -268,6 +268,53 @@ (lambda () (thread-terminate! t)))) ;;;=========================================================================== +;;; 5b. Chunked reads: large output stays complete, slow output interruptible +;;;=========================================================================== + +(display "--- CHUNKED: large output is read completely and correctly ---\n") +;; seq 1 20000 emits ~108KB. The chunked drain (get-string-some) must capture +;; all of it, not just the first buffer-full. +(let* ((fake-peek (lambda (ms) (thread-sleep! (/ ms 1000.0)) #f)) + (fake-key? (lambda (ev) #f)) + (fake-key (lambda (ev) 0))) + (let-values (((output status) + (run-process-interruptible + "seq 1 20000" fake-peek fake-key? fake-key))) + (check (> (string-length output) 100000) => #t) + (check (not (eq? #f (string-contains output "20000"))) => #t))) + +(display "--- CHUNKED: small output still works ---\n") +(let* ((fake-peek (lambda (ms) (thread-sleep! (/ ms 1000.0)) #f)) + (fake-key? (lambda (ev) #f)) + (fake-key (lambda (ev) 0))) + (let-values (((output status) + (run-process-interruptible + "/bin/echo chunk-ok" fake-peek fake-key? fake-key))) + (check (not (eq? #f (string-contains output "chunk-ok"))) => #t))) + +(display "--- CHUNKED: slow-drip output stays interruptible (C-g between chunks) ---\n") +;; A subprocess that drips one line every 0.3s for ~60s. The chunked read must +;; return to the C-g checkpoint between drips instead of blocking on a full +;; buffer; a C-g after ~1s must raise keyboard-quit long before the command ends. +(let* ((start-time (time-second (current-time))) + (fake-peek (lambda (ms) + (thread-sleep! (/ ms 1000.0)) + (if (> (- (time-second (current-time)) start-time) 1.0) + 'fake-event + #f))) + (fake-key? (lambda (ev) (eq? ev 'fake-event))) + (fake-key (lambda (ev) 7)) ;; 7 = C-g + (interrupted? #f)) + (guard (e [else (when (keyboard-quit-exception? e) + (set! interrupted? #t))]) + (run-process-interruptible + "for i in $(seq 1 200); do echo tick; sleep 0.3; done" + fake-peek fake-key? fake-key)) + (check interrupted? => #t) + (let ((elapsed (- (time-second (current-time)) start-time))) + (check (< elapsed 10.0) => #t))) + +;;;=========================================================================== ;;; 6. Summary report ;;;===========================================================================