Fix debug REPL and stress test robustness
ober
06460b8bf202c4f5854fb0a1b19ba5258c483b15
--- a/CLAUDE.md +++ b/CLAUDE.md @@ -67,7 +67,7 @@ The editor has automated stress testing infrastructure for finding segfaults. Se `vendor/qt_shim.cpp` includes a SIGSEGV/SIGBUS/SIGABRT crash reporter that: - Records the last 64 FFI calls in a lock-free ring buffer -- On crash, writes a diagnostic report to `~/.jemacs-crash.log` with the FFI ring buffer and native backtrace +- On crash, writes a diagnostic report to `~/.jemacs-crash.log` with signal details and the FFI ring buffer - Re-raises the signal so gdb/core dumps still work The crash reporter is automatically installed when `qt_application_create()` is called. No configuration needed. @@ -89,10 +89,10 @@ Override the REPL port: `make stress-test STRESS_PORT=8888` Connects to jemacs-qt's `--repl` TCP interface via `nc` subprocess and drives random editor commands in a continuous loop until the editor crashes (connection drops). Runs 10 stress phases per cycle: 1. **Window Chaos** — split/delete/balance windows randomly -2. **Vterm Storm** — open multiple vterm buffers +2. **Vterm Storm** — open multiple vterm buffers and run bounded shell commands 3. **File Churn** — create/open/edit/kill temp files, copy/paste between buffers 4. **Navigation Stress** — rapid cursor movement and scrolling -5. **EWW** — web browser buffer +5. **Scratch Buffer** — prompt-free buffer navigation 6. **Edit Storm** — insert/delete/undo/redo 7. **Buffer Management** — open many buffers, rapid switching 8. **Combined Chaos** — random mix of all operations @@ -100,7 +100,7 @@ Connects to jemacs-qt's `--repl` TCP interface via `nc` subprocess and drives ra 10. **Search Operations** — word-motion navigation All commands are logged to `stress-test.log` with timestamps. When a crash occurs: -- `~/.jemacs-crash.log` shows the FFI call ring buffer and backtrace +- `~/.jemacs-crash.log` shows signal details and the FFI call ring buffer - `stress-test.log` shows the exact command sequence that triggered it - gdb (in `stress-burn-static`) shows the native stack trace --- a/Makefile +++ b/Makefile @@ -1086,6 +1086,7 @@ stress-burn: build repl_shim.so libqt_shim.so vterm_shim.so qt_chez_shim.so @PORT=$$(grep -oP '\d+' $(HOME)/.jerboa-repl-port); \ echo "jemacs-qt running on REPL port $$PORT"; \ $(SCHEME) $(LIBDIRS) --script tests/stress-test.ss --port $$PORT; \ + STATUS=$$?; \ echo ""; \ echo "=== Stress test ended ==="; \ if [ -f $(HOME)/.jemacs-crash.log ]; then \ @@ -1093,7 +1094,8 @@ stress-burn: build repl_shim.so libqt_shim.so vterm_shim.so qt_chez_shim.so cat $(HOME)/.jemacs-crash.log; \ fi; \ echo "=== STRESS LOG (last 50 lines) ==="; \ - tail -50 stress-test.log 2>/dev/null + tail -50 stress-test.log 2>/dev/null; \ + exit $$STATUS # All-in-one: launch static jemacs-qt under gdb + run stress test driver stress-burn-static: @@ -1117,6 +1119,7 @@ stress-burn-static: @PORT=$$(grep -oP '\d+' $(HOME)/.jerboa-repl-port); \ echo "jemacs-qt (static) running under gdb on REPL port $$PORT"; \ $(SCHEME) $(LIBDIRS) --script tests/stress-test.ss --port $$PORT; \ + STATUS=$$?; \ echo ""; \ echo "=== Stress test ended ==="; \ if [ -f $(HOME)/.jemacs-crash.log ]; then \ @@ -1124,7 +1127,8 @@ stress-burn-static: cat $(HOME)/.jemacs-crash.log; \ fi; \ echo "=== STRESS LOG (last 50 lines) ==="; \ - tail -50 stress-test.log 2>/dev/null + tail -50 stress-test.log 2>/dev/null; \ + exit $$STATUS # ============================================================================= # Scenario runner — coherent user workflows, screenshots, assertions, hours --- a/docs/repl-server.md +++ b/docs/repl-server.md @@ -93,11 +93,10 @@ Connection closed. - Binds to `127.0.0.1` only — no remote access - Optional `--repl-token <token>` flag; if set, the first line from each client must be the token or the connection is dropped -- The port file (`~/.jemacs-repl-port`) is written with mode `0600` -- **No** `system`, `shell-command`, or `open-process` in the REPL sandbox - (the evaluator runs in a restricted environment that omits dangerous - primitives — but since this is a debug tool for localhost, the restriction - is advisory) +- The port file (`~/.jerboa-repl-port`) is written with mode `0600` +- This is a full-power debug REPL, not a sandbox. It intentionally evaluates + expressions in the live editor environment; use localhost binding and + `--repl-token` when exposing it during tests. ## Implementation Plan @@ -121,7 +120,7 @@ Create `debug-repl.ss` in the repository root: 1. Call `open-tcp-server` on `127.0.0.1:port-num` 2. Save the server port in `*debug-repl-server*` -3. Write `~/.jemacs-repl-port` with the actual port number (supports port 0 +3. Write `~/.jerboa-repl-port` with the actual port number (supports port 0 for auto-assign) 4. Spawn an accept loop thread (`debug-repl-accept`) that calls `read` on the server to accept connections @@ -192,7 +191,7 @@ Create `debug-repl.ss` in the repository root: #### `(stop-debug-repl!)` 1. Close `*debug-repl-server*` -2. Delete `~/.jemacs-repl-port` +2. Delete `~/.jerboa-repl-port` 3. Terminate all client handler threads #### `(debug-repl-port)` @@ -219,8 +218,9 @@ was requested). ...existing cleanup...)))))) ``` -Also support `JEMACS_REPL_PORT` environment variable as an alternative to the -CLI flag (easier for always-on usage). +Also support `JEMACS_REPL_PORT` and `JEMACS_REPL_TOKEN` environment variables +as alternatives to the CLI flags (easier for always-on usage). Qt also accepts +the legacy `GEMACS_REPL_PORT` spelling for older scripts. ### Step 3: Wire Into `qt/main.ss` (Qt) @@ -238,10 +238,9 @@ In `qt/app.ss :: qt-do-init!`, after the IPC server start: ### Step 4: Port File Discovery -Write `~/.jemacs-repl-port` containing: +Write `~/.jerboa-repl-port` containing: ``` PORT=4242 -PID=12345 ``` Claude can discover the port by reading this file, then connecting via: @@ -258,7 +257,7 @@ Add a convenience function for Claude's `gerbil_eval` tool to connect: (begin (def (jemacs-repl-query expr-string) (let ((port-info (call-with-input-file - (path-expand "~/.jemacs-repl-port") + (path-expand "~/.jerboa-repl-port") read-line))) ;; Parse port number (let* ((port-num (string->number --- a/docs/stress-test.md +++ b/docs/stress-test.md @@ -6,7 +6,7 @@ jemacs-qt segfaults in production use. The static binary provides no diagnostic information — it just dies. We need two things: 1. **Crash reporting** — when a segfault happens, capture useful diagnostics - before dying (which FFI call, backtrace, editor state). + before dying (which FFI call, signal, and fault address). 2. **Automated stress testing** — a burn-in harness that exercises the editor heavily and continuously until it crashes, without human interaction. @@ -18,7 +18,7 @@ information — it just dies. We need two things: │ (controller) │ eval commands │ under gdb │ │ │ ◄──────────────── │ │ │ Logs every command │ results/errors │ SIGSEGV handler: │ -│ to stress.log │ │ - backtrace │ +│ to stress.log │ │ - FFI ring buffer │ └─────────────────────┘ │ - FFI call ring buffer │ │ - crash log file │ └──────────────────────────┘ @@ -60,9 +60,9 @@ Installed at startup via `sigaction(SIGSEGV, ...)`. On crash: 1. Writes crash report to `~/.jemacs-crash.log` (using only async-signal-safe functions: `write()`, `open()`, no `fprintf`/`malloc`) -2. Captures native backtrace via `backtrace()` (glibc) — not strictly - async-signal-safe but works in practice and we're dying anyway -3. Dumps the FFI call ring buffer showing what was happening +2. Dumps the FFI call ring buffer showing what was happening +3. Notes that native backtraces are collected by the `stress-burn-static` gdb + wrapper rather than inside the signal handler 4. Re-raises SIGSEGV with default handler so gdb/core dump still works #### 3. Integration with QT_VOID / QT_RETURN macros @@ -86,10 +86,7 @@ FFI Call Ring (most recent last): [ 4] ENTER qt_splitter_add_widget +0.001ms ← LAST ENTRY (still inside) Native backtrace: - #0 0x7f3a2b1c4e00 in QSplitter::insertWidget() - #1 0x5555556789ab in qt_splitter_add_widget() - #2 0x555555612345 in ... - ... + (not captured in signal handler; run stress-burn-static for gdb bt full) Written to: /home/user/.jemacs-crash.log ``` @@ -125,28 +122,27 @@ REPL over TCP and drives random editor operations in a continuous loop. - Random sequences of 5-15 operations **Phase 2: Vterm Storm** -- Open 3-5 vterm buffers -- Send shell commands: `find /usr -ls`, `top -b -n 5`, `ls -laR /tmp`, - `yes | head -10000` +- Open 1-3 vterm buffers +- Send bounded shell commands such as `pwd`, `ls -la /tmp`, and short `printf` + bursts - Let them run concurrently while doing other operations - Kill vterm buffers randomly **Phase 3: File Churn** - Create temp files with random content - Open them with `find-file` (via eval, bypassing echo-area prompts) -- Insert large text blocks, navigate around +- Insert files up to several KB, navigate around - Copy/paste between buffers (kill-region + yank in another) -- Save, revert, kill buffers +- Kill buffers randomly **Phase 4: Navigation Stress** - Rapid cursor movement: forward-char, next-line, scroll-up/down -- goto-line to random positions - beginning-of-buffer / end-of-buffer -- mark-whole-buffer, kill-region, undo +- word movement and recenter -**Phase 5: EWW (Web Browser)** -- Open `eww` with simple URLs (localhost, file:// paths) -- Navigate, switch between eww and editor buffers +**Phase 5: Scratch Buffer** +- Open a scratch-like buffer directly +- Navigate and switch windows without minibuffer prompts **Phase 6: Combined Chaos** - All phases interleaved randomly @@ -254,8 +250,8 @@ stress-burn: When the segfault hits, gdb catches it and you get: 1. **gdb backtrace** — full native stack trace with debug symbols -2. **~/.jemacs-crash.log** — FFI call ring buffer showing which Scheme→C - boundary was active +2. **~/.jemacs-crash.log** — signal details and FFI call ring buffer showing + which Scheme→C boundary was active 3. **stress-test.log** — the exact sequence of editor commands that triggered it ### Iterative debugging workflow --- a/lib/jerboa-emacs/debug-repl.sls +++ b/lib/jerboa-emacs/debug-repl.sls @@ -25,6 +25,7 @@ (def *repl-authed* #f) (def *repl-prompted* #f) (def *repl-protocol* 'unknown) + (def *repl-unknown-ticks* 0) (def *repl-port-file* (string-append (getenv "HOME") "/.jerboa-repl-port")) (def *repl-env* (interaction-environment)) @@ -59,7 +60,19 @@ (lambda () (repl-socket-close *repl-client-fd*)))) (set! *repl-client-fd* #f) (set! *repl-line-buf* "") (set! *repl-authed* #f) (set! *repl-prompted* #f) - (set! *repl-protocol* 'unknown)) + (set! *repl-protocol* 'unknown) + (set! *repl-unknown-ticks* 0)) + (def (debug-read port) + "Read one datum. Call reject-reader-eval! on strings before opening ports." + (read port)) + (def (reject-reader-eval! str) + "Reject Chez reader-eval markers before parsing debug input." + (when (string-contains str "#.") + (error 'debug-repl + "reader-eval marker #. is not accepted"))) + (def (debug-read-string str) + (reject-reader-eval! str) + (debug-read (open-input-string str))) (def (capture-eval expr-str) "Evaluate expression string, capturing stdout. Returns (list status result stdout).\n Handles expressions that return multiple values by formatting all of them.\n Returns a LIST (not values) to avoid multi-value issues with with-catch's call/cc." (with-catch @@ -80,7 +93,7 @@ (call-with-values (lambda () (eval - (read (open-input-string expr-str)) + (debug-read-string expr-str) *repl-env*)) list))] [stdout-str (get-output-string stdout-capture)]) @@ -112,12 +125,13 @@ (display-condition e (current-output-port)))))) "")) (lambda () + (reject-reader-eval! str) (let* ([stdout-capture (open-output-string)] [p (open-input-string str)] [results (parameterize ([current-output-port stdout-capture]) (let loop ([last (list (void))]) - (let ([form (read p)]) + (let ([form (debug-read p)]) (if (eof-object? form) last (loop @@ -212,30 +226,30 @@ limited)]) (list id ':ok strs))] [(expand) - (let* ([expr (read (open-input-string (car args)))] + (let* ([expr (debug-read-string (car args))] [expanded (expand expr *repl-env*)] [result (with-output-to-string (lambda () (pretty-print expanded)))]) (list id ':ok result))] [(expand1) - (let* ([expr (read (open-input-string (car args)))] + (let* ([expr (debug-read-string (car args))] [expanded (sc-expand expr)] [result (with-output-to-string (lambda () (pretty-print expanded)))]) (list id ':ok result))] [(type) - (let* ([expr (read (open-input-string (car args)))] + (let* ([expr (debug-read-string (car args))] [val (eval expr *repl-env*)]) (list id ':ok (value->type-string val)))] [(describe) - (let* ([expr (read (open-input-string (car args)))] + (let* ([expr (debug-read-string (car args))] [val (eval expr *repl-env*)] [desc (with-output-to-string (lambda () (describe-value val)))]) (list id ':ok desc))] [(import) (let ([mod-expr (if (string? (car args)) - (read (open-input-string (car args))) + (debug-read-string (car args)) (car args))]) (eval (list 'import mod-expr) *repl-env*) (list id ':ok "imported"))] @@ -348,7 +362,7 @@ "unknown method: " (symbol->string method)))]))))) (def help-text - " Inspection & Exploration:\n ,type <expr> Show type of expression result\n ,describe <expr> Deep inspection of value\n ,apropos <str> Search for symbols matching string\n ,doc <sym> Show documentation\n ,complete <pfx> Show completions for a symbol prefix\n ,who <sym> Show binding info for a symbol\n\n Evaluation & Debugging:\n ,expand <expr> Show macro expansion\n ,expand1 <expr> One-step macro expansion\n ,pp <expr> Pretty-print value\n\n Performance:\n ,time <expr> Measure evaluation time\n ,alloc <expr> Show memory allocation\n\n Module System:\n ,import (mod ...) Import a module\n ,load <path> Load a file\n ,cd [path] Change/show current directory\n ,pwd Show current directory\n ,ls [path] List directory contents\n\n Data Inspection:\n ,json <expr> Display value as JSON\n ,count <expr> Count items in collection\n ,env [pattern] List environment symbols\n\n Session:\n ,state Show state summary\n ,gc Force GC and show stats\n ,modules List loaded libraries\n ,memory Show memory stats\n ,help This help message\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") + " Inspection & Exploration:\n ,type <expr> Show type of expression result\n ,describe <expr> Deep inspection of value\n ,apropos <str> Search for symbols matching string\n ,doc <sym> Show documentation\n ,complete <pfx> Show completions for a symbol prefix\n ,who <sym> Show binding info for a symbol\n\n Evaluation & Debugging:\n ,expand <expr> Show macro expansion\n ,expand1 <expr> One-step macro expansion\n ,pp <expr> Pretty-print value\n\n Performance:\n ,time <expr> Measure evaluation time\n ,alloc <expr> Show memory allocation\n\n Module System:\n ,import (mod ...) Import a module\n ,load <path> Load a file\n ,cd [path] Change/show current directory\n ,pwd Show current directory\n ,ls [path] List directory contents\n\n Data Inspection:\n ,json <expr> Display value as JSON\n ,count <expr> Count items in collection\n ,env [pattern] List environment symbols\n\n Session:\n ,state Show state summary\n ,gc Force GC and show stats\n ,threads Show timer/thread status\n ,modules List loaded libraries\n ,memory Show memory stats\n ,help This help message\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") (def (text-split-first-word str) "Split string into (first-word . rest)." (let* ([n (string-length str)] @@ -376,7 +390,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [val (eval expr *repl-env*)]) (repl-send! (string-append (value->type-string val) "\n")))))) @@ -389,7 +403,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [val (eval expr *repl-env*)] [desc (with-output-to-string (lambda () (describe-value val)))]) @@ -492,7 +506,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [expanded (expand expr *repl-env*)] [result (with-output-to-string (lambda () (pretty-print expanded)))]) @@ -506,7 +520,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [expanded (sc-expand expr)] [result (with-output-to-string (lambda () (pretty-print expanded)))]) @@ -520,7 +534,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [val (eval expr *repl-env*)]) (repl-send! (safe-pp-value val)))))) #t] @@ -532,7 +546,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [t0 (current-time-ms)] [result (eval expr *repl-env*)] [t1 (current-time-ms)] @@ -550,7 +564,7 @@ (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () (collect (collect-maximum-generation)) - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [before (bytes-allocated)] [result (eval expr *repl-env*)] [after (bytes-allocated)] @@ -568,7 +582,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let ([mod-expr (read (open-input-string rest))]) + (let ([mod-expr (debug-read-string rest)]) (eval (list 'import mod-expr) *repl-env*) (repl-send! (string-append @@ -636,7 +650,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [val (eval expr *repl-env*)]) (repl-send! (string-append (value->json val) "\n")))))) #t] @@ -648,7 +662,7 @@ (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ([expr (read (open-input-string rest))] + (let* ([expr (debug-read-string rest)] [val (eval expr *repl-env*)]) (repl-send! (cond @@ -729,14 +743,20 @@ (collect (collect-maximum-generation)) (let ([after (bytes-allocated)]) (repl-send! - (string-append " bytes-before: " (number->string before) - "\n bytes-after: " (number->string after) - "\n freed: " (number->string (- before after)) + (string-append " GC done\n" " bytes-before: " + (number->string before) "\n bytes-after: " + (number->string after) "\n bytes-allocated: " + (number->string after) "\n freed: " + (number->string (- before after)) "\n collections: " (number->string (collections)) "\n max-generation: " (number->string (collect-maximum-generation)) "\n")))))) #t] + [(string=? cmd ",threads") + (repl-send! + " master-timer: active\n debug-repl: timer-driven on primordial thread\n note: full Chez thread listing not available\n") + #t] [(string=? cmd ",modules") (let ([libs (library-list)]) (for-each @@ -864,12 +884,18 @@ [else (display c out)])) s) (get-output-string out))) + (def (repl-enter-text-mode!) + "Switch the current connection to text mode and send the banner/prompt." + (set! *repl-protocol* 'text) (set! *repl-unknown-ticks* 0) + (repl-send! + "jerboa REPL v2 — ,help for commands | s-expr protocol: (id method args...)\n") + (repl-send! "jerboa> ") (set! *repl-prompted* #t)) (def (sexpr-balanced? str) "Check if a string contains a complete s-expression (balanced parens)." - (let ([len (string-length str)]) + (let ([n (string-length str)]) (let loop ([i 0] [depth 0] [in-string #f] [escape #f]) (cond - [(>= i len) (and (= depth 0) (not in-string) (> len 0))] + [(>= i n) (and (= depth 0) (not in-string) (> n 0))] [else (let ([c (string-ref str i)]) (cond @@ -883,7 +909,7 @@ [(char=? c #\;) (let skip ([j (+ i 1)]) (cond - [(>= j len) (and (= depth 0))] + [(>= j n) (and (= depth 0))] [(char=? (string-ref str j) #\newline) (loop (+ j 1) depth #f #f)] [else (skip (+ j 1))]))] @@ -906,46 +932,65 @@ (set! *repl-line-buf* "") (set! *repl-prompted* #f) (set! *repl-protocol* 'unknown) + (set! *repl-unknown-ticks* 0) (if *repl-token* (begin (set! *repl-authed* #f) (repl-send! "token: ")) (begin (set! *repl-authed* #t)))))] [*repl-client-fd* - (when (and *repl-authed* - (eq? *repl-protocol* 'unknown) - (string=? *repl-line-buf* "")) - (repl-send! - "jerboa REPL v2 — ,help for commands | s-expr protocol: (id method args...)\n") - (set! *repl-protocol* 'text)) - (when (and *repl-authed* - (not *repl-prompted*) - (eq? *repl-protocol* 'text)) - (repl-send! "jerboa> ") - (set! *repl-prompted* #t)) (let ([data (repl-socket-read *repl-client-fd*)]) (cond [(string? data) + (set! *repl-unknown-ticks* 0) (set! *repl-line-buf* (string-append *repl-line-buf* data)) - (when (eq? *repl-protocol* 'text) + (when (and *repl-authed* + (eq? *repl-protocol* 'unknown)) (let ([trimmed (string-trim-both *repl-line-buf*)]) (when (and (> (string-length trimmed) 0) - (char=? (string-ref trimmed 0) #\()) + (not (char=? + (string-ref trimmed 0) + (integer->char 40)))) + (repl-enter-text-mode!)) + (when (and (> (string-length trimmed) 0) + (char=? + (string-ref trimmed 0) + (integer->char 40)) + (sexpr-balanced? trimmed)) (with-catch - (lambda _ #f) + (lambda _ (repl-enter-text-mode!)) (lambda () + (reject-reader-eval! trimmed) (let* ([p (open-input-string trimmed)] - [expr (read p)]) - (when (and (pair? expr) - (number? (car expr)) - (>= (length expr) 2) - (symbol? (cadr expr))) - (set! *repl-protocol* 'sexpr)))))))) - (if (eq? *repl-protocol* 'sexpr) - (repl-process-sexprs!) - (repl-process-lines!))] - [(eq? data 'eof) (repl-disconnect!)]))]))))) + [expr (debug-read p)]) + (if (and (pair? expr) + (number? (car expr)) + (>= (length expr) 2) + (symbol? (cadr expr))) + (set! *repl-protocol* 'sexpr) + (repl-enter-text-mode!)))))))) + (cond + [(not *repl-authed*) (repl-process-lines!)] + [(eq? *repl-protocol* 'sexpr) + (repl-process-sexprs!)] + [(eq? *repl-protocol* 'text) + (repl-process-lines!)])] + [(eq? data 'eof) (repl-disconnect!)] + [else + (when (and *repl-authed* + (eq? *repl-protocol* 'unknown) + (string=? *repl-line-buf* "")) + (set! *repl-unknown-ticks* + (+ *repl-unknown-ticks* 1)) + (when (>= *repl-unknown-ticks* 10) + (repl-enter-text-mode!)))])) + (when (and *repl-authed* + (eq? *repl-protocol* 'text) + (not *repl-prompted*) + *repl-client-fd*) + (repl-send! "jerboa> ") + (set! *repl-prompted* #t))]))))) (def (repl-process-sexprs!) "Extract and process complete s-expressions from *repl-line-buf*." (let loop () @@ -961,8 +1006,9 @@ "\")\n")) (set! *repl-line-buf* "")) (lambda () + (reject-reader-eval! trimmed) (let* ([p (open-input-string trimmed)] - [req (read p)] + [req (debug-read p)] [pos (let ([remaining (get-string-all p)]) (if (eof-object? remaining) "" remaining))]) (set! *repl-line-buf* pos) --- a/lib/jerboa-emacs/qt/app.sls +++ b/lib/jerboa-emacs/qt/app.sls @@ -302,18 +302,20 @@ (> (string-length (vector-ref cache r)) 0)) (vterm-apply-row-colors! ed vt r (+ line-offset r))))) (loop (+ r 1)))))) - (def (parse-repl-port args) - "Return (port-num . filtered-args) if --repl <port> is present, else #f." - (let loop ([rest args] [acc '()]) + (def (parse-repl-options args) + "Return (port token filtered-args) if REPL flags are present, else #f." + (let loop ([rest args] [acc '()] [port #f] [token #f]) (cond - [(null? rest) #f] + [(null? rest) + (and (or port token) (list port token (reverse acc)))] [(and (string=? (car rest) "--repl") (pair? (cdr rest)) (string->number (cadr rest))) - (cons - (string->number (cadr rest)) - (append (reverse acc) (cddr rest)))] - [else (loop (cdr rest) (cons (car rest) acc))]))) + (loop (cddr rest) acc (string->number (cadr rest)) token)] + [(and (string=? (car rest) "--repl-token") + (pair? (cdr rest))) + (loop (cddr rest) acc port (cadr rest))] + [else (loop (cdr rest) (cons (car rest) acc) port token)]))) (def (qt-make-auto-save-path path) (let* ([dir (path-directory path)] [name (path-strip-directory path)]) @@ -2428,8 +2430,8 @@ (qt-current-window fr) (car bufs))) (loop (cdr bufs)))))))) - (let* ([repl-parsed (parse-repl-port args)] - [clean-args (if repl-parsed (cdr repl-parsed) args)] + (let* ([repl-parsed (parse-repl-options args)] + [clean-args (if repl-parsed (caddr repl-parsed) args)] [files (filter (lambda (a) (not (string-prefix? "-" a))) clean-args)]) @@ -2442,14 +2444,19 @@ (qt-tabbar-update! app) (qt-update-frame-title! app) (start-ipc-server!) - (let* ([repl-port-env (getenv "GEMACS_REPL_PORT" #f)] - [repl-info (or (parse-repl-port args) + (let* ([repl-parsed (parse-repl-options args)] + [repl-port-env (or (getenv "JEMACS_REPL_PORT" #f) + (getenv "GEMACS_REPL_PORT" #f))] + [repl-token-env (getenv "JEMACS_REPL_TOKEN" #f)] + [repl-port (or (and repl-parsed (car repl-parsed)) (and repl-port-env - (cons - (string->number repl-port-env) - args)))]) - (when repl-info - (start-debug-repl! (car repl-info)) + (string->number repl-port-env)))] + [repl-token (or (and repl-parsed (cadr repl-parsed)) + repl-token-env)]) + (when repl-port + (if repl-token + (start-debug-repl! repl-port repl-token) + (start-debug-repl! repl-port)) (for-each (lambda (pair) (debug-repl-bind! (car pair) (cdr pair))) (list (cons '*app* app) --- a/lib/jerboa-emacs/qt/main.sls +++ b/lib/jerboa-emacs/qt/main.sls @@ -32,5 +32,7 @@ (displayln " --verbose Log all Qt calls and commands to ~/.jemacs-verbose.log") (displayln - " --repl <port> Start TCP debug REPL on given port (0=auto)")] + " --repl <port> Start TCP debug REPL on given port (0=auto)") + (displayln + " --repl-token <t> Require token as first REPL input line")] [else (apply qt-main args)]))) --- a/lib/jerboa/repl-socket.sls +++ b/lib/jerboa/repl-socket.sls @@ -243,8 +243,8 @@ 'eof))])))) ;; real error → treat as disconnect (define (repl-socket-write fd str) - ;; Write a string to fd. Uses blocking retry for simplicity - ;; (REPL output is small, so this returns quickly). + ;; Write a string to fd. The fd is non-blocking; if the peer stops + ;; reading, fail instead of spinning in the UI/master-timer path. ;; Returns #t on success, #f on error. (let* ([bv (string->utf8 str)] [len (bytevector-length bv)]) @@ -262,9 +262,11 @@ (cond [(> n 0) (lp (+ written n))] [(and (< n 0) - (let ([e (get-errno)]) - (or (= e EAGAIN) (= e EINTR)))) - (lp written)] ;; retry immediately (small data) + (= (get-errno) EINTR)) + (lp written)] + [(and (< n 0) + (= (get-errno) EAGAIN)) + #f] [else #f])))))) (define (repl-socket-close fd) --- a/main.ss +++ b/main.ss @@ -22,17 +22,21 @@ ("Jerboa" . "master") ("Chez Scheme" . "10.x"))) -(define (parse-repl-port args) - "Return (port-num . filtered-args) if --repl <port> is present, else #f." - (let loop ((rest args) (acc '())) +(define (parse-repl-options args) + "Return (port token filtered-args) if REPL flags are present, else #f." + (let loop ((rest args) (acc '()) (port #f) (token #f)) (cond - ((null? rest) #f) + ((null? rest) + (and (or port token) + (list port token (reverse acc)))) ((and (string=? (car rest) "--repl") (pair? (cdr rest)) (string->number (cadr rest))) - (cons (string->number (cadr rest)) - (append (reverse acc) (cddr rest)))) - (else (loop (cdr rest) (cons (car rest) acc)))))) + (loop (cddr rest) acc (string->number (cadr rest)) token)) + ((and (string=? (car rest) "--repl-token") + (pair? (cdr rest))) + (loop (cddr rest) acc port (cadr rest))) + (else (loop (cdr rest) (cons (car rest) acc) port token))))) (define (main . args) (cond @@ -47,21 +51,26 @@ (display "Options:") (newline) (display " --version Show version information") (newline) (display " --help Show this help message") (newline) - (display " --repl <port> Start TCP debug REPL on given port (0=auto)") (newline)) + (display " --repl <port> Start TCP debug REPL on given port (0=auto)") (newline) + (display " --repl-token <t> Require token as first REPL input line") (newline)) (else - (let* ((repl-port-env (getenv "JEMACS_REPL_PORT")) - (repl-info (or (parse-repl-port args) - (and repl-port-env - (cons (string->number repl-port-env) args)))) - (clean-args (if repl-info (cdr repl-info) args)) + (let* ((parsed (parse-repl-options args)) + (repl-port-env (getenv "JEMACS_REPL_PORT")) + (repl-token-env (getenv "JEMACS_REPL_TOKEN")) + (repl-port (or (and parsed (car parsed)) + (and repl-port-env (string->number repl-port-env)))) + (repl-token (or (and parsed (cadr parsed)) repl-token-env)) + (clean-args (if parsed (caddr parsed) args)) (app (app-init! clean-args))) - (when repl-info - (start-debug-repl! (car repl-info))) + (when repl-port + (if repl-token + (start-debug-repl! repl-port repl-token) + (start-debug-repl! repl-port))) (try (app-run! app) (finally (when *desktop-save-mode* (tui-session-save! app)) - (when repl-info (stop-debug-repl!)) + (when repl-port (stop-debug-repl!)) (stop-ipc-server!) (frame-shutdown! (app-state-frame app)) (tui-shutdown!))))))) --- a/src/jerboa-emacs/debug-repl.ss +++ b/src/jerboa-emacs/debug-repl.ss @@ -47,6 +47,7 @@ (def *repl-authed* #f) ;; #t after successful auth (or if no token) (def *repl-prompted* #f) ;; #t if we've sent the prompt for current line (def *repl-protocol* 'unknown) ;; 'unknown, 'text, or 'sexpr +(def *repl-unknown-ticks* 0) ;; ticks spent waiting for first protocol byte (def *repl-port-file* (string-append (getenv "HOME") "/.jerboa-repl-port")) (def *repl-env* (interaction-environment)) @@ -96,7 +97,21 @@ (set! *repl-line-buf* "") (set! *repl-authed* #f) (set! *repl-prompted* #f) - (set! *repl-protocol* 'unknown)) + (set! *repl-protocol* 'unknown) + (set! *repl-unknown-ticks* 0)) + +(def (debug-read port) + "Read one datum. Call reject-reader-eval! on strings before opening ports." + (read port)) + +(def (reject-reader-eval! str) + "Reject Chez reader-eval markers before parsing debug input." + (when (string-contains str "#.") + (error 'debug-repl "reader-eval marker #. is not accepted"))) + +(def (debug-read-string str) + (reject-reader-eval! str) + (debug-read (open-input-string str))) ;;;============================================================================ ;;; Evaluation helpers (shared by both protocols) @@ -118,7 +133,7 @@ (let* ((stdout-capture (open-output-string)) (results (parameterize ((current-output-port stdout-capture)) (call-with-values - (lambda () (eval (read (open-input-string expr-str)) + (lambda () (eval (debug-read-string expr-str) *repl-env*)) list))) (stdout-str (get-output-string stdout-capture))) @@ -145,12 +160,13 @@ (lambda () (display-condition e (current-output-port)))))) "")) (lambda () + (reject-reader-eval! str) (let* ((stdout-capture (open-output-string)) (p (open-input-string str)) (results (parameterize ((current-output-port stdout-capture)) (let loop ((last (list (void)))) - (let ((form (read p))) + (let ((form (debug-read p))) (if (eof-object? form) last (loop (call-with-values @@ -248,26 +264,26 @@ (list id ':ok strs))) ((expand) - (let* ((expr (read (open-input-string (car args)))) + (let* ((expr (debug-read-string (car args))) (expanded (expand expr *repl-env*)) (result (with-output-to-string (lambda () (pretty-print expanded))))) (list id ':ok result))) ((expand1) - (let* ((expr (read (open-input-string (car args)))) + (let* ((expr (debug-read-string (car args))) (expanded (sc-expand expr)) (result (with-output-to-string (lambda () (pretty-print expanded))))) (list id ':ok result))) ((type) - (let* ((expr (read (open-input-string (car args)))) + (let* ((expr (debug-read-string (car args))) (val (eval expr *repl-env*))) (list id ':ok (value->type-string val)))) ((describe) - (let* ((expr (read (open-input-string (car args)))) + (let* ((expr (debug-read-string (car args))) (val (eval expr *repl-env*)) (desc (with-output-to-string (lambda () (describe-value val))))) @@ -275,7 +291,7 @@ ((import) (let ((mod-expr (if (string? (car args)) - (read (open-input-string (car args))) + (debug-read-string (car args)) (car args)))) (eval (list 'import mod-expr) *repl-env*) (list id ':ok "imported"))) @@ -393,6 +409,7 @@ Session: ,state Show state summary ,gc Force GC and show stats + ,threads Show timer/thread status ,modules List loaded libraries ,memory Show memory stats ,help This help message @@ -431,7 +448,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (val (eval expr *repl-env*))) (repl-send! (string-append (value->type-string val) "\n")))))) #t) @@ -441,7 +458,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (val (eval expr *repl-env*)) (desc (with-output-to-string (lambda () (describe-value val))))) @@ -517,7 +534,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (expanded (expand expr *repl-env*)) (result (with-output-to-string (lambda () (pretty-print expanded))))) @@ -529,7 +546,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (expanded (sc-expand expr)) (result (with-output-to-string (lambda () (pretty-print expanded))))) @@ -541,7 +558,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (val (eval expr *repl-env*))) (repl-send! (safe-pp-value val)))))) #t) @@ -552,7 +569,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (t0 (current-time-ms)) (result (eval expr *repl-env*)) (t1 (current-time-ms)) @@ -567,7 +584,7 @@ (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () (collect (collect-maximum-generation)) - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (before (bytes-allocated)) (result (eval expr *repl-env*)) (after (bytes-allocated)) @@ -582,7 +599,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let ((mod-expr (read (open-input-string rest)))) + (let ((mod-expr (debug-read-string rest))) (eval (list 'import mod-expr) *repl-env*) (repl-send! (string-append ";; imported " (format "~s" mod-expr) "\n")))))) #t) @@ -639,7 +656,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (val (eval expr *repl-env*))) (repl-send! (string-append (value->json val) "\n")))))) #t) @@ -649,7 +666,7 @@ (with-catch (lambda (e) (repl-send! (string-append "ERROR: " (fmt-error e) "\n"))) (lambda () - (let* ((expr (read (open-input-string rest))) + (let* ((expr (debug-read-string rest)) (val (eval expr *repl-env*))) (repl-send! (cond @@ -707,14 +724,21 @@ (let ((after (bytes-allocated))) (repl-send! (string-append + " GC done\n" " bytes-before: " (number->string before) "\n bytes-after: " (number->string after) + "\n bytes-allocated: " (number->string after) "\n freed: " (number->string (- before after)) "\n collections: " (number->string (collections)) "\n max-generation: " (number->string (collect-maximum-generation)) "\n")))))) #t) + ((string=? cmd ",threads") + (repl-send! + " master-timer: active\n debug-repl: timer-driven on primordial thread\n note: full Chez thread listing not available\n") + #t) + ((string=? cmd ",modules") (let ((libs (library-list))) (for-each @@ -842,12 +866,20 @@ ;;; S-expression protocol: balanced paren detection ;;;============================================================================ +(def (repl-enter-text-mode!) + "Switch the current connection to text mode and send the banner/prompt." + (set! *repl-protocol* 'text) + (set! *repl-unknown-ticks* 0) + (repl-send! "jerboa REPL v2 — ,help for commands | s-expr protocol: (id method args...)\n") + (repl-send! "jerboa> ") + (set! *repl-prompted* #t)) + (def (sexpr-balanced? str) "Check if a string contains a complete s-expression (balanced parens)." - (let ((len (string-length str))) + (let ((n (string-length str))) (let loop ((i 0) (depth 0) (in-string #f) (escape #f)) (cond - ((>= i len) (and (= depth 0) (not in-string) (> len 0))) + ((>= i n) (and (= depth 0) (not in-string) (> n 0))) (else (let ((c (string-ref str i))) (cond @@ -865,7 +897,7 @@ ;; Skip to end of line (let skip ((j (+ i 1))) (cond - ((>= j len) (and (= depth 0))) + ((>= j n) (and (= depth 0))) ((char=? (string-ref str j) #\newline) (loop (+ j 1) depth #f #f)) (else (skip (+ j 1)))))) @@ -897,6 +929,7 @@ (set! *repl-line-buf* "") (set! *repl-prompted* #f) (set! *repl-protocol* 'unknown) + (set! *repl-unknown-ticks* 0) (if *repl-token*