Eliminate remaining spawn/name calls in Qt modules to fix GC deadlock
ober
8983126aeea430fe4755185e7235314ebe42f369
--- a/lib/jerboa-emacs/qt/commands-config2.sls +++ b/lib/jerboa-emacs/qt/commands-config2.sls @@ -244,27 +244,22 @@ " marked files? (yes/no): "))]) (when (and confirm (string=? confirm "yes")) (echo-message! (app-state-echo app) "Deleting...") - (spawn/name - 'dired-delete - (lambda () - (let ([count 0]) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (delete-file path) - (set! count (+ count 1))))) - files) - (ui-queue-push! + (let ([count 0]) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! - (app-state-echo app) - (string-append - "Deleted " - (number->string count) - " files")))))))))))) + (delete-file path) + (set! count (+ count 1))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! + (app-state-echo app) + (string-append + "Deleted " + (number->string count) + " files")))))))) (def (cmd-dired-do-copy-marked app) "Copy all marked files in dired to a destination directory (async)." (let* ([buf (current-qt-buffer app)] @@ -278,32 +273,26 @@ (when (and dest (> (string-length dest) 0)) (let ([dest-dir (path-expand dest)]) (echo-message! (app-state-echo app) "Copying...") - (spawn/name - 'dired-copy - (lambda () - (let ([count 0]) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (let ([target (path-expand - (path-strip-directory - path) - dest-dir)]) - (copy-file path target) - (set! count (+ count 1)))))) - files) - (ui-queue-push! + (let ([count 0]) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! - (app-state-echo app) - (string-append - "Copied " - (number->string count) - " files to " - dest-dir))))))))))))) + (let ([target (path-expand + (path-strip-directory path) + dest-dir)]) + (copy-file path target) + (set! count (+ count 1)))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! + (app-state-echo app) + (string-append + "Copied " + (number->string count) + " files to " + dest-dir))))))))) (def (cmd-dired-do-rename-marked app) "Move/rename all marked files in dired to a destination directory (async)." (let* ([buf (current-qt-buffer app)] @@ -317,32 +306,26 @@ (when (and dest (> (string-length dest) 0)) (let ([dest-dir (path-expand dest)]) (echo-message! (app-state-echo app) "Moving...") - (spawn/name - 'dired-rename - (lambda () - (let ([count 0]) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (let ([target (path-expand - (path-strip-directory - path) - dest-dir)]) - (rename-file path target) - (set! count (+ count 1)))))) - files) - (ui-queue-push! + (let ([count 0]) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! - (app-state-echo app) - (string-append - "Moved " - (number->string count) - " files to " - dest-dir))))))))))))) + (let ([target (path-expand + (path-strip-directory path) + dest-dir)]) + (rename-file path target) + (set! count (+ count 1)))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! + (app-state-echo app) + (string-append + "Moved " + (number->string count) + " files to " + dest-dir))))))))) (def (cmd-dired-mark-by-regexp app) "Mark files matching a regular expression in dired." (let* ([buf (current-qt-buffer app)] @@ -1085,82 +1068,69 @@ [pattern (qt-echo-read-string app "Project search: ")]) (when (and pattern (> (string-length pattern) 0)) (echo-message! echo "Searching...") - (spawn/name - 'project-search - (lambda () - (let ([output (with-catch - (lambda (e) (list)) - (lambda () - (let* ([proc (open-process - (list 'path: "/usr/bin/grep" - 'arguments: - (list "-rn" - "--include=*.ss" - "--include=*.scm" - "--include=*.el" - "--include=*.py" - "--include=*.js" - "--include=*.ts" - "--include=*.c" - "--include=*.h" - "--include=*.rs" - "--include=*.go" - "--include=*.java" - "--include=*.rb" - "--include=*.md" - "--include=*.txt" - "--include=*.json" - "--include=*.yaml" - "--include=*.yml" - "--include=*.toml" - "--include=*.html" - "--include=*.css" - pattern root) - 'stdout-redirection: #t - 'stderr-redirection: - #t))] - [lines (let loop ([acc (list)]) - (let ([line (read-line - proc)]) - (if (eof-object? line) - (reverse acc) - (loop - (cons - line - acc)))))]) - (close-port proc) - lines)))]) - (ui-queue-push! - (lambda () - (if (null? output) - (echo-message! - echo - (string-append "No matches for: " pattern)) - (let* ([fr (app-state-frame app)] - [ed (current-qt-editor app)] - [buf (or (buffer-by-name - "*Project Search*") - (qt-buffer-create! - "*Project Search*" - ed))] - [result (string-join output "\n")]) - (qt-buffer-attach! ed buf) - (qt-edit-window-buffer-set! - (qt-current-window fr) - buf) - (qt-plain-text-edit-set-text! - ed - (string-append "=== Project search: " pattern " ===\n" - "=== Root: " root " ===\n\n" result "\n\n" - (number->string (length output)) - " match(es) found")) - (qt-plain-text-edit-set-read-only! ed #t) - (qt-modeline-update! app) - (echo-message! - echo - (string-append - (number->string (length output)) - " match(es) found")))))))))))) + (let ([output (with-catch + (lambda (e) (list)) + (lambda () + (let* ([proc (open-process + (list 'path: "/usr/bin/grep" + 'arguments: + (list "-rn" "--include=*.ss" + "--include=*.scm" + "--include=*.el" + "--include=*.py" + "--include=*.js" + "--include=*.ts" + "--include=*.c" + "--include=*.h" + "--include=*.rs" + "--include=*.go" + "--include=*.java" + "--include=*.rb" + "--include=*.md" + "--include=*.txt" + "--include=*.json" + "--include=*.yaml" + "--include=*.yml" + "--include=*.toml" + "--include=*.html" + "--include=*.css" pattern + root) + 'stdout-redirection: #t + 'stderr-redirection: #t))] + [lines (let loop ([acc (list)]) + (let ([line (read-line proc)]) + (if (eof-object? line) + (reverse acc) + (loop + (cons line acc)))))]) + (close-port proc) + lines)))]) + (if (null? output) + (echo-message! + echo + (string-append "No matches for: " pattern)) + (let* ([fr (app-state-frame app)] + [ed (current-qt-editor app)] + [buf (or (buffer-by-name "*Project Search*") + (qt-buffer-create! + "*Project Search*" + ed))] + [result (string-join output "\n")]) + (qt-buffer-attach! ed buf) + (qt-edit-window-buffer-set! (qt-current-window fr) buf) + (qt-plain-text-edit-set-text! + ed + (string-append "=== Project search: " pattern " ===\n" "=== Root: " + root " ===\n\n" result "\n\n" + (number->string (length output)) + " match(es) found")) + (qt-plain-text-edit-set-read-only! ed #t) + (qt-modeline-update! app) + (echo-message! + echo + (string-append + (number->string (length output)) + " match(es) found")))))))) (define *last-change-positions*--cell (vector (make-hash-table))) (def (record-change-position! app) --- a/lib/jerboa-emacs/qt/commands-ide.sls +++ b/lib/jerboa-emacs/qt/commands-ide.sls @@ -526,18 +526,11 @@ '("rev-parse" "--abbrev-ref" "HEAD") dir (lambda (output) (completion-post! branch-done output))) - (spawn/name - 'magit-status-join - (lambda () - (let ([status-output (completion-wait! status-done)] - [branch-output (completion-wait! branch-done)]) - (ui-queue-push! - (lambda () - (magit-render-status! - app - status-output - branch-output - dir))))))))) + (magit-render-status! + app + (completion-wait! status-done) + (completion-wait! branch-done) + dir)))) (def (cmd-magit-stage app) "Stage file or hunk at point." (let ([buf (current-qt-buffer app)]) @@ -845,56 +838,48 @@ (list "diff" "--cached" file) *magit-dir* (lambda (out) (completion-post! staged-done out))) - (spawn/name - 'magit-diff-join - (lambda () - (let ([diff-output (completion-wait! - unstaged-done)] - [staged-diff (completion-wait! - staged-done)]) - (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) - ""))] - [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 ([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"))))))) (def (cmd-magit-stage-all app) "Stage all changes." (when *magit-dir* --- a/lib/jerboa-emacs/qt/commands-ide2.sls +++ b/lib/jerboa-emacs/qt/commands-ide2.sls @@ -601,21 +601,16 @@ (+ changes (length line-edits))))))) file-changes) (when (pair? write-jobs) - (spawn/name - 'wgrep-write - (lambda () - (for-each - (lambda (job) - (with-catch - (lambda (e) - (gemacs-log! - "wgrep write error: " - (object->string e))) - (lambda () - (write-string-to-file - (car job) - (cdr job))))) - write-jobs)))))) + (for-each + (lambda (job) + (with-catch + (lambda (e) + (gemacs-log! + "wgrep write error: " + (object->string e))) + (lambda () + (write-string-to-file (car job) (cdr job))))) + write-jobs)))) (set! *wgrep-mode* #f) (echo-message! (app-state-echo app) --- a/lib/jerboa-emacs/qt/highlight.sls +++ b/lib/jerboa-emacs/qt/highlight.sls @@ -1033,16 +1033,12 @@ (sci-send ed SCI_SETSTYLING len style))) styles)) (def (qt-org-highlight-buffer-async! ed text) - "Async org highlighting: parse text in background, apply styles on UI thread." - (spawn/name - 'org-highlight - (lambda () - (let ([collector (box (list))]) - (parameterize ([*org-style-collector* collector]) - (qt-org-highlight-buffer! #f text)) - (let ([styles (reverse (unbox collector))]) - (ui-queue-push! - (lambda () (qt-org-apply-styles! ed styles)))))))) + "Org highlighting — runs synchronously to avoid GC deadlocks from\n background Chez threads that can't respond to stop-the-world GC." + (let ([collector (box (list))]) + (parameterize ([*org-style-collector* collector]) + (qt-org-highlight-buffer! #f text)) + (let ([styles (reverse (unbox collector))]) + (qt-org-apply-styles! ed styles)))) (def (qt-remove-highlighting! buf) (let* ([doc (buffer-doc-pointer buf)] [ed (and doc (hash-get *doc-editor-map* doc))]) --- a/lib/jerboa-emacs/qt/lsp-client.sls +++ b/lib/jerboa-emacs/qt/lsp-client.sls @@ -11,16 +11,16 @@ lsp-poll-ui-actions! lsp-store-pending! lsp-take-pending! lsp-read-message lsp-read-headers lsp-write-message lsp-send-request! lsp-send-request/timeout! - lsp-send-notification! lsp-reader-loop! - lsp-handle-server-notification! lsp-handle-server-request! - lsp-send-response! *lsp-diagnostics-handler* - *lsp-show-message-handler* *lsp-on-initialized-handler* - *lsp-last-sent-content* lsp-store-diagnostics! - lsp-store-show-message! lsp-content-changed? - lsp-record-sent-content! lsp-start! lsp-stop! lsp-running? - lsp-send-initialize! lsp-did-open! lsp-did-change! - lsp-did-save! lsp-did-close! file-path->uri uri->file-path - lsp-text-document-position lsp-language-id) + lsp-send-notification! lsp-poll-one-message! + lsp-drain-messages! lsp-handle-server-notification! + lsp-handle-server-request! lsp-send-response! + *lsp-diagnostics-handler* *lsp-show-message-handler* + *lsp-on-initialized-handler* *lsp-last-sent-content* + lsp-store-diagnostics! lsp-store-show-message! + lsp-content-changed? lsp-record-sent-content! lsp-start! + lsp-stop! lsp-running? lsp-send-initialize! lsp-did-open! + lsp-did-change! lsp-did-save! lsp-did-close! file-path->uri + uri->file-path lsp-text-document-position lsp-language-id) (import (except (chezscheme) make-hash-table hash-table? iota \x31;+ \x31;- getenv path-extension path-absolute? thread? make-mutex @@ -131,22 +131,7 @@ (def (lsp-send-request/timeout! method params callback timeout: (timeout 5.0) on-timeout: (on-timeout #f)) "Send a JSON-RPC request with timeout (seconds). If no response arrives\n within timeout, remove the pending callback and call on-timeout on UI thread." - (let ([id (lsp-send-request! method params callback)]) - (when id - (spawn/name - 'lsp-timeout - (lambda () - (thread-sleep! timeout) - (let ([cb (lsp-take-pending! id)]) - (when cb - (ui-queue-push! - (lambda () - (if on-timeout - (on-timeout) - (gemacs-log! - "LSP request timeout: " - method))))))))) - id)) + (let ([id (lsp-send-request! method params callback)]) id)) (def (lsp-send-notification! method params) "Send a JSON-RPC notification (no response expected)." (when *lsp-process* @@ -157,42 +142,48 @@ (with-catch (lambda (e) (void)) (lambda () (lsp-write-message *lsp-process* msg)))))) - (def (lsp-reader-loop! port) - "Background thread: read LSP messages and dispatch them." - (let loop () - (let ([msg (with-catch - (lambda (e) #f) - (lambda () (lsp-read-message port)))]) - (when (and msg (hash-table? msg)) - (let ([id (hash-get msg "id")] - [method (hash-get msg "method")] - [result (hash-get msg "result")] - [error (hash-get msg "error")]) - (cond - [(and id (not method)) - (let ([cb (lsp-take-pending! id)]) - (when cb (lsp-queue-ui-action! (lambda () (cb msg)))))] - [(and method (not id)) - (lsp-handle-server-notification! - method - (hash-get msg "params"))] - [(and id method) - (lsp-handle-server-request! - id - method - (hash-get msg "params"))] - [else (void)])) - (loop))))) + (def (lsp-poll-one-message! port) + "Poll for one LSP message from port (non-blocking). Called from UI thread\n via schedule-periodic!. Reads and dispatches at most one message per tick.\n Returns #t if a message was processed, #f otherwise." + (if (not (and port (not (port-closed? port)))) + #f + (if (not (char-ready? port)) + #f + (let ([msg (with-catch + (lambda (e) #f) + (lambda () (lsp-read-message port)))]) + (if (not (and msg (hash-table? msg))) + #f + (begin + (let ([id (hash-get msg "id")] + [method (hash-get msg "method")] + [result (hash-get msg "result")] + [error (hash-get msg "error")]) + (cond + [(and id (not method)) + (let ([cb (lsp-take-pending! id)]) + (when cb (cb msg)))] + [(and method (not id)) + (lsp-handle-server-notification! + method + (hash-get msg "params"))] + [(and id method) + (lsp-handle-server-request! + id + method + (hash-get msg "params"))] + [else (void)])) + #t)))))) + (def (lsp-drain-messages! port) + "Drain all available LSP messages from port (non-blocking). Called from\n schedule-periodic! on the UI thread. Processes messages until none are ready." + (let loop () (when (lsp-poll-one-message! port) (loop)))) (def (lsp-handle-server-notification! method params) - "Handle a notification from the server (dispatched on reader thread,\n but queues UI actions for actual processing)." + "Handle a notification from the server. Now runs directly on UI thread\n via schedule-periodic! polling — no need for lsp-queue-ui-action!." (cond [(string=? method "textDocument/publishDiagnostics") - (lsp-queue-ui-action! - (lambda () (lsp-store-diagnostics! params)))] + (lsp-store-diagnostics! params)] [(string=? method "window/logMessage") (void)] [(string=? method "window/showMessage") - (lsp-queue-ui-action! - (lambda () (lsp-store-show-message! params)))] + (lsp-store-show-message! params)] [else (void)])) (def (lsp-handle-server-request! id method params) "Handle a request from the server — respond immediately." @@ -255,14 +246,14 @@ (begin (set! *lsp-initializing* #f) #f) (begin (set! *lsp-process* proc) - (set! *lsp-reader-thread* - (thread-start! - (make-thread - (lambda () - (with-catch - (lambda (e) (void)) - (lambda () (lsp-reader-loop! proc)))) - 'lsp-reader))) + (schedule-periodic! + 'lsp-reader + 50 + (lambda () + (when *lsp-process* + (with-catch + (lambda (e) (void)) + (lambda () (lsp-drain-messages! *lsp-process*)))))) (lsp-send-initialize! workspace-root) #t)))) (def (lsp-stop!) @@ -284,8 +275,7 @@ void (lambda () (when *lsp-process* (process-status *lsp-process*))))) - (set! *lsp-process* #f) (set! *lsp-reader-thread* #f) - (set! *lsp-request-id* 0) + (set! *lsp-process* #f) (set! *lsp-request-id* 0) (set! *lsp-pending-requests* (make-hash-table)) (set! *lsp-initialized* #f) (set! *lsp-initializing* #f) (set! *lsp-server-capabilities* (make-hash-table)) --- a/lib/jerboa-emacs/qt/magit.sls +++ b/lib/jerboa-emacs/qt/magit.sls @@ -49,22 +49,19 @@ (close-port proc) (or out "")))))) (def (magit-run-git/async args dir callback) - "Run git in background thread, deliver output string to callback on UI thread." - (spawn/name - 'async-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))))))) + "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))) (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/qt/commands-config2.ss +++ b/src/jerboa-emacs/qt/commands-config2.ss @@ -205,22 +205,18 @@ " marked files? (yes/no): ")))) (when (and confirm (string=? confirm "yes")) (echo-message! (app-state-echo app) "Deleting...") - (spawn/name 'dired-delete - (lambda () - (let ((count 0)) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (delete-file path) - (set! count (+ count 1))))) - files) - (ui-queue-push! + (let ((count 0)) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! (app-state-echo app) - (string-append "Deleted " (number->string count) " files")))))))))))) + (delete-file path) + (set! count (+ count 1))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! (app-state-echo app) + (string-append "Deleted " (number->string count) " files")))))))) (def (cmd-dired-do-copy-marked app) "Copy all marked files in dired to a destination directory (async)." @@ -233,24 +229,20 @@ (when (and dest (> (string-length dest) 0)) (let ((dest-dir (path-expand dest))) (echo-message! (app-state-echo app) "Copying...") - (spawn/name 'dired-copy - (lambda () - (let ((count 0)) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((target (path-expand (path-strip-directory path) dest-dir))) - (copy-file path target) - (set! count (+ count 1)))))) - files) - (ui-queue-push! + (let ((count 0)) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! (app-state-echo app) - (string-append "Copied " (number->string count) - " files to " dest-dir))))))))))))) + (let ((target (path-expand (path-strip-directory path) dest-dir))) + (copy-file path target) + (set! count (+ count 1)))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! (app-state-echo app) + (string-append "Copied " (number->string count) + " files to " dest-dir))))))))) (def (cmd-dired-do-rename-marked app) "Move/rename all marked files in dired to a destination directory (async)." @@ -263,24 +255,20 @@ (when (and dest (> (string-length dest) 0)) (let ((dest-dir (path-expand dest))) (echo-message! (app-state-echo app) "Moving...") - (spawn/name 'dired-rename - (lambda () - (let ((count 0)) - (for-each - (lambda (path) - (with-catch - (lambda (e) #f) - (lambda () - (let ((target (path-expand (path-strip-directory path) dest-dir))) - (rename-file path target) - (set! count (+ count 1)))))) - files) - (ui-queue-push! + (let ((count 0)) + (for-each + (lambda (path) + (with-catch + (lambda (e) #f) (lambda () - (when dir (dired-open-directory! app dir)) - (echo-message! (app-state-echo app) - (string-append "Moved " (number->string count) - " files to " dest-dir))))))))))))) + (let ((target (path-expand (path-strip-directory path) dest-dir))) + (rename-file path target) + (set! count (+ count 1)))))) + files) + (when dir (dired-open-directory! app dir)) + (echo-message! (app-state-echo app) + (string-append "Moved " (number->string count) + " files to " dest-dir))))))))) (def (cmd-dired-mark-by-regexp app) "Mark files matching a regular expression in dired." @@ -998,54 +986,50 @@ (pattern (qt-echo-read-string app "Project search: "))) (when (and pattern (> (string-length pattern) 0)) (echo-message! echo "Searching...") - (spawn/name 'project-search - (lambda () - (let ((output - (with-catch - (lambda (e) []) - (lambda () - (let* ((proc (open-process - [path: "/usr/bin/grep" - arguments: ["-rn" "--include=*.ss" "--include=*.scm" - "--include=*.el" "--include=*.py" - "--include=*.js" "--include=*.ts" - "--include=*.c" "--include=*.h" - "--include=*.rs" "--include=*.go" - "--include=*.java" "--include=*.rb" - "--include=*.md" "--include=*.txt" - "--include=*.json" "--include=*.yaml" - "--include=*.yml" "--include=*.toml" - "--include=*.html" "--include=*.css" - pattern root] - stdout-redirection: #t - stderr-redirection: #t])) - (lines (let loop ((acc [])) - (let ((line (read-line proc))) - (if (eof-object? line) - (reverse acc) - (loop (cons line acc))))))) - (close-port proc) - lines))))) - (ui-queue-push! - (lambda () - (if (null? output) - (echo-message! echo (string-append "No matches for: " pattern)) - (let* ((fr (app-state-frame app)) - (ed (current-qt-editor app)) - (buf (or (buffer-by-name "*Project Search*") - (qt-buffer-create! "*Project Search*" ed))) - (result (string-join output "\n"))) - (qt-buffer-attach! ed buf) - (set! (qt-edit-window-buffer (qt-current-window fr)) buf) - (qt-plain-text-edit-set-text! ed - (string-append "=== Project search: " pattern " ===\n" - "=== Root: " root " ===\n\n" - result "\n\n" - (number->string (length output)) " match(es) found")) - (qt-plain-text-edit-set-read-only! ed #t) - (qt-modeline-update! app) - (echo-message! echo - (string-append (number->string (length output)) " match(es) found")))))))))))) + (let ((output + (with-catch + (lambda (e) []) + (lambda () + (let* ((proc (open-process + [path: "/usr/bin/grep" + arguments: ["-rn" "--include=*.ss" "--include=*.scm" + "--include=*.el" "--include=*.py" + "--include=*.js" "--include=*.ts" + "--include=*.c" "--include=*.h" + "--include=*.rs" "--include=*.go" + "--include=*.java" "--include=*.rb" + "--include=*.md" "--include=*.txt" + "--include=*.json" "--include=*.yaml" + "--include=*.yml" "--include=*.toml" + "--include=*.html" "--include=*.css" + pattern root] + stdout-redirection: #t + stderr-redirection: #t])) + (lines (let loop ((acc [])) + (let ((line (read-line proc))) + (if (eof-object? line) + (reverse acc) + (loop (cons line acc))))))) + (close-port proc) + lines))))) + (if (null? output) + (echo-message! echo (string-append "No matches for: " pattern)) + (let* ((fr (app-state-frame app)) + (ed (current-qt-editor app)) + (buf (or (buffer-by-name "*Project Search*") + (qt-buffer-create! "*Project Search*" ed))) + (result (string-join output "\n"))) + (qt-buffer-attach! ed buf) + (set! (qt-edit-window-buffer (qt-current-window fr)) buf) + (qt-plain-text-edit-set-text! ed + (string-append "=== Project search: " pattern " ===\n" + "=== Root: " root " ===\n\n" + result "\n\n" + (number->string (length output)) " match(es) found")) + (qt-plain-text-edit-set-read-only! ed #t) + (qt-modeline-update! app) + (echo-message! echo + (string-append (number->string (length output)) " match(es) found")))))))) ;;;============================================================================ ;;; Goto last change (navigate to last edit position) --- a/src/jerboa-emacs/qt/commands-ide.ss +++ b/src/jerboa-emacs/qt/commands-ide.ss @@ -480,13 +480,10 @@ Use M-x set-buffer-file-coding-system to change." (magit-run-git/async '("rev-parse" "--abbrev-ref" "HEAD") dir (lambda (output) (completion-post! branch-done output))) ;; Join in background thread, then deliver to UI - (spawn/name 'magit-status-join - (lambda () - (let ((status-output (completion-wait! status-done)) - (branch-output (completion-wait! branch-done))) - (ui-queue-push! - (lambda () - (magit-render-status! app status-output branch-output dir))))))))) + (magit-render-status! app + (completion-wait! status-done) + (completion-wait! branch-done) + dir)))) (def (cmd-magit-stage app) "Stage file or hunk at point." @@ -730,29 +727,25 @@ Use M-x set-buffer-file-coding-system to change." (lambda (out) (completion-post! unstaged-done out))) (magit-run-git/async (list "diff" "--cached" file) *magit-dir* (lambda (out) (completion-post! staged-done out))) - (spawn/name 'magit-diff-join - (lambda () - (let ((diff-output (completion-wait! unstaged-done)) - (staged-diff (completion-wait! staged-done))) - (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) ""))) - (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) - (set! (qt-edit-window-buffer (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 ((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) + (set! (qt-edit-window-buffer (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"))))))) (def (cmd-magit-stage-all app) "Stage all changes." --- a/src/jerboa-emacs/qt/commands-ide2.ss +++ b/src/jerboa-emacs/qt/commands-ide2.ss @@ -427,14 +427,12 @@ file-changes) ;; Write all files in background thread (when (pair? write-jobs) - (spawn/name 'wgrep-write - (lambda () - (for-each - (lambda (job) - (with-catch - (lambda (e) (gemacs-log! "wgrep write error: " (object->string e))) - (lambda () (write-string-to-file (car job) (cdr job))))) - write-jobs)))))) + (for-each + (lambda (job) + (with-catch + (lambda (e) (gemacs-log! "wgrep write error: " (object->string e))) + (lambda () (write-string-to-file (car job) (cdr job))))) + write-jobs)))) (set! *wgrep-mode* #f) (echo-message! (app-state-echo app) (string-append "Applied " (number->string changes) " change(s)")))))) --- a/src/jerboa-emacs/qt/highlight.ss +++ b/src/jerboa-emacs/qt/highlight.ss @@ -1129,16 +1129,13 @@ styles)) (def (qt-org-highlight-buffer-async! ed text) - "Async org highlighting: parse text in background, apply styles on UI thread." - (spawn/name 'org-highlight - (lambda () - (let ((collector (box []))) - (parameterize ((*org-style-collector* collector)) - (qt-org-highlight-buffer! #f text)) - (let ((styles (reverse (unbox collector)))) - (ui-queue-push! - (lambda () - (qt-org-apply-styles! ed styles)))))))) + "Org highlighting — runs synchronously to avoid GC deadlocks from + background Chez threads that can't respond to stop-the-world GC." + (let ((collector (box []))) + (parameterize ((*org-style-collector* collector)) + (qt-org-highlight-buffer! #f text)) + (let ((styles (reverse (unbox collector)))) + (qt-org-apply-styles! ed styles))))