Fix GC deadlock: C-level deactivation around blocking subprocess/file I/O
ober
6c73656e5d0d729aa663571b199807b002a4f3ad
--- a/Makefile +++ b/Makefile @@ -4,7 +4,7 @@ JSH = $(HOME)/mine/jerboa-shell/src GHERKIN = $(HOME)/mine/gherkin/src LIBDIRS = --libdirs lib:$(JERBOA)/lib:$(JSH):$(GHERKIN):$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla/src:$(HOME)/mine/chez-qt JERBUILD = $(SCHEME) --libdirs $(JERBOA)/lib --script $(JERBOA)/jerbuild.ss -export LD_LIBRARY_PATH := $(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/chez-qt:$(HOME)/mine/gerbil-qt/vendor:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) +export LD_LIBRARY_PATH := .:$(HOME)/mine/chez-pcre2:$(HOME)/mine/chez-scintilla:$(HOME)/mine/chez-qt:$(HOME)/mine/gerbil-qt/vendor:$(HOME)/mine/jerboa-shell:$(LD_LIBRARY_PATH) export CHEZ_SCINTILLA_LIB := $(HOME)/mine/chez-scintilla export CHEZ_PCRE2_LIB := $(HOME)/mine/chez-pcre2 export CHEZ_QT_LIB := $(HOME)/mine/chez-qt @@ -30,7 +30,10 @@ rebuild: run: build $(SCHEME) $(LIBDIRS) --script main.ss -run-qt: build +repl_shim.so: support/repl_shim.c + gcc -shared -fPIC -O2 -o repl_shim.so support/repl_shim.c -Wall + +run-qt: build repl_shim.so $(SCHEME) $(LIBDIRS) --script qt-main.ss # Qt backend build target --- a/build-binary-qt.ss +++ b/build-binary-qt.ss @@ -337,7 +337,7 @@ ;; define-foreign name "c-name" — jsh macro (C name is the second string) (gen-cmd (format - "{ { cat ~a ~a; find ~a ~a ~a lib/jerboa-emacs -name '*.sls' -o -name '*.ss' | xargs cat 2>/dev/null; } | \ + "{ { cat ~a ~a; find ~a ~a ~a lib/jerboa-emacs lib/jerboa vendor -name '*.sls' -o -name '*.ss' | xargs cat 2>/dev/null; } | \ sed 's/;;.*//' | grep -oE '(foreign-procedure|foreign-entry\\?) \"[^\"]*\"' | sed 's/.* \"//;s/\"//'; \ { cat ~a ~a; } | sed 's/;;.*//' | grep -o 'define-optional-ffi [^ ]* \"[^\"]*\"' | sed 's/.*define-optional-ffi [^ ]* \"//;s/\"//'; \ find ~a -name '*.sls' -o -name '*.ss' | \ @@ -401,6 +401,14 @@ echo OK" (display "Error: pty_shim.c compilation failed\n") (exit 1)))) +;; repl shim (poll/nanosleep/Sdeactivate wrappers for debug REPL in static builds) +(when jemacs-static? + (let* ((cmd (format "gcc -c -O2 -o jemacs-qt-repl-shim.o support/repl_shim.c -I~a -Wall 2>&1" + chez-dir))) + (unless (= 0 (system cmd)) + (display "Error: repl_shim.c compilation failed\n") + (exit 1)))) + ;; jerboa landlock shim (jerboa_landlock_* symbols from jerboa/support/landlock-shim.c) (when jemacs-static? (let* ((jerboa-root (path-parent jerboa-dir)) @@ -435,7 +443,7 @@ echo OK" (libqt-shim (format "~a/libqt_shim.a" qt-shim-dir)) (cmd (format "g++ -static -Wl,--export-dynamic -o jemacs-qt \ jemacs-qt-main.o jemacs-qt-chez-shim.o jemacs-qt-pcre2-shim.o jemacs-qt-jsh-ffi.o \ -jemacs-qt-pty-shim.o jemacs-qt-jerboa-landlock.o jemacs-qt-sci-stubs.o \ +jemacs-qt-pty-shim.o jemacs-qt-repl-shim.o jemacs-qt-jerboa-landlock.o jemacs-qt-sci-stubs.o \ qt_static_symbols.o \ ~a ~a ~a ~a \ -L~a -lkernel -llz4 -lz \ --- a/lib/jerboa-emacs/async.sls +++ b/lib/jerboa-emacs/async.sls @@ -18,13 +18,49 @@ (std misc channel) (only (std srfi srfi-19) current-time time->seconds) (std misc atom) (std sugar) (std srfi srfi-13) - (jerboa-emacs core) (except (jerboa core) time->seconds) - (jerboa runtime)) + (jerboa-emacs core) + (only + (jerboa repl-socket) + repl-capture-command + repl-read-file + repl-write-file) + (except (jerboa core) time->seconds) (jerboa runtime)) + (def (string-split-newlines str) + "Split a string on newline characters. Drops trailing empty string." + (let ([len (string-length str)]) + (if (= len 0) + '() + (let loop ([start 0] [i 0] [acc '()]) + (cond + [(>= i len) + (let ([last (substring str start len)]) + (reverse (if (string=? last "") acc (cons last acc))))] + [(char=? (string-ref str i) #\newline) + (loop + (+ i 1) + (+ i 1) + (cons (substring str start i) acc))] + [else (loop start (+ i 1) acc)]))))) + (def (shell-escape-single-quotes str) + "Escape single quotes for use inside a single-quoted shell string.\n Replaces ' with '\\'' (end quote, escaped quote, start quote)." + (let loop ([i 0] [acc '()]) + (if (>= i (string-length str)) + (apply string-append (reverse acc)) + (if (char=? (string-ref str i) #\') + (loop (+ i 1) (cons "'\\''" acc)) + (let ([start i]) + (let scan ([j (+ i 1)]) + (cond + [(>= j (string-length str)) + (loop j (cons (substring str start j) acc))] + [(char=? (string-ref str j) #\') + (loop j (cons (substring str start j) acc))] + [else (scan (+ j 1))]))))))) (def (pin-thread-to-processor0! thread) "No-op on Chez — Qt thread affinity is handled by architecture:\n all Qt calls run on the primordial thread, blocking work in workers." #f) (def (spawn-worker name thunk) - "Spawn a background worker thread for blocking operations.\n Uses fork-thread which properly decrements S_nthreads on completion.\n The thunk runs in a background thread — do NOT call Qt FFI from it.\n Post Qt operations back to the UI thread via ui-queue-push!." + "Spawn a background worker thread for blocking operations.\n Worker thunks should use repl-capture-command (not open-process-ports)\n for subprocess I/O, and repl-read-file/repl-write-file for file I/O.\n These C-level helpers deactivate the Chez thread during blocking system\n calls so GC can proceed, then reactivate before returning Scheme strings." (let ([t (make-thread (lambda () (with-catch @@ -87,7 +123,7 @@ *scheduled-tasks*)))) (def (async-process! cmd callback: callback on-error: (on-error #f) stdin-text: (stdin-text #f)) - "Run shell command in a background thread, deliver result via UI queue.\n The callback runs on the primordial/UI thread (safe for Qt operations).\n Never blocks the event loop." + "Run shell command in a background thread, deliver result via UI queue.\n Uses repl-capture-command for GC-safe subprocess I/O — the thread is\n deactivated during the blocking popen/fread at the C level.\n The callback runs on the primordial/UI thread (safe for Qt operations)." (spawn-worker 'async-process (lambda () @@ -101,23 +137,19 @@ "async-process error: " (format "~a" e)))))) (lambda () - (let-values ([(in-port out-port err-port pid) - (open-process-ports - cmd - (buffer-mode block) - (native-transcoder))]) - (when stdin-text - (put-string out-port stdin-text) - (flush-output-port out-port)) - (close-port out-port) - (close-port err-port) - (let ([out (get-string-all in-port)]) - (close-port in-port) - (let ([result (if (eof-object? out) "" out)]) - (ui-queue-push! (lambda () (callback result))))))))))) + (let ([full-cmd (if stdin-text + (string-append + "printf '%s' '" + (shell-escape-single-quotes + stdin-text) + "' | " + cmd) + cmd)]) + (let ([result (repl-capture-command full-cmd)]) + (ui-queue-push! (lambda () (callback result)))))))))) (def (async-process-stream! cmd on-line: on-line on-done: (on-done #f) on-error: (on-error #f)) - "Run shell command in background thread, deliver each line via UI queue.\n Callbacks run on the primordial/UI thread (safe for Qt operations)." + "Run shell command in background thread, deliver each line via UI queue.\n Uses repl-capture-command for GC-safe I/O, then splits output into lines.\n Callbacks run on the primordial/UI thread (safe for Qt operations)." (spawn-worker 'async-process-stream (lambda () @@ -131,46 +163,30 @@ "async-process-stream error: " (format "~a" e)))))) (lambda () - (let-values ([(in-port out-port err-port pid) - (open-process-ports - cmd - (buffer-mode line) - (native-transcoder))]) - (close-port out-port) - (close-port err-port) - (let loop () - (let ([line (get-line in-port)]) - (if (eof-object? line) - (begin - (close-port in-port) - (when on-done (ui-queue-push! on-done))) - (begin - (ui-queue-push! (lambda () (on-line line))) - (loop))))))))))) + (let ([output (repl-capture-command cmd)]) + (let ([lines (string-split-newlines output)]) + (for-each + (lambda (line) + (ui-queue-push! (lambda () (on-line line)))) + lines) + (when on-done (ui-queue-push! on-done))))))))) (def (async-read-file! path callback) - "Read file in a background thread, deliver content via UI queue.\n Callback receives the file content string, or #f on error." + "Read file in a background thread, deliver content via UI queue.\n Uses repl-read-file for GC-safe file I/O.\n Callback receives the file content string, or #f on error." (spawn-worker 'async-read-file (lambda () (let ([content (with-catch (lambda (e) #f) - (lambda () - (call-with-input-file - path - (lambda (port) (get-string-all port)))))]) + (lambda () (repl-read-file path)))]) (ui-queue-push! (lambda () (callback content))))))) (def (async-write-file! path content callback) - "Write file in a background thread, deliver result via UI queue.\n Callback receives #t on success, #f on error." + "Write file in a background thread, deliver result via UI queue.\n Uses repl-write-file for GC-safe file I/O.\n Callback receives #t on success, #f on error." (spawn-worker 'async-write-file (lambda () (let ([ok (with-catch (lambda (e) #f) - (lambda () - (call-with-output-file - path - (lambda (port) (display content port))) - #t))]) + (lambda () (repl-write-file path content)))]) (ui-queue-push! (lambda () (callback ok))))))) (def (async-eval! thunk callback) "Evaluate thunk in background thread, deliver result via UI queue.\n Callback runs on the primordial/UI thread." @@ -246,50 +262,38 @@ (cons (string-trim-both status) file)))) (def *git-watcher-running* #f) (def (git-status-collect dir) - "Run git status subprocess and return a hash with branch/modified/staged/untracked.\n Runs in the calling thread (designed for background worker)." - (let-values ([(in-port out-port err-port pid) - (open-process-ports - (string-append - "git -C \"" - dir - "\" status --porcelain -b 2>&1") - (buffer-mode line) - (native-transcoder))]) - (close-port out-port) - (close-port err-port) - (let ([lines (let rd ([acc '()]) - (let ([line (get-line in-port)]) - (if (eof-object? line) - (reverse acc) - (rd (cons line acc)))))]) - (close-port in-port) - (let ([status (make-hash-table)] - [modified 0] - [staged 0] - [untracked 0]) - (for-each - (lambda (line) - (when (>= (string-length line) 3) - (let ([xy (substring line 0 2)]) - (cond - [(string-prefix? "##" xy) - (hash-put! - status - 'branch - (substring line 3 (string-length line)))] - [(string-contains xy "?") - (set! untracked (+ untracked 1))] - [(or (string-contains xy "M") - (string-contains xy "D")) - (set! modified (+ modified 1))] - [(or (string-contains xy "A") - (string-contains xy "R")) - (set! staged (+ staged 1))])))) - lines) - (hash-put! status 'modified modified) - (hash-put! status 'staged staged) - (hash-put! status 'untracked untracked) - status)))) + "Run git status subprocess and return a hash with branch/modified/staged/untracked.\n Uses repl-capture-command for GC-safe subprocess I/O." + (let* ([output (repl-capture-command + (string-append + "git -C \"" + dir + "\" status --porcelain -b 2>&1"))] + [lines (string-split-newlines output)] + [status (make-hash-table)] + [modified 0] + [staged 0] + [untracked 0]) + (for-each + (lambda (line) + (when (>= (string-length line) 3) + (let ([xy (substring line 0 2)]) + (cond + [(string-prefix? "##" xy) + (hash-put! + status + 'branch + (substring line 3 (string-length line)))] + [(string-contains xy "?") + (set! untracked (+ untracked 1))] + [(or (string-contains xy "M") (string-contains xy "D")) + (set! modified (+ modified 1))] + [(or (string-contains xy "A") (string-contains xy "R")) + (set! staged (+ staged 1))])))) + lines) + (hash-put! status 'modified modified) + (hash-put! status 'staged staged) + (hash-put! status 'untracked untracked) + status)) (def (git-watcher-tick!) "One git status poll. Spawns a background thread for the subprocess,\n posts results to UI thread. Skips if previous poll still running." (when (and *git-watcher-dir* (not *git-watcher-running*)) --- a/lib/jerboa-emacs/debug-repl.sls +++ b/lib/jerboa-emacs/debug-repl.sls @@ -9,11 +9,14 @@ getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) (std sugar) (std srfi srfi-13) (jerboa repl-socket) - (jerboa core) (jerboa runtime)) + (jerboa-emacs async) (jerboa core) (jerboa runtime)) (def *repl-listen-fd* #f) + (def *repl-client-fd* #f) + (def *repl-line-buf* "") (def *repl-actual-port* #f) - (def *repl-running* #f) - (def *repl-thread* #f) + (def *repl-token* #f) + (def *repl-authed* #f) + (def *repl-prompted* #f) (def *repl-port-file* (string-append (getenv "HOME") "/.jerboa-repl-port")) (def (write-repl-port-file! port-num) @@ -29,45 +32,45 @@ (with-catch (lambda _ (void)) (lambda () (delete-file *repl-port-file*))))) + (def (repl-send! str) + "Send a string to the connected client. No-op if no client." + (when *repl-client-fd* + (unless (repl-socket-write *repl-client-fd* str) + (repl-disconnect!)))) + (def (repl-disconnect!) + "Close the client connection and reset state for next accept." + (when *repl-client-fd* + (with-catch + (lambda _ (void)) + (lambda () (repl-socket-close *repl-client-fd*)))) + (set! *repl-client-fd* #f) (set! *repl-line-buf* "") + (set! *repl-authed* #f) (set! *repl-prompted* #f)) (def help-text - " ,help This help message\n ,threads List active threads\n ,state Show state summary\n ,gc Force GC and show heap info\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") - (def (process-repl-line line client-fd) - "Process one REPL command line. Returns #t to continue, #f to disconnect." + " ,help This help message\n ,state Show state summary\n ,gc Show GC stats\n ,quit Close this REPL connection\n <expr> Evaluate arbitrary Chez Scheme expression\n") + (def (process-repl-line! line) + "Process one REPL command line. Returns #t to continue, #f to disconnect." (let ([cmd (string-trim-both line)]) (cond [(string=? cmd "") #t] [(string=? cmd ",quit") - (repl-fd-send! client-fd "Connection closed.\n") + (repl-send! "Connection closed.\n") #f] - [(string=? cmd ",help") - (repl-fd-send! client-fd help-text) - #t] - [(string=? cmd ",threads") - (with-catch - (lambda (e) - (repl-fd-send! client-fd " (error listing threads)\n")) - (lambda () - (repl-fd-send! client-fd " REPL thread (active)\n"))) - #t] + [(string=? cmd ",help") (repl-send! help-text) #t] [(string=? cmd ",state") - (repl-fd-send! - client-fd + (repl-send! (string-append " listen-fd: " (number->string (or *repl-listen-fd* -1)) - "\n client-fd: " (number->string client-fd) + "\n client-fd: " (number->string (or *repl-client-fd* -1)) "\n bytes-allocated: " (number->string (bytes-allocated)) "\n")) #t] [(string=? cmd ",gc") (with-catch - (lambda (e) - (repl-fd-send! client-fd " (error reading GC stats)\n")) + (lambda (e) (repl-send! " (error reading GC stats)\n")) (lambda () - (repl-fd-send! - client-fd + (repl-send! (string-append " bytes-allocated: " (number->string (bytes-allocated)) "\n collections: " - (number->string (collections)) - "\n Note: (collect) not safe from REPL thread; GC runs automatically.\n")))) + (number->string (collections)) "\n")))) #t] [else (with-catch @@ -80,22 +83,86 @@ (display-condition e (current-output-port))))))]) - (repl-fd-send! - client-fd - (string-append "ERROR: " msg "\n")))) + (repl-send! (string-append "ERROR: " msg "\n")))) (lambda () (let* ([result (eval (read (open-input-string cmd)) (interaction-environment))] [out (open-output-string)]) (write result out) - (repl-fd-send! - client-fd + (repl-send! (string-append (get-output-string out) "\n"))))) #t]))) - (def (repl-fd-send! fd str) - "Send string to fd. Returns #t on success, #f on error." - (repl-socket-write fd str)) + (def (debug-repl-tick!) + "Non-blocking REPL poll. Called from the master timer on the primordial thread." + (when *repl-listen-fd* + (with-catch + (lambda (e) (void)) + (lambda () + (cond + [(not *repl-client-fd*) + (let ([cfd (repl-socket-accept *repl-listen-fd*)]) + (when cfd + (set! *repl-client-fd* cfd) + (set! *repl-line-buf* "") + (set! *repl-prompted* #f) + (if *repl-token* + (begin + (set! *repl-authed* #f) + (repl-send! "token: ")) + (begin + (set! *repl-authed* #t) + (repl-send! + "jerboa debug REPL — type ,help for commands\n")))))] + [*repl-client-fd* + (when (and *repl-authed* (not *repl-prompted*)) + (repl-send! "jerboa-dbg> ") + (set! *repl-prompted* #t)) + (let ([data (repl-socket-read *repl-client-fd*)]) + (cond + [(string? data) + (set! *repl-line-buf* + (string-append *repl-line-buf* data)) + (repl-process-lines!)] + [(eq? data 'eof) (repl-disconnect!)]))]))))) + (def (repl-process-lines!) + "Extract and process complete lines from *repl-line-buf*." + (let loop () + (let ([nl (repl-string-index *repl-line-buf* #\newline)]) + (when nl + (let ([line (substring *repl-line-buf* 0 nl)] + [rest (substring + *repl-line-buf* + (+ nl 1) + (string-length *repl-line-buf*))]) + (set! *repl-line-buf* rest) + (let ([line (if (and (> (string-length line) 0) + (char=? + (string-ref + line + (- (string-length line) 1)) + #\return)) + (substring + line + 0 + (- (string-length line) 1)) + line)]) + (if *repl-authed* + (let ([continue? (process-repl-line! line)]) + (if continue? + (begin (set! *repl-prompted* #f) (loop)) + (repl-disconnect!))) + (let ([tok (string-trim-both line)]) + (if (string=? tok *repl-token*) + (begin + (set! *repl-authed* #t) + (repl-send! + "jerboa debug REPL — type ,help for commands\n") + (set! *repl-prompted* #f) + (loop)) + (begin + (repl-send! "Access denied.\n") + (repl-disconnect!))))))))))) (def (repl-string-index str ch) "Return the index of the first occurrence of ch in str, or #f." (let ([len (string-length str)]) @@ -104,110 +171,31 @@ [(>= i len) #f] [(char=? (string-ref str i) ch) i] [else (loop (+ i 1))])))) - (def (handle-client! client-fd token) - "Handle one client connection. Blocks until client disconnects or ,quit.\n Uses non-blocking reads + thread-sleep! for GC safety." - (with-catch - (lambda (e) (void)) - (lambda () - (let ([authed (if token - (begin - (repl-fd-send! client-fd "token: ") - (let-values ([(tok-line rest) - (repl-read-line - client-fd - "")]) - (and tok-line - (string=? - (string-trim-both tok-line) - token)))) - #t)]) - (when authed - (repl-fd-send! - client-fd - "jerboa debug REPL — type ,help for commands\n") - (let loop ([buf ""]) - (when *repl-running* - (repl-fd-send! client-fd "jerboa-dbg> ") - (let-values ([(line rest) - (repl-read-line client-fd buf)]) - (when (and line *repl-running*) - (when (process-repl-line line client-fd) - (loop rest)))))))))) - (with-catch - (lambda _ (void)) - (lambda () (repl-socket-close client-fd)))) - (def (repl-read-line client-fd buf) - "Read one line from client-fd using non-blocking reads + thread-sleep!.\n Returns (values line remaining-buffer) or (values #f \"\") on EOF/disconnect.\n Carries over leftover data in buf from previous reads." - (let loop ([buf buf]) - (if (not *repl-running*) - (values #f "") - (let ([nl (repl-string-index buf #\newline)]) - (if nl - (let ([line (substring buf 0 nl)] - [rest (substring - buf - (+ nl 1) - (string-length buf))]) - (values - (if (and (> (string-length line) 0) - (char=? - (string-ref - line - (- (string-length line) 1)) - #\return)) - (substring line 0 (- (string-length line) 1)) - line) - rest)) - (let ([data (repl-socket-read client-fd)]) - (cond - [(string? data) (loop (string-append buf data))] - [(eq? data 'eof) (values #f "")] - [else (thread-sleep! 0.05) (loop buf)]))))))) - (def (repl-accept-loop! token) - "Main accept loop. Runs in the dedicated REPL thread.\n Accepts one client at a time (single-connection REPL)." - (let loop () - (when *repl-running* - (let ([cfd (with-catch - (lambda _ #f) - (lambda () - (repl-socket-accept *repl-listen-fd*)))]) - (if cfd - (begin (handle-client! cfd token) (loop)) - (begin (thread-sleep! 0.1) (loop))))))) (def (start-debug-repl! port-num . args) - "Start the TCP debug REPL on 127.0.0.1:port-num.\n Optional second argument: token string for authentication.\n Use port 0 for OS-assigned ephemeral port.\n Returns the actual port number and writes ~/.jerboa-repl-port.\n\n Runs in a dedicated background thread — independent of Qt event loop." + "Start the TCP debug REPL on 127.0.0.1:port-num.\n Optional second argument: token string for authentication.\n Runs on primordial thread via schedule-periodic! — no GC deadlock." (stop-debug-repl!) (let ([token (if (null? args) #f (car args))]) (let-values ([(fd actual-port) (repl-socket-listen "127.0.0.1" port-num)]) (set! *repl-listen-fd* fd) (set! *repl-actual-port* actual-port) - (set! *repl-running* #t) + (set! *repl-token* token) + (set! *repl-authed* (not token)) + (set! *repl-client-fd* #f) + (set! *repl-line-buf* "") + (set! *repl-prompted* #f) (write-repl-port-file! actual-port) - (set! *repl-thread* - (let ([t (make-thread - (lambda () - (with-catch - (lambda (e) (void)) - (lambda () (repl-accept-loop! token)))) - 'debug-repl)]) - (thread-start! t) - t)) + (schedule-periodic! 'debug-repl 50 debug-repl-tick!) actual-port))) (def (stop-debug-repl!) "Stop the debug REPL server and clean up." - (set! *repl-running* #f) + (repl-disconnect!) (when *repl-listen-fd* (with-catch (lambda _ (void)) (lambda () (repl-socket-close *repl-listen-fd*))) (set! *repl-listen-fd* #f) (set! *repl-actual-port* #f)) - (when *repl-thread* - (with-catch - (lambda _ (void)) - (lambda () (thread-sleep! 0.2))) - (set! *repl-thread* #f)) (delete-repl-port-file!)) (def (debug-repl-port) "Return the actual port number the debug REPL is listening on, or #f if stopped." --- a/lib/jerboa/repl-socket.sls +++ b/lib/jerboa/repl-socket.sls @@ -12,17 +12,42 @@ repl-socket-accept ;; (listen-fd) → client-fd or #f repl-socket-read ;; (fd) → string or #f (EAGAIN) or 'eof repl-socket-write ;; (fd string) → #t or #f - repl-socket-close) ;; (fd) → void + repl-socket-close ;; (fd) → void + repl-socket-poll ;; (fd timeout-ms) → 'ready, #f (timeout), or 'error + repl-socket-nanosleep ;; (milliseconds) → void + repl-deactivate-thread! ;; () → void — deactivate for GC + repl-activate-thread! ;; () → void — reactivate after foreign call + ;; GC-safe subprocess/file I/O — deactivates thread during blocking calls + repl-capture-command ;; (cmd-string) → output-string + repl-read-file ;; (path) → content-string (empty on error) + repl-write-file) ;; (path content) → #t or #f (import (chezscheme)) ;; ========== FFI ========== + ;; load-shared-object #f → dlopen(NULL) → gives access to all symbols + ;; in the main binary, whether dynamically or statically linked. + ;; Must always be called (even for static builds) so poll/nanosleep/etc. + ;; are found by foreign-procedure. (define _libc-loaded (let ((v (getenv "JEMACS_STATIC"))) (if (and v (not (string=? v "")) (not (string=? v "0"))) - #f ; symbols already in static binary - (load-shared-object #f)))) + #f ; static build: symbols from repl_shim.c + libc via --export-dynamic + (begin + (load-shared-object #f) + ;; Load repl_shim.so for GC-safe subprocess/file I/O helpers. + ;; Try several paths: next to the binary, in support/, or via LD_LIBRARY_PATH. + (let try ((paths (list "repl_shim.so" + "./repl_shim.so" + "support/repl_shim.so" + "../support/repl_shim.so"))) + (if (null? paths) + ;; If no .so found, the capture functions won't be available + ;; but socket functions (from libc) still work + (void) + (guard (e (#t (try (cdr paths)))) + (load-shared-object (car paths))))))))) (define c-socket (foreign-procedure "socket" (int int int) int)) (define c-bind (foreign-procedure "bind" (int void* int) int)) @@ -36,6 +61,18 @@ (define c-inet-pton (foreign-procedure "inet_pton" (int string void*) int)) (define c-getsockname (foreign-procedure "getsockname" (int void* void*) int)) (define c-fcntl (foreign-procedure "fcntl" (int int int) int)) + ;; poll/nanosleep/thread activation use wrapper names from repl_shim.c + ;; because musl static binaries don't export libc symbols to dlsym. + (define c-poll (foreign-procedure "repl_poll" (void* unsigned-int int) int)) + (define c-nanosleep (foreign-procedure "repl_nanosleep" (void* void*) int)) + + ;; Chez SMP thread activation — allows GC to proceed while this thread + ;; is blocked in foreign calls. Must bracket foreign blocking calls: + ;; (repl-deactivate-thread!) ; tell GC we're not using Scheme heap + ;; ... foreign blocking call (poll, nanosleep) ... + ;; (repl-activate-thread!) ; re-enter Scheme safely + (define c-deactivate (foreign-procedure "repl_deactivate_thread" () void)) + (define c-activate (foreign-procedure "repl_activate_thread" () int)) ;; errno (define c-errno-location (foreign-procedure "__errno_location" () void*)) @@ -52,6 +89,8 @@ (define F_GETFL 3) (define F_SETFL 4) (define O_NONBLOCK #x800) + (define POLLIN #x001) + (define POLLFD_SIZE 8) ;; struct pollfd: int fd, short events, short revents ;; ========== Helpers ========== @@ -177,4 +216,69 @@ (bytevector-copy! bv start result 0 len) result)) + (define (repl-socket-poll fd timeout-ms) + ;; Use poll() to wait for data on fd with a timeout. + ;; Returns 'ready if data available, #f on timeout, 'error on error. + ;; This is a pure C call — it does NOT interact with Chez GC. + (let ([pfd (foreign-alloc POLLFD_SIZE)]) + (foreign-set! 'int pfd 0 fd) ;; .fd + (foreign-set! 'short pfd 4 POLLIN) ;; .events + (foreign-set! 'short pfd 6 0) ;; .revents + (let ([rc (c-poll pfd 1 timeout-ms)]) + (let ([result (cond + [(> rc 0) 'ready] + [(= rc 0) #f] ;; timeout + [else 'error])]) + (foreign-free pfd) + result)))) + + (define (repl-socket-nanosleep ms) + ;; Sleep for ms milliseconds using raw nanosleep(). + ;; This is a pure C call — does NOT use Chez sleep/condition-wait, + ;; so it doesn't participate in GC rendezvous. + (let ([ts (foreign-alloc 16)]) ;; struct timespec: long tv_sec, long tv_nsec + (foreign-set! 'long ts 0 (quotient ms 1000)) + (foreign-set! 'long ts 8 (* (remainder ms 1000) 1000000)) + (c-nanosleep ts 0) + (foreign-free ts))) + + (define (repl-deactivate-thread!) + ;; Deactivate this Chez thread for GC purposes. + ;; After this call, GC will NOT wait for this thread at rendezvous. + ;; The thread must NOT touch any Scheme heap objects until reactivated. + (c-deactivate)) + + (define (repl-activate-thread!) + ;; Reactivate this Chez thread. Must be called before accessing any + ;; Scheme objects. Will block if a GC is currently in progress (safe). + (c-activate)) + + ;; ========== GC-safe subprocess/file I/O ========== + ;; + ;; These functions deactivate the Chez thread during the blocking C call + ;; (popen+fread, fopen+fread, fopen+fwrite) and reactivate before returning. + ;; The Chez FFI converts the C string return to a Scheme string AFTER + ;; reactivation, so heap allocation is safe. + + (define c-capture-command + (foreign-procedure "repl_capture_command" (string) string)) + (define c-read-file + (foreign-procedure "repl_read_file" (string) string)) + (define c-write-file + (foreign-procedure "repl_write_file" (string string size_t) int)) + + (define (repl-capture-command cmd) + ;; Run a shell command in a GC-safe way. The thread is deactivated + ;; during the blocking popen/fread so GC can proceed. + ;; Returns the command's stdout as a string (empty string on error). + (c-capture-command cmd)) + + (define (repl-read-file path) + ;; Read a file in a GC-safe way. Returns content string (empty on error). + (c-read-file path)) + + (define (repl-write-file path content) + ;; Write content to a file in a GC-safe way. Returns #t/#f. + (= 0 (c-write-file path content (string-length content)))) + ) ;; end library new file mode 100755 Binary files /dev/null and b/repl_shim.so differ --- a/src/jerboa-emacs/async.ss +++ b/src/jerboa-emacs/async.ss @@ -9,9 +9,12 @@ ;;; - Master timer drains UI queue on primordial thread (safe for Qt) ;;; ;;; GC safety: -;;; Chez SMP GC uses active_threads count for stop-the-world rendezvous. -;;; fork-thread properly decrements S_nthreads when thunks complete. +;;; Chez SMP GC uses stop-the-world rendezvous (active_threads must reach 0). ;;; Threads blocked in sleep/condition-wait/mutex-acquire auto-deactivate. +;;; Threads blocked in foreign calls (read/popen) do NOT auto-deactivate. +;;; Solution: repl-capture-command (C level) deactivates around blocking I/O. +;;; NEVER use open-process-ports + get-line in worker threads — use +;;; repl-capture-command instead. ;;; NEVER block the primordial thread — it freezes the entire UI. (export @@ -58,7 +61,45 @@ :std/misc/atom :std/sugar :std/srfi/13 - :jerboa-emacs/core) + :jerboa-emacs/core + (only-in :jerboa/repl-socket + repl-capture-command + repl-read-file + repl-write-file)) + +;;;============================================================================ +;;; String Helpers +;;;============================================================================ + +(def (string-split-newlines str) + "Split a string on newline characters. Drops trailing empty string." + (let ((len (string-length str))) + (if (= len 0) '() + (let loop ((start 0) (i 0) (acc '())) + (cond + ((>= i len) + (let ((last (substring str start len))) + (reverse (if (string=? last "") acc (cons last acc))))) + ((char=? (string-ref str i) #\newline) + (loop (+ i 1) (+ i 1) (cons (substring str start i) acc))) + (else (loop start (+ i 1) acc))))))) + +(def (shell-escape-single-quotes str) + "Escape single quotes for use inside a single-quoted shell string. + Replaces ' with '\\'' (end quote, escaped quote, start quote)." + (let loop ((i 0) (acc '())) + (if (>= i (string-length str)) + (apply string-append (reverse acc)) + (if (char=? (string-ref str i) #\') + (loop (+ i 1) (cons "'\\''" acc)) + (let ((start i)) + (let scan ((j (+ i 1))) + (cond + ((>= j (string-length str)) + (loop j (cons (substring str start j) acc))) + ((char=? (string-ref str j) #\') + (loop j (cons (substring str start j) acc))) + (else (scan (+ j 1)))))))))) ;;;============================================================================ ;;; Thread Pinning (no-op on Chez) @@ -73,14 +114,12 @@ ;;; Background Worker ;;;============================================================================ - - - (def (spawn-worker name thunk) "Spawn a background worker thread for blocking operations. - Uses fork-thread which properly decrements S_nthreads on completion. - The thunk runs in a background thread — do NOT call Qt FFI from it. - Post Qt operations back to the UI thread via ui-queue-push!." + Worker thunks should use repl-capture-command (not open-process-ports) + for subprocess I/O, and repl-read-file/repl-write-file for file I/O. + These C-level helpers deactivate the Chez thread during blocking system + calls so GC can proceed, then reactivate before returning Scheme strings." (let ((t (make-thread (lambda () (with-catch @@ -166,8 +205,9 @@ on-error: (on-error #f) stdin-text: (stdin-text #f)) "Run shell command in a background thread, deliver result via UI queue. - The callback runs on the primordial/UI thread (safe for Qt operations). - Never blocks the event loop." + Uses repl-capture-command for GC-safe subprocess I/O — the thread is + deactivated during the blocking popen/fread at the C level. + The callback runs on the primordial/UI thread (safe for Qt operations)." (spawn-worker 'async-process (lambda () (with-catch @@ -177,23 +217,22 @@ (if on-error (on-error e) (jemacs-log! "async-process error: " (format "~a" e)))))) (lambda () - (let-values (((in-port out-port err-port pid) - (open-process-ports cmd (buffer-mode block) (native-transcoder)))) - (when stdin-text - (put-string out-port stdin-text) - (flush-output-port out-port)) - (close-port out-port) - (close-port err-port) - (let ((out (get-string-all in-port))) - (close-port in-port) - (let ((result (if (eof-object? out) "" out))) - (ui-queue-push! (lambda () (callback result))))))))))) + (let ((full-cmd (if stdin-text + ;; For stdin: use printf piped to command + ;; (shell handles the pipe, no Chez port blocking) + (string-append "printf '%s' '" + (shell-escape-single-quotes stdin-text) + "' | " cmd) + cmd))) + (let ((result (repl-capture-command full-cmd))) + (ui-queue-push! (lambda () (callback result)))))))))) (def (async-process-stream! cmd on-line: on-line on-done: (on-done #f) on-error: (on-error #f)) "Run shell command in background thread, deliver each line via UI queue. + Uses repl-capture-command for GC-safe I/O, then splits output into lines. Callbacks run on the primordial/UI thread (safe for Qt operations)." (spawn-worker 'async-process-stream (lambda () @@ -204,20 +243,15 @@ (if on-error (on-error e) (jemacs-log! "async-process-stream error: " (format "~a" e)))))) (lambda () - (let-values (((in-port out-port err-port pid) - (open-process-ports cmd (buffer-mode line) (native-transcoder)))) - (close-port out-port) - (close-port err-port) - (let loop () - (let ((line (get-line in-port))) - (if (eof-object? line) - (begin - (close-port in-port) - (when on-done - (ui-queue-push! on-done))) - (begin - (ui-queue-push! (lambda () (on-line line))) - (loop))))))))))) + (let ((output (repl-capture-command cmd))) + ;; Split output into lines and deliver each via UI queue + (let ((lines (string-split-newlines output))) + (for-each + (lambda (line) + (ui-queue-push! (lambda () (on-line line)))) + lines) + (when on-done + (ui-queue-push! on-done))))))))) ;;;============================================================================ ;;; Async File I/O @@ -225,25 +259,22 @@ (def (async-read-file! path callback) "Read file in a background thread, deliver content via UI queue. + Uses repl-read-file for GC-safe file I/O. Callback receives the file content string, or #f on error." (spawn-worker 'async-read-file (lambda () (let ((content (with-catch (lambda (e) #f) - (lambda () - (call-with-input-file path - (lambda (port) (get-string-all port))))))) + (lambda () (repl-read-file path))))) (ui-queue-push! (lambda () (callback content))))))) (def (async-write-file! path content callback) "Write file in a background thread, deliver result via UI queue. + Uses repl-write-file for GC-safe file I/O. Callback receives #t on success, #f on error." (spawn-worker 'async-write-file (lambda () (let ((ok (with-catch (lambda (e) #f) - (lambda () - (call-with-output-file path - (lambda (port) (display content port))) - #t)))) + (lambda () (repl-write-file path content))))) (ui-queue-push! (lambda () (callback ok))))))) ;;;============================================================================ @@ -339,39 +370,31 @@ (def (git-status-collect dir) "Run git status subprocess and return a hash with branch/modified/staged/untracked. - Runs in the calling thread (designed for background worker)." - (let-values (((in-port out-port err-port pid) - (open-process-ports - (string-append "git -C \"" dir "\" status --porcelain -b 2>&1") - (buffer-mode line) (native-transcoder)))) - (close-port out-port) - (close-port err-port) - (let ((lines (let rd ((acc '())) - (let ((line (get-line in-port))) - (if (eof-object? line) (reverse acc) - (rd (cons line acc))))))) - (close-port in-port) - (let ((status (make-hash-table)) - (modified 0) (staged 0) (untracked 0)) - (for-each - (lambda (line) - (when (>= (string-length line) 3) - (let ((xy (substring line 0 2))) - (cond - ((string-prefix? "##" xy) - (hash-put! status 'branch - (substring line 3 (string-length line)))) - ((string-contains xy "?") - (set! untracked (+ untracked 1))) - ((or (string-contains xy "M") (string-contains xy "D")) - (set! modified (+ modified 1))) - ((or (string-contains xy "A") (string-contains xy "R")) - (set! staged (+ staged 1))))))) - lines) - (hash-put! status 'modified modified) - (hash-put! status 'staged staged) - (hash-put! status 'untracked untracked) - status)))) + Uses repl-capture-command for GC-safe subprocess I/O." + (let* ((output (repl-capture-command + (string-append "git -C \"" dir "\" status --porcelain -b 2>&1"))) + (lines (string-split-newlines output)) + (status (make-hash-table)) + (modified 0) (staged 0) (untracked 0)) + (for-each + (lambda (line) + (when (>= (string-length line) 3) + (let ((xy (substring line 0 2))) + (cond + ((string-prefix? "##" xy) + (hash-put! status 'branch + (substring line 3 (string-length line)))) + ((string-contains xy "?") + (set! untracked (+ untracked 1))) + ((or (string-contains xy "M") (string-contains xy "D")) + (set! modified (+ modified 1))) + ((or (string-contains xy "A") (string-contains xy "R")) + (set! staged (+ staged 1))))))) + lines) + (hash-put! status 'modified modified) + (hash-put! status 'staged staged) + (hash-put! status 'untracked untracked) + status)) (def (git-watcher-tick!) "One git status poll. Spawns a background thread for the subprocess, --- a/src/jerboa-emacs/debug-repl.ss +++ b/src/jerboa-emacs/debug-repl.ss @@ -2,14 +2,9 @@