Restore SMP threading: background workers for blocking ops, Qt on primordial
ober
6dc5addb07e3db4ea62734e7ae9bde29e7686833
--- a/lib/jerboa-emacs/async.sls +++ b/lib/jerboa-emacs/async.sls @@ -3,14 +3,14 @@ ;;; Source: src/jerboa-emacs/async.ss (library (jerboa-emacs async) - (export ui-queue-push! ui-queue-drain! - pin-thread-to-processor0! spawn/name/pinned async-process! - async-process-stream! async-read-file! async-write-file! - async-eval! schedule-periodic! master-timer-tick! - current-time-ms *file-index* start-file-indexer! - stop-file-indexer! file-index-lookup *git-status-cache* - start-git-watcher! stop-git-watcher! flycheck-trigger! - start-flycheck-watcher! stop-flycheck-watcher!) + (export ui-queue-push! ui-queue-drain! spawn-worker + async-process! async-process-stream! async-read-file! + async-write-file! async-eval! schedule-periodic! + master-timer-tick! current-time-ms *file-index* + start-file-indexer! stop-file-indexer! file-index-lookup + *git-status-cache* start-git-watcher! stop-git-watcher! + flycheck-trigger! start-flycheck-watcher! + stop-flycheck-watcher!) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -20,13 +20,19 @@ (std misc atom) (std sugar) (std srfi srfi-13) (jerboa-emacs core) (except (jerboa core) time->seconds) (jerboa runtime)) - (def (pin-thread-to-processor0! thread) - "Pin a green thread to processor 0 (no-op on Chez — no thread pinning API)." - #f) - (def (spawn/name/pinned name thunk) - "Spawn a named green thread pinned to processor 0.\n The thread is pinned before starting so it never runs on any other processor.\n Use for threads that must stay on the main OS thread (Qt UI operations)." - (let ([t (make-thread thunk name)]) - (pin-thread-to-processor0! t) + (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!." + (let ([t (make-thread + (lambda () + (with-catch + (lambda (e) + (jemacs-log! + "Worker " + (symbol->string name) + " error: " + (format "~a" e))) + thunk)) + name)]) (thread-start! t) t)) (def *ui-queue* (make-channel 4096)) @@ -78,75 +84,100 @@ *scheduled-tasks*)))) (def (async-process! cmd callback: callback on-error: (on-error #f) stdin-text: (stdin-text #f)) - "Run shell command synchronously and call callback with result.\n Blocks the caller until the subprocess finishes — avoids GC deadlocks\n caused by background Chez threads blocking in foreign calls." - (with-catch - (lambda (e) - (if on-error - (on-error e) - (jemacs-log! "async-process error: " (format "~a" e)))) + "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." + (spawn-worker + 'async-process (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)]) - (callback result))))))) + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (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))))))))))) (def (async-process-stream! cmd on-line: on-line on-done: (on-done #f) on-error: (on-error #f)) - "Run shell command synchronously, deliver each line to on-line callback.\n Blocks until the subprocess finishes — avoids GC deadlocks." - (with-catch - (lambda (e) - (if on-error - (on-error e) - (jemacs-log! - "async-process-stream error: " - (format "~a" e)))) + "Run shell command in background thread, deliver each line via UI queue.\n Callbacks run on the primordial/UI thread (safe for Qt operations)." + (spawn-worker + 'async-process-stream (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 (on-done))) - (begin (on-line line) (loop))))))))) + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (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))))))))))) (def (async-read-file! path callback) - "Read file synchronously and call callback immediately.\n Runs on the caller's thread to avoid Chez SMP GC deadlocks caused by\n background threads blocking in foreign calls (file I/O)." - (let ([content (with-catch - (lambda (e) #f) - (lambda () - (call-with-input-file - path - (lambda (port) (get-string-all port)))))]) - (callback content))) + "Read file in a background thread, deliver content via UI queue.\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)))))]) + (ui-queue-push! (lambda () (callback content))))))) (def (async-write-file! path content callback) - "Write file synchronously and call callback immediately.\n Runs on the caller's thread to avoid GC deadlocks." - (let ([ok (with-catch - (lambda (e) #f) - (lambda () - (call-with-output-file - path - (lambda (port) (display content port))) - #t))]) - (callback ok))) + "Write file in a background thread, deliver result via UI queue.\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))]) + (ui-queue-push! (lambda () (callback ok))))))) (def (async-eval! thunk callback) - "Evaluate thunk synchronously and call callback immediately.\n Runs on the caller's thread to avoid GC deadlocks." - (let ([result (with-catch - (lambda (e) (values 'error e)) - thunk)]) - (callback result))) + "Evaluate thunk in background thread, deliver result via UI queue.\n Callback runs on the primordial/UI thread." + (spawn-worker + 'async-eval + (lambda () + (let ([result (with-catch + (lambda (e) (values 'error e)) + thunk)]) + (ui-queue-push! (lambda () (callback result))))))) (define *file-index*--cell (vector (atom (make-hash-table)))) (def *file-indexer-root* #f) @@ -176,16 +207,24 @@ (cons path existing))))))))) (directory-files dir))) index)))) + (def *file-indexer-running* #f) (def (start-file-indexer! root-dir) - "Register file indexer as a periodic task (30s interval).\n Runs on the master timer thread — no background Chez thread needed." + "Register file indexer as a periodic task (30s interval).\n The periodic tick spawns a background thread for the filesystem walk,\n then posts the result to the UI thread via atom-reset!." (stop-file-indexer!) (set! *file-indexer-root* root-dir) (schedule-periodic! 'file-indexer 30000 (lambda () - (when *file-indexer-root* - (let ([index (build-file-index *file-indexer-root*)]) - (atom-reset! *file-index* index)))))) + (when (and *file-indexer-root* (not *file-indexer-running*)) + (set! *file-indexer-running* #t) + (spawn-worker + 'file-indexer + (lambda () + (let ([index (build-file-index *file-indexer-root*)]) + (ui-queue-push! + (lambda () + (atom-reset! *file-index* index) + (set! *file-indexer-running* #f)))))))))) (def (stop-file-indexer!) "Stop the file indexer." (set! *file-indexer-root* #f)) @@ -202,57 +241,70 @@ (let ([status (substring line 0 2)] [file (substring line 3 (string-length line))]) (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)))) (def (git-watcher-tick!) - "One git status poll. Called from the periodic scheduler." - (when *git-watcher-dir* - (with-catch - (lambda (e) #f) - (lambda () - (let-values ([(in-port out-port err-port pid) - (open-process-ports - (string-append - "git -C \"" - *git-watcher-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) - (atom-reset! *git-status-cache* status) - (when *git-watcher-callback* - (*git-watcher-callback* status))))))))) + "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*)) + (set! *git-watcher-running* #t) + (let ([dir *git-watcher-dir*]) + (spawn-worker + 'git-watcher + (lambda () + (let ([status (with-catch + (lambda (e) #f) + (lambda () (git-status-collect dir)))]) + (ui-queue-push! + (lambda () + (when status + (atom-reset! *git-status-cache* status) + (when *git-watcher-callback* + (*git-watcher-callback* status))) + (set! *git-watcher-running* #f))))))))) (def (start-git-watcher! dir (on-update #f)) "Register git status polling as a periodic task (5s interval).\n Runs on the master timer thread — no background Chez thread needed." (stop-git-watcher!) (set! *git-watcher-dir* dir) @@ -269,24 +321,41 @@ "Queue a flycheck run for the given file path." (unless (member path *flycheck-pending*) (set! *flycheck-pending* (cons path *flycheck-pending*)))) + (def *flycheck-running* #f) (def (start-flycheck-watcher! lint-fn on-result) - "Register flycheck as a periodic task (500ms interval).\n Runs on the master timer thread — no background Chez thread needed." + "Register flycheck as a periodic task (500ms interval).\n Spawns background thread for linting, posts results to UI thread." (stop-flycheck-watcher!) (set! *flycheck-lint-fn* lint-fn) (set! *flycheck-result-fn* on-result) (schedule-periodic! 'flycheck 500 (lambda () - (when (and *flycheck-lint-fn* (pair? *flycheck-pending*)) - (let ([path (car *flycheck-pending*)]) + (when (and *flycheck-lint-fn* + (pair? *flycheck-pending*) + (not *flycheck-running*)) + (let ([path (car *flycheck-pending*)] + [lint *flycheck-lint-fn*] + [result-fn *flycheck-result-fn*]) (set! *flycheck-pending* (cdr *flycheck-pending*)) (when (string? path) - (with-catch - (lambda (e) - (jemacs-log! "flycheck error: " (format "~a" e))) + (set! *flycheck-running* #t) + (spawn-worker + 'flycheck (lambda () - (let ([errors (*flycheck-lint-fn* path)]) - (*flycheck-result-fn* path errors)))))))))) + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (jemacs-log! + "flycheck error: " + (format "~a" e)) + (set! *flycheck-running* #f)))) + (lambda () + (let ([errors (lint path)]) + (ui-queue-push! + (lambda () + (result-fn path errors) + (set! *flycheck-running* #f)))))))))))))) (def (stop-flycheck-watcher!) "Stop the flycheck watcher." (set! *flycheck-lint-fn* #f) (set! *flycheck-result-fn* #f) (set! *flycheck-pending* '())) --- a/lib/jerboa-emacs/qt/commands-ide.sls +++ b/lib/jerboa-emacs/qt/commands-ide.sls @@ -39,14 +39,14 @@ mutex? mutex-name printf fprintf sort sort!) (std sugar) (chez-scintilla constants) (std sort) (std srfi srfi-13) (std format) (std text base64) - (std misc completion) (jerboa-emacs qt sci-shim) - (jerboa-emacs core) (jerboa-emacs async) - (jerboa-emacs editor) (jerboa-emacs repl) - (jerboa-emacs eshell) (jerboa-emacs shell) - (jerboa-emacs terminal) (jerboa-emacs qt buffer) - (jerboa-emacs qt window) (jerboa-emacs qt echo) - (jerboa-emacs qt highlight) (jerboa-emacs qt modeline) - (jerboa-emacs qt magit) (jerboa-emacs qt commands-core) + (jerboa-emacs qt sci-shim) (jerboa-emacs core) + (jerboa-emacs async) (jerboa-emacs editor) + (jerboa-emacs repl) (jerboa-emacs eshell) + (jerboa-emacs shell) (jerboa-emacs terminal) + (jerboa-emacs qt buffer) (jerboa-emacs qt window) + (jerboa-emacs qt echo) (jerboa-emacs qt highlight) + (jerboa-emacs qt modeline) (jerboa-emacs qt magit) + (jerboa-emacs qt commands-core) (jerboa-emacs qt commands-core2) (jerboa-emacs qt commands-edit) (jerboa-emacs qt commands-edit2) @@ -516,21 +516,22 @@ [dir (if path (path-directory path) (current-directory))]) (set! *magit-dir* dir) (echo-message! (app-state-echo app) "Loading git status...") - (let ([status-done (make-completion 'status)] - [branch-done (make-completion 'branch)]) - (magit-run-git/async - '("status" "--porcelain") - dir - (lambda (output) (completion-post! status-done output))) - (magit-run-git/async - '("rev-parse" "--abbrev-ref" "HEAD") - dir - (lambda (output) (completion-post! branch-done output))) - (magit-render-status! - app - (completion-wait! status-done) - (completion-wait! branch-done) - dir)))) + (spawn-worker + 'magit-status + (lambda () + (let ([status-output (magit-run-git + '("status" "--porcelain") + dir)] + [branch-output (magit-run-git + '("rev-parse" "--abbrev-ref" "HEAD") + dir)]) + (ui-queue-push! + (lambda () + (magit-render-status! + app + status-output + branch-output + dir)))))))) (def (cmd-magit-stage app) "Stage file or hunk at point." (let ([buf (current-qt-buffer app)]) @@ -828,58 +829,59 @@ (if file (begin (echo-message! (app-state-echo app) "Loading diff...") - (let ([unstaged-done (make-completion 'diff)] - [staged-done (make-completion 'diff-cached)]) - (magit-run-git/async - (list "diff" file) - *magit-dir* - (lambda (out) (completion-post! unstaged-done out))) - (magit-run-git/async - (list "diff" "--cached" file) - *magit-dir* - (lambda (out) (completion-post! staged-done out))) - (let ([diff-output (completion-wait! unstaged-done)] - [staged-diff (completion-wait! staged-done)]) - (let* ([full-diff (string-append - (if (> (string-length - staged-diff) - 0) - (string-append - "Staged:\n" - staged-diff - "\n") - "") - (if (> (string-length - diff-output) - 0) - (string-append - "Unstaged:\n" - diff-output) - ""))] - [ed (current-qt-editor app)] - [fr (app-state-frame app)] - [diff-buf (or (buffer-by-name "*Magit Diff*") - (qt-buffer-create! - "*Magit Diff*" - ed - #f))]) - (qt-buffer-attach! ed diff-buf) - (qt-edit-window-buffer-set! - (qt-current-window fr) - diff-buf) - (qt-plain-text-edit-set-text! - ed - (if (string=? full-diff "") - "No differences.\n" - full-diff)) - (qt-text-document-set-modified! - (buffer-doc-pointer diff-buf) - #f) - (qt-plain-text-edit-set-cursor-position! ed 0) - (qt-highlight-diff! ed)))) - (echo-error! - (app-state-echo app) - "No file at point"))))))) + (let ([dir *magit-dir*]) + (spawn-worker + 'magit-diff + (lambda () + (let ([diff-output (magit-run-git + (list "diff" file) + dir)] + [staged-diff (magit-run-git + (list "diff" "--cached" file) + dir)]) + (ui-queue-push! + (lambda () + (let* ([full-diff (string-append + (if (> (string-length + staged-diff) + 0) + (string-append + "Staged:\n" + staged-diff + "\n") + "") + (if (> (string-length + diff-output) + 0) + (string-append + "Unstaged:\n" + diff-output) + ""))] + [ed2 (current-qt-editor app)] + [fr (app-state-frame app)] + [diff-buf (or (buffer-by-name + "*Magit Diff*") + (qt-buffer-create! + "*Magit Diff*" + ed2 + #f))]) + (qt-buffer-attach! ed2 diff-buf) + (qt-edit-window-buffer-set! + (qt-current-window fr) + diff-buf) + (qt-plain-text-edit-set-text! + ed2 + (if (string=? full-diff "") + "No differences.\n" + full-diff)) + (qt-text-document-set-modified! + (buffer-doc-pointer diff-buf) + #f) + (qt-plain-text-edit-set-cursor-position! + ed2 + 0) + (qt-highlight-diff! ed2)))))))))) + (echo-error! (app-state-echo app) "No file at point"))))) (def (cmd-magit-stage-all app) "Stage all changes." (when *magit-dir* --- a/lib/jerboa-emacs/qt/magit.sls +++ b/lib/jerboa-emacs/qt/magit.sls @@ -15,7 +15,8 @@ (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex mutex? mutex-name) - (std sugar) (std srfi srfi-13) (jerboa-emacs async) + (std sugar) (std srfi srfi-13) + (only (jerboa-emacs async) spawn-worker ui-queue-push!) (jerboa core) (jerboa runtime)) (def (magit-run-git args dir) "Run git command, return output. Omits process-status to avoid Qt SIGCHLD race." @@ -49,19 +50,22 @@ (close-port proc) (or out "")))))) (def (magit-run-git/async args dir callback) - "Run git synchronously and call callback with output.\n Avoids GC deadlocks from background Chez threads." - (let ([output (with-catch - (lambda (e) "") - (lambda () - (let* ([proc (open-process - (list 'path: "/usr/bin/git" 'arguments: - args 'directory: dir - 'stdout-redirection: #t - 'stderr-redirection: #t))] - [out (read-line proc #f)]) - (close-port proc) - (or out ""))))]) - (callback output))) + "Run git in a background thread, deliver output via UI queue.\n Callback runs on the primordial/UI thread (safe for Qt operations)." + (spawn-worker + 'magit-git + (lambda () + (let ([output (with-catch + (lambda (e) "") + (lambda () + (let* ([proc (open-process + (list 'path: "/usr/bin/git" + 'arguments: args 'directory: + dir 'stdout-redirection: #t + 'stderr-redirection: #t))] + [out (read-line proc #f)]) + (close-port proc) + (or out ""))))]) + (ui-queue-push! (lambda () (callback output))))))) (def (magit-parse-status output) "Parse git status --porcelain output into list of (status . filename)." (let ([lines (string-split output #\newline)]) --- a/src/jerboa-emacs/async.ss +++ b/src/jerboa-emacs/async.ss @@ -1,26 +1,26 @@ ;;; -*- Gerbil -*- ;;; Async infrastructure for jemacs SMP ;;; -;;; Provides a unified UI action queue, async process runners, -;;; async file I/O, and a periodic task scheduler. -;;; Background threads push thunks via ui-queue-push!; a master timer -;;; drains them on the UI thread. +;;; Architecture: +;;; - Primordial thread runs Qt event loop + master timer (UI-only) +;;; - Background threads (via fork-thread) handle blocking work: +;;; subprocesses, file I/O, filesystem walks, git operations +;;; - Background threads post results to UI queue via ui-queue-push! +;;; - Master timer drains UI queue on primordial thread (safe for Qt) ;;; -;;; SMP Thread Pinning: -;;; Gambit SMP can migrate green threads between OS-level Virtual Processors -;;; via work-stealing. For Qt apps, the UI thread must stay on processor 0 -;;; (the main OS thread) so Qt widget operations happen on the correct pthread. -;;; Use pin-thread-to-processor0! to pin critical threads, and -;;; spawn/name/pinned to spawn a green thread pre-pinned to processor 0. +;;; GC safety: +;;; Chez SMP GC uses active_threads count for stop-the-world rendezvous. +;;; fork-thread properly decrements S_nthreads when thunks complete. +;;; Threads blocked in sleep/condition-wait/mutex-acquire auto-deactivate. +;;; NEVER block the primordial thread — it freezes the entire UI. (export ;; UI action queue ui-queue-push! ui-queue-drain! - ;; SMP thread pinning - pin-thread-to-processor0! - spawn/name/pinned + ;; Background worker + spawn-worker ;; Async command runner async-process! @@ -58,25 +58,25 @@ :jerboa-emacs/core) ;;;============================================================================ -;;; SMP Thread Pinning +;;; Background Worker ;;;============================================================================ -(def (pin-thread-to-processor0! thread) - "Pin a green thread to processor 0 (no-op on Chez — no thread pinning API)." - #f) - - - - -(def (spawn/name/pinned name thunk) - "Spawn a named green thread pinned to processor 0. - The thread is pinned before starting so it never runs on any other processor. - Use for threads that must stay on the main OS thread (Qt UI operations)." - (let ((t (make-thread thunk name))) - (pin-thread-to-processor0! t) +(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!." + (let ((t (make-thread + (lambda () + (with-catch + (lambda (e) + (jemacs-log! "Worker " (symbol->string name) " error: " + (format "~a" e))) + thunk)) + name))) (thread-start! t) t)) @@ -153,87 +153,100 @@ callback: callback on-error: (on-error #f) stdin-text: (stdin-text #f)) - "Run shell command synchronously and call callback with result. - Blocks the caller until the subprocess finishes — avoids GC deadlocks - caused by background Chez threads blocking in foreign calls." - (with-catch - (lambda (e) - (if on-error (on-error e) - (jemacs-log! "async-process error: " (format "~a" e)))) + "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." + (spawn-worker 'async-process (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) - ;; Read all output - (let ((out (get-string-all in-port))) - (close-port in-port) - (let ((result (if (eof-object? out) "" out))) - (callback result))))))) + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (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))))))))))) (def (async-process-stream! cmd on-line: on-line on-done: (on-done #f) on-error: (on-error #f)) - "Run shell command synchronously, deliver each line to on-line callback. - Blocks until the subprocess finishes — avoids GC deadlocks." - (with-catch - (lambda (e) - (if on-error (on-error e) - (jemacs-log! "async-process-stream error: " (format "~a" e)))) + "Run shell command in background thread, deliver each line via UI queue. + Callbacks run on the primordial/UI thread (safe for Qt operations)." + (spawn-worker 'async-process-stream (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 (on-done))) - (begin - (on-line line) - (loop))))))))) + (with-catch + (lambda (e) + (ui-queue-push! + (lambda () + (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))))))))))) ;;;============================================================================ ;;; Async File I/O ;;;============================================================================ (def (async-read-file! path callback) - "Read file synchronously and call callback immediately. - Runs on the caller's thread to avoid Chez SMP GC deadlocks caused by - background threads blocking in foreign calls (file I/O)." - (let ((content (with-catch (lambda (e) #f) - (lambda () - (call-with-input-file path - (lambda (port) (get-string-all port))))))) - (callback content))) + "Read file in a background thread, deliver content via UI queue. + 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))))))) + (ui-queue-push! (lambda () (callback content))))))) (def (async-write-file! path content callback) - "Write file synchronously and call callback immediately. - Runs on the caller's thread to avoid GC deadlocks." - (let ((ok (with-catch (lambda (e) #f) - (lambda () - (call-with-output-file path - (lambda (port) (display content port))) - #t)))) - (callback ok))) + "Write file in a background thread, deliver result via UI queue. + 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)))) + (ui-queue-push! (lambda () (callback ok))))))) ;;;============================================================================ ;;; Async Eval ;;;============================================================================ (def (async-eval! thunk callback) - "Evaluate thunk synchronously and call callback immediately. - Runs on the caller's thread to avoid GC deadlocks." - (let ((result (with-catch - (lambda (e) (values 'error e)) - thunk))) - (callback result))) + "Evaluate thunk in background thread, deliver result via UI queue. + Callback runs on the primordial/UI thread." + (spawn-worker 'async-eval + (lambda () + (let ((result (with-catch + (lambda (e) (values 'error e)) + thunk))) + (ui-queue-push! (lambda () (callback result))))))) ;;;============================================================================ ;;; Background Services @@ -269,16 +282,25 @@ (directory-files dir))) index)))) +(def *file-indexer-running* #f) + (def (start-file-indexer! root-dir) "Register file indexer as a periodic task (30s interval). - Runs on the master timer thread — no background Chez thread needed." + The periodic tick spawns a background thread for the filesystem walk, + then posts the result to the UI thread via atom-reset!." (stop-file-indexer!) (set! *file-indexer-root* root-dir) (schedule-periodic! 'file-indexer 30000 (lambda () - (when *file-indexer-root* - (let ((index (build-file-index *file-indexer-root*))) - (atom-reset! *file-index* index)))))) + (when (and *file-indexer-root* (not *file-indexer-running*)) + (set! *file-indexer-running* #t) + (spawn-worker 'file-indexer + (lambda () + (let ((index (build-file-index *file-indexer-root*))) + (ui-queue-push! + (lambda () + (atom-reset! *file-index* index) + (set! *file-indexer-running* #f)))))))))) (def (stop-file-indexer!) "Stop the file indexer." @@ -301,49 +323,61 @@ (file (substring line 3 (string-length line)))) (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. + 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)))) + (def (git-watcher-tick!) - "One git status poll. Called from the periodic scheduler." - (when *git-watcher-dir* - (with-catch - (lambda (e) #f) - (lambda () - (let-values (((in-port out-port err-port pid) - (open-process-ports - (string-append "git -C \"" *git-watcher-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) - (atom-reset! *git-status-cache* status) - (when *git-watcher-callback* - (*git-watcher-callback* status))))))))) + "One git status poll. Spawns a background thread for the subprocess, + posts results to UI thread. Skips if previous poll still running." + (when (and *git-watcher-dir* (not *git-watcher-running*)) + (set! *git-watcher-running* #t) + (let ((dir *git-watcher-dir*)) + (spawn-worker 'git-watcher + (lambda ()