build: remove tracked generated .sls files and ignore them
ober
7c4acc018f0e935265cd47add655b4c28d15e3d4
--- a/.gitignore +++ b/.gitignore @@ -45,3 +45,4 @@ qt_chez_shim.so /vendor/ vendor/**/*.so vendor/**/*.wpo +**/*.sls deleted file mode 100644 --- a/lib/jerboa-emacs/async.sls +++ /dev/null @@ -1,768 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-emacs/async.ss - -(library (jerboa-emacs async) - (export ui-queue-push! ui-queue-drain! spawn-worker - pin-thread-to-processor0! async-process! - async-process-stream! trusted-executable async-read-file! - async-write-file! async-eval! engine-eval-start! - engine-eval-cancel! *engine-eval-active* - register-for-cleanup! drain-guardians! parallel-map - parallel-git! make-weak-cache weak-cache-ref weak-cache-set! - runtime-statistics runtime-gc-info with-abortable-command - abort-current-command! with-time-limit parallel-for-each - make-pipeline pipeline-push! pipeline-close! - pipeline-results make-file-line-generator fan-out-gather - async-future future-get schedule-periodic! cancel-periodic! - master-timer-tick! current-time-ms string-split-newlines - *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 - mutex? mutex-name) - (std misc channel) (std misc completion) - (only (std srfi srfi-19) current-time time->seconds) - (jerboa-emacs atom) (std sugar) (std srfi srfi-13) - (jerboa-emacs core) - (only (jerboa repl-socket) repl-capture-command - repl-capture-argv 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 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 - (lambda (e) - (jemacs-log! - "Worker " - (symbol->string name) - " error: " - (format "~a" e))) - thunk)) - name)]) - (thread-start! t) - t)) - (def *ui-queue* (make-channel 4096)) - (def (ui-queue-push! thunk) - "Push a UI action from any thread. Non-blocking (buffered channel)." - (channel-try-put *ui-queue* thunk)) - (def (ui-queue-drain!) - "Drain all pending UI actions. Called from the master timer on the UI thread.\n Processes up to 64 actions per tick to avoid starving the event loop." - (let loop ([n 0]) - (when (< n 64) - (let-values ([(action found) (channel-try-get *ui-queue*)]) - (when found - (with-catch - (lambda (e) - (verbose-log! - "UI-QUEUE-ERROR: " - (with-output-to-string - (lambda () (display-exception e))))) - action) - (loop (+ n 1))))))) - (def *scheduled-tasks* '()) - (def (current-time-ms) - "Current wall-clock time in milliseconds." - (inexact->exact - (floor (* (time->seconds (current-time)) 1000)))) - (def (schedule-periodic! name interval-ms thunk) - "Register a periodic task to run at the given interval.\n Tasks are run by master-timer-tick! on the UI thread." - (set! *scheduled-tasks* - (filter - (lambda (t) (not (eq? (car t) name))) - *scheduled-tasks*)) - (set! *scheduled-tasks* - (cons (list name interval-ms 0 thunk) *scheduled-tasks*))) - (def (cancel-periodic! name) - "Remove a periodic task by name." - (set! *scheduled-tasks* - (filter - (lambda (t) (not (eq? (car t) name))) - *scheduled-tasks*))) - (def (master-timer-tick!) - "Master timer callback: drain the UI queue, run periodic tasks, cleanup GC'd resources.\n Should be called from a single Qt timer at ~16-50ms interval." - (ui-queue-drain!) (drain-guardians!) - (let ([now (current-time-ms)]) - (set! *scheduled-tasks* - (map (lambda (task) - (let ([name (car task)] - [interval (cadr task)] - [last (caddr task)] - [thunk (cadddr task)]) - (if (>= (- now last) interval) - (begin - (verbose-log! - "TICK " - (symbol->string name) - " begin") - (with-catch - (lambda (e) - (verbose-log! - "TIMER-ERROR in " - (symbol->string name) - ": " - (with-output-to-string - (lambda () (display-exception e))))) - thunk) - (verbose-log! - "TICK " - (symbol->string name) - " end") - (list name interval now thunk)) - task))) - *scheduled-tasks*)))) - (def (trusted-executable name) - "Resolve NAME only in fixed system prefixes and reject writable executables." - (when (or (not (string? name)) - (= (string-length name) 0) - (string-contains name "/")) - (error 'trusted-executable "invalid executable name" name)) - (let loop ([dirs '("/usr/bin" - "/bin" - "/usr/local/bin" - "/opt/homebrew/bin" - "/opt/gerbil/bin")]) - (if (null? dirs) - (error 'trusted-executable - "required executable not found" - name) - (let ([candidate (string-append (car dirs) "/" name)]) - (if (with-catch - (lambda _ #f) - (lambda () - (let ([info (file-info candidate)]) - (and (eq? (file-info-type info) 'regular) - (= 0 - (bitwise-and - (file-info-mode info) - 18)))))) - candidate - (loop (cdr dirs))))))) - (def (async-process! argv callback: callback on-error: - (on-error #f) stdin-text: (stdin-text #f)) - "Run an absolute executable and argv vector in a background thread.\n No shell parsing or interpolation occurs. To expose an intentional shell\n command feature, pass (list \"/bin/sh\" \"-c\" user-command) explicitly.\n The callback runs on the primordial/UI thread (safe for Qt operations)." - (unless (and (pair? argv) - (let all-strings? ([rest argv]) - (or (null? rest) - (and (string? (car rest)) - (all-strings? (cdr rest)))))) - (error 'async-process! "expected non-empty argv list" argv)) - (spawn-worker - 'async-process - (lambda () - (with-catch - (lambda (e) - (ui-queue-push! - (lambda () - (if on-error - (on-error e) - (jemacs-log! - "async-process error: " - (format "~a" e)))))) - (lambda () - (let ([result (repl-capture-argv argv (or stdin-text ""))]) - (ui-queue-push! (lambda () (callback result))))))))) - (def (async-process-stream! argv on-line: on-line on-done: - (on-done #f) on-error: (on-error #f)) - "Run an argv subprocess in background, delivering each captured output line.\n Callbacks run on the primordial/UI thread (safe for Qt operations)." - (unless (and (pair? argv) - (let all-strings? ([rest argv]) - (or (null? rest) - (and (string? (car rest)) - (all-strings? (cdr rest)))))) - (error 'async-process-stream! - "expected non-empty argv list" - argv)) - (spawn-worker - 'async-process-stream - (lambda () - (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 ([output (repl-capture-argv argv)]) - (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 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 () (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 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 () (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." - (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) - (def (build-file-index root-dir) - "Walk directory tree and build a hash of basename -> full-path list." - (let ([index (make-hash-table)]) - (with-catch - (lambda (e) index) - (lambda () - (let walk ([dir root-dir]) - (for-each - (lambda (entry) - (let ([path (path-expand entry dir)]) - (with-catch - (lambda (e) #f) - (lambda () - (let ([info (file-info path)]) - (if (eq? 'directory (file-info-type info)) - (unless (string-prefix? "." entry) - (walk path)) - (let* ([name (path-strip-directory path)] - [existing (or (hash-get index name) - '())]) - (hash-put! - index - name - (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 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 (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)) - (def (file-index-lookup name) - "Look up a filename in the index. Returns list of full paths." - (or (hash-get (atom-deref *file-index*) name) '())) - (define *git-status-cache*--cell - (vector (atom (make-hash-table)))) - (def *git-watcher-dir* #f) - (def *git-watcher-callback* #f) - (def (parse-git-status-line line) - "Parse one line of git status --porcelain output into (status . file)." - (when (>= (string-length line) 4) - (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 Uses argv execution for GC-safe subprocess I/O." - (let* ([output (repl-capture-argv - (list "/usr/bin/git" "-C" dir "status" - "--porcelain" "-b"))] - [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*)) - (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) - (set! *git-watcher-callback* on-update) - (schedule-periodic! 'git-watcher 5000 git-watcher-tick!)) - (def (stop-git-watcher!) - "Stop the git status watcher." - (set! *git-watcher-dir* #f) - (set! *git-watcher-callback* #f)) - (def *flycheck-pending* '()) - (def *flycheck-lint-fn* #f) - (def *flycheck-result-fn* #f) - (def (flycheck-trigger! path) - "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 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*) - (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) - (set! *flycheck-running* #t) - (spawn-worker - 'flycheck - (lambda () - (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* '())) - (define *engine-eval-active*--cell (vector #f)) - (def *engine-eval-on-result* #f) - (def *engine-eval-on-error* #f) - (def *engine-eval-tick-count* 0) - (def *engine-ticks-per-slice* 50000) - (def (engine-eval-start! expr-string on-result on-error) - "Start time-sliced evaluation of EXPR-STRING using a Chez engine.\n The engine runs for *engine-ticks-per-slice* per master-timer tick,\n yielding back to the UI between slices. Eval never freezes the editor.\n ON-RESULT: (lambda (result-string) ...) called when eval completes.\n ON-ERROR: (lambda (error-string) ...) called on exception." - (engine-eval-cancel!) - (with-catch - (lambda (e) - (on-error - (with-output-to-string (lambda () (display-exception e))))) - (lambda () - (let* ([expr (with-input-from-string expr-string read)] - [eng (make-engine - (lambda () - (let* ([out (open-output-string)] - [err (open-output-string)] - [result (parameterize ([current-output-port - out] - [current-error-port - err]) - (eval expr))] - [stdout-text (get-output-string out)] - [result-str (with-output-to-string - (lambda () - (write result)))]) - (if (> (string-length stdout-text) 0) - (string-append - stdout-text - "\n=> " - result-str) - (string-append "=> " result-str)))))]) - (set! *engine-eval-active* eng) - (set! *engine-eval-on-result* on-result) - (set! *engine-eval-on-error* on-error) - (set! *engine-eval-tick-count* 0) - (schedule-periodic! 'engine-eval 16 engine-eval-tick!))))) - (def (engine-eval-tick!) - "One slice of engine execution. Called by master timer." - (when *engine-eval-active* - (set! *engine-eval-tick-count* - (+ *engine-eval-tick-count* 1)) - (with-catch - (lambda (e) - (let ([msg (with-output-to-string - (lambda () (display-exception e)))]) - (when *engine-eval-on-error* (*engine-eval-on-error* msg)) - (engine-eval-cancel!))) - (lambda () - (*engine-eval-active* - *engine-ticks-per-slice* - (lambda (ticks-left value) - (when *engine-eval-on-result* - (*engine-eval-on-result* value)) - (engine-eval-cancel!)) - (lambda (new-engine) - (set! *engine-eval-active* new-engine))))))) - (def (engine-eval-cancel!) "Cancel any running engine eval." - (set! *engine-eval-active* #f) - (set! *engine-eval-on-result* #f) - (set! *engine-eval-on-error* #f) - (set! *engine-eval-tick-count* 0) - (cancel-periodic! 'engine-eval)) - (def *resource-guardian* (make-guardian)) - (def *guardian-cleanups* (make-hash-table-eq)) - (def (register-for-cleanup! obj cleanup-thunk) - "Register OBJ for automatic cleanup when garbage collected.\n CLEANUP-THUNK is called with OBJ when GC collects it.\n Useful for PTY fds, subprocess ports, temp files, etc." - (hash-put! *guardian-cleanups* obj cleanup-thunk) - (*resource-guardian* obj)) - (def (drain-guardians!) - "Process any guardian-collected objects. Safe to call from UI thread.\n Called automatically by master-timer-tick!." - (let loop () - (let ([obj (*resource-guardian*)]) - (when obj - (let ([cleanup (hash-get *guardian-cleanups* obj)]) - (when cleanup - (with-catch - (lambda (e) - (verbose-log! - "Guardian cleanup error: " - (with-output-to-string - (lambda () (display-exception e))))) - (lambda () (cleanup obj))) - (hash-remove! *guardian-cleanups* obj))) - (loop))))) - (def (parallel-map fn items) - "Apply FN to each item in ITEMS using parallel worker threads.\n Returns results in the same order as ITEMS.\n Each FN call runs in its own SMP thread — true parallelism.\n Falls back to sequential map for 0-1 items." - (let ([n (length items)]) - (cond - [(= n 0) '()] - [(= n 1) (list (fn (car items)))] - [else - (let* ([results (make-vector n #f)] - [threads (let loop ([rest items] [i 0] [acc '()]) - (if (null? rest) - (reverse acc) - (let ([item (car rest)] [idx i]) - (loop - (cdr rest) - (+ i 1) - (cons - (let ([t (make-thread - (lambda () - (let ([result (with-catch - (lambda (e) - (cons - 'error - e)) - (lambda () - (fn item)))]) - (vector-set! - results - idx - result))) - (string->symbol - (string-append - "pmap-" - (number->string - idx))))]) - (thread-start! t) - t) - acc)))))]) - (for-each (lambda (t) (thread-join! t)) threads) - (let loop ([i 0] [acc '()]) - (if (>= i n) - (reverse acc) - (loop (+ i 1) (cons (vector-ref results i) acc)))))]))) - (def (parallel-git! dir commands callback) - "Run multiple git commands concurrently using SMP threads.\n COMMANDS is a list of (name . args-list) pairs.\n CALLBACK receives an alist of (name . output-string) results.\n Runs in background, results delivered via UI queue.\n\n Example: (parallel-git! dir\n '((status \"status\" \"--porcelain\")\n (branch \"branch\" \"--show-current\")\n (log \"log\" \"--oneline\" \"-5\"))\n (lambda (results) ...))\n\n This replaces sequential git-output calls (4x speedup on magit-status)." - (spawn-worker - 'parallel-git - (lambda () - (let* ([results (parallel-map - (lambda (cmd-pair) - (let* ([name (car cmd-pair)] - [args (cdr cmd-pair)]) - (cons - name - (with-catch - (lambda (e) "") - (lambda () - (repl-capture-argv - (append - (list "/usr/bin/git" "-C" dir) - args))))))) - commands)]) - (ui-queue-push! (lambda () (callback results))))))) - (def (make-weak-cache) - "Create a weak-key hashtable for caching.\n Entries are automatically removed when the key is GC'd." - (make-weak-eq-hashtable)) - (def *weak-cache-miss* (list 'weak-cache-miss)) - (def (weak-cache-ref cache key . default) - "Look up KEY in weak CACHE. Returns value or default (default: #f)." - (let ([v (hashtable-ref cache key *weak-cache-miss*)]) - (if (eq? v *weak-cache-miss*) - (if (null? default) #f (car default)) - v))) - (def (weak-cache-set! cache key value) - "Set KEY to VALUE in weak CACHE." - (hashtable-set! cache key value)) - (def (runtime-statistics) - "Return an alist of Chez Scheme runtime statistics.\n Includes: cpu-time, real-time, gc-count, gc-cpu-time, bytes-allocated,\n current-memory, max-memory, threads-active." - (let ([stats (statistics)]) - (list (cons 'cpu-time (sstats-cpu stats)) - (cons 'real-time (sstats-real stats)) - (cons 'gc-count (sstats-gc-count stats)) - (cons 'gc-cpu-time (sstats-gc-cpu stats)) - (cons 'gc-real-time (sstats-gc-real stats)) - (cons 'bytes-allocated (sstats-bytes stats)) - (cons 'current-memory (current-memory-bytes)) - (cons 'max-memory (maximum-memory-bytes))))) - (def (runtime-gc-info) - "Return a human-readable string of GC and memory statistics." - (let* ([stats (runtime-statistics)] - [mem-mb (/ (cdr (assoc 'current-memory stats)) 1048576.0)] - [max-mb (/ (cdr (assoc 'max-memory stats)) 1048576.0)] - [gc-count (cdr (assoc 'gc-count stats))] - [gc-time (cdr (assoc 'gc-cpu-time stats))] - [alloc (cdr (assoc 'bytes-allocated stats))]) - (string-append "Memory: " - (number->string (inexact->exact (round (* mem-mb 10)))) - "/10 MB" " (peak " - (number->string (inexact->exact (round (* max-mb 10)))) - "/10 MB)" " | GC: " (number->string gc-count) " collections" - ", " - (number->string - (inexact->exact (round (* (time-second gc-time) 1000)))) - " ms" " | Allocated: " - (number->string (quotient alloc 1048576)) " MB total"))) - (def *abort-continuation* #f) - (def (with-abortable-command thunk) - "Run THUNK as an abortable command. If abort-current-command! is called\n during execution, the command immediately exits via continuation." - (call/cc - (lambda (k) - (let ([old *abort-continuation*]) - (dynamic-wind - (lambda () (set! *abort-continuation* k)) - thunk - (lambda () (set! *abort-continuation* old))))))) - (def (abort-current-command!) - "Abort the currently running command by invoking its saved continuation.\n Safe to call from any context (timer, callback, signal handler)." - (when *abort-continuation* - (let ([k *abort-continuation*]) - (set! *abort-continuation* #f) - (k 'aborted)))) - (def (with-time-limit ticks thunk default) - "Run THUNK for at most TICKS engine ticks. If it finishes, return its value.\n If not, return DEFAULT. The thunk is truly preempted, not just signaled.\n This is impossible in Emacs Lisp which lacks preemptive scheduling." - (let ([eng (make-engine thunk)]) - (eng ticks - (lambda (remaining value) value) - (lambda (new-engine) default)))) - (def (parallel-for-each fn items) - "Apply FN to each item in ITEMS using parallel threads.\n Waits for all threads to complete but discards results.\n More efficient than parallel-map when you don't need return values." - (let ([n (length items)]) - (when (> n 0) - (let ([threads (let loop ([rest items] [i 0] [acc '()]) - (if (null? rest) - (reverse acc) - (let ([item (car rest)] [idx i]) - (loop - (cdr rest) - (+ i 1) - (cons - (let ([t (make-thread - (lambda () - (with-catch - (lambda (e) (void)) - (lambda () - (fn item)))) - (string->symbol - (string-append - "pfe-" - (number->string - idx))))]) - (thread-start! t) - t) - acc)))))]) - (for-each (lambda (t) (thread-join! t)) threads))))) - (def (make-pipeline (buf-size 256)) - "Create a pipeline: returns (values input-channel output-channel).\n Producer pushes to input-channel, consumer reads from output-channel.\n BUF-SIZE controls backpressure (default 256 items buffered)." - (let ([in-ch (make-channel buf-size)] - [out-ch (make-channel buf-size)]) - (values in-ch out-ch))) - (def (pipeline-push! channel item) - "Push an item into a pipeline channel. Blocks if buffer full (backpressure)." - (channel-put channel item)) - (def (pipeline-close! channel) - "Close a pipeline channel, signaling no more data." - (channel-close channel)) - (def (pipeline-results channel) - "Drain all results from a pipeline output channel into a list.\n Blocks until channel is closed by producer." - (let loop ([acc '()]) - (let ([val (channel-try-get channel)]) - (if val (loop (cons val acc)) (reverse acc))))) - (def (make-file-line-generator path) - "Create a generator that returns one line at a time from PATH.\n Returns #!eof when file is exhausted. O(1) memory usage.\n Usage: (def gen (make-file-line-generator \"/etc/hosts\"))\n (gen) => first line\n (gen) => second line\n ..." - (let ([port (open-input-file - (check-untainted-file-path path))] - [done #f]) - (lambda () - (if done - (eof-object) - (let ([line (get-line port)]) - (when (eof-object? line) (close-port port) (set! done #t)) - line))))) - (def (fan-out-gather fn items (max-workers 8)) - "Apply FN to each item using up to MAX-WORKERS parallel threads.\n Results are collected via a shared channel — order is NOT preserved\n (fastest-first). Returns list of results.\n Unlike parallel-map, this uses bounded parallelism (won't spawn 1000 threads)." - (let* ([n (length items)] - [actual-workers (min n max-workers)] - [result-ch (make-channel n)] - [work-ch (make-channel n)]) - (for-each (lambda (item) (channel-put work-ch item)) items) - (channel-close work-ch) - (let ([workers (let loop ([i 0] [acc '()]) - (if (>= i actual-workers) - acc - (loop - (+ i 1) - (cons - (let ([t (make-thread - (lambda () - (let work-loop () - (let ([item (channel-try-get - work-ch)]) - (when item - (let ([result (with-catch - (lambda (e) - (cons - 'error - e)) - (lambda () - (fn item)))]) - (channel-put - result-ch - result)) - (work-loop))))) - (string->symbol - (string-append - "fan-" - (number->string i))))]) - (thread-start! t) - t) - acc))))]) - (for-each (lambda (t) (thread-join! t)) workers) - (channel-close result-ch) - (let loop ([acc '()]) - (let ([val (channel-try-get result-ch)]) - (if val (loop (cons val acc)) (reverse acc))))))) - (def (async-future thunk) - "Run THUNK in a background thread, return a completion token.\n Use (future-get token) to block until result is ready.\n Usage: (let ((f (async-future (lambda () (expensive-computation)))))\n ... do other work ...\n (future-get f)) ;; blocks until done" - (let ([c (make-completion)]) - (spawn-worker - 'future - (lambda () - (let ([result (with-catch - (lambda (e) (cons 'future-error e)) - thunk)]) - (completion-post! c result)))) - c)) - (def (future-get completion) - "Block until a future's result is available, then return it.\n If the future raised an exception, returns (cons 'future-error exn)." - (completion-wait! completion)) - (define-syntax *engine-eval-active* - (identifier-syntax - [id (vector-ref *engine-eval-active*--cell 0)] - [(set! id val) (vector-set! - *engine-eval-active*--cell - 0 - val)])) - (define-syntax *file-index* - (identifier-syntax - [id (vector-ref *file-index*--cell 0)] - [(set! id val) (vector-set! *file-index*--cell 0 val)])) - (define-syntax *git-status-cache* - (identifier-syntax - [id (vector-ref *git-status-cache*--cell 0)] - [(set! id val) (vector-set! - *git-status-cache*--cell - 0 - val)]))) deleted file mode 100644 --- a/lib/jerboa-emacs/debug-repl.sls +++ /dev/null @@ -1,1152 +0,0 @@ -#!chezscheme -;;; Generated by jerbuild — DO NOT EDIT -;;; Source: src/jerboa-emacs/debug-repl.ss - -(library (jerboa-emacs debug-repl) - (export - start-debug-repl! - stop-debug-repl! - debug-repl-port - debug-repl-bind!) - (import - (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) (std misc process) - (only (jerboa reader) jerboa-read) - (only (std repl) value->type-string describe-value - repl-complete repl-doc repl-apropos) - (jerboa repl-socket) - (only (jerboa-emacs core) check-untainted-file-path) - (jerboa-emacs async) - (except (jerboa core) open-process open-input-process) - (jerboa runtime)) - (def *repl-listen-fd* #f) - (def *repl-client-fd* #f) - (def *repl-line-buf* "") - (def *repl-actual-port* #f) - (def *repl-token* #f) - (def *repl-authed* #f) - (def *repl-prompted* #f) - (def *repl-protocol* 'unknown) - (def *repl-unknown-ticks* 0) - (def *repl-connected-at-ms* 0) - (def *repl-last-activity-ms* 0) - (def debug-repl-max-input-bytes 65536) - (def debug-repl-auth-timeout-ms 5000) - (def debug-repl-idle-timeout-ms 60000) - (def debug-repl-total-timeout-ms 600000) - (def *repl-port-file* - (or (getenv "JEMACS_REPL_PORT_FILE" #f) - (string-append - (getenv "HOME" "/tmp") - "/.jerboa-repl-port"))) - (def *repl-env* (interaction-environment)) - (def (debug-repl-bind! name value) - "Register a binding in the debug REPL environment so it's accessible via IPC.\n Uses Chez's define-top-level-value to inject the value directly." - (define-top-level-value name value *repl-env*)) - (def (write-repl-port-file! port-num token) - (let* ([safe-repl-port-file (check-untainted-file-path - *repl-port-file*)] - [content (string-append "HOST=127.0.0.1\nPORT=" - (number->string port-num) "\nTOKEN=" token "\n")]) - (unless (repl-secure-replace-file - safe-repl-port-file - content) - (error 'debug-repl - "could not securely write endpoint file" - safe-repl-port-file)))) - (def (delete-repl-port-file!) - (when (file-exists? *repl-port-file*) - (with-catch - (lambda _ (void)) - (lambda () - (let ([safe-repl-port-file (check-untainted-file-path - *repl-port-file*)]) - (delete-file safe-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) - (set! *repl-protocol* 'unknown) - (set! *repl-unknown-ticks* 0) - (set! *repl-connected-at-ms* 0) - (set! *repl-last-activity-ms* 0)) - (def (valid-repl-token? token) - (and (string? token) - (>= (string-length token) 32) - (<= (string-length token) 256) - (let loop ([i 0]) - (or (= i (string-length token)) - (let ([n (char->integer (string-ref token i))]) - (and (>= n 33) (not (= n 127)) (loop (+ i 1)))))))) - (def (debug-read port) - "Read one bounded datum after the protocol's sharp-dot preflight." - (jerboa-read port)) - (def (reject-reader-eval! str) - "Preflight invalid #. syntax for a stable protocol error. Chez rejects it too." - (when (string-contains str "#.") - (error 'debug-repl - "invalid sharp-dot syntax is not accepted"))) - (def (debug-read-string str) - (reject-reader-eval! str) - (debug-read (open-input-string str))) - (def (capture-eval expr-str) - "Evaluate expression string, capturing stdout. Returns (list status result stdout).\n Handles expressions that return multiple values by formatting all of them.\n Returns a LIST (not values) to avoid multi-value issues with with-catch's call/cc." - (with-catch - (lambda (e) - (list - 'error - (with-catch - (lambda _ "unknown error") - (lambda () - (with-output-to-string - (lambda () - (display-condition e (current-output-port)))))) - "")) - (lambda () - (let* ([stdout-capture (open-output-string)] - [results (parameterize ([current-output-port - stdout-capture]) - (call-with-values - (lambda () - (eval - (debug-read-string expr-str) - *repl-env*)) - list))] - [stdout-str (get-output-string stdout-capture)]) - (list - 'ok - (if (= (length results) 1) - (format "~s" (car results)) - (let loop ([rs results] [acc ""]) - (if (null? rs) - acc - (loop - (cdr rs) - (string-append - acc - (if (string=? acc "") "" "\n") - (format "~s" (car rs))))))) - stdout-str))))) - (def (capture-eval-region str) - "Evaluate multiple forms, return last result.\n Returns a LIST (not values) to avoid multi-value issues with with-catch's call/cc." - (with-catch - (lambda (e) - (list - 'error - (with-catch - (lambda _ "unknown error") - (lambda () - (with-output-to-string - (lambda () - (display-condition e (current-output-port)))))) - "")) - (lambda () - (reject-reader-eval! str) - (let* ([stdout-capture (open-output-string)] - [p (open-input-string str)] - [results (parameterize ([current-output-port - stdout-capture]) - (let loop ([last (list (void))]) - (let ([form (debug-read p)]) - (if (eof-object? form) - last - (loop - (call-with-values - (lambda () (eval form *repl-env*)) - list))))))] - [stdout-str (get-output-string stdout-capture)]) - (list - 'ok - (if (= (length results) 1) - (format "~s" (car results)) - (let loop ([rs results] [acc ""]) - (if (null? rs) - acc - (loop - (cdr rs) - (string-append - acc - (if (string=? acc "") "" "\n") - (format "~s" (car rs))))))) - stdout-str))))) - (def (safe-format-value val) - "Format a value to string, safely handling errors." - (with-catch - (lambda _ "#<unprintable>") - (lambda () - (let ([out (open-output-string)]) - (write val out) - (get-output-string out))))) - (def (safe-pp-value val) - "Pretty-print a value to string." - (with-catch - (lambda _ (safe-format-value val)) - (lambda () - (with-output-to-string (lambda () (pretty-print val)))))) - (def (handle-sexpr-request req) - "Handle an s-expression protocol request.\n req: (id method . args)\n Returns: (id :ok result) or (id :error message)" - (with-catch - (lambda (e) - (let ([id (if (pair? req) (car req) 0)]) - (list - id - ':error - (with-catch - (lambda _ "unknown error") - (lambda () - (with-output-to-string - (lambda () - (display-condition e (current-output-port))))))))) - (lambda () - (let ([id (car req)] [method (cadr req)] [args (cddr req)]) - (case method - [(ping) (list id ':ok "pong")] - [(eval) - (let* ([res (capture-eval (car args))] - [status (car res)] - [result (cadr res)] - [stdout (caddr res)]) - (if (eq? status 'ok) - (list id ':ok (list ':value result ':stdout stdout))