From: Matt Birkholz Date: Sun, 5 Jul 2015 16:21:17 +0000 (-0700) Subject: Do NOT use permanently-register-io-thread-event in Edwin. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=be07e0c208d26d633d6f3e62fde6a4e23c5e950e;p=mit-scheme.git Do NOT use permanently-register-io-thread-event in Edwin. Edwin does not consume the IO in the thread event. This worked in a uni-processing world where another thread could consume the IO in round-robin fashion, but in an SMPing world there is no way to know when it is appropriate to signal another event. In a naive implementation (without special handling of these events), an idle processor would spin, queuing MANY "IO ready" events to one thread until another thread consumed the IO. Edwin's X11 and console display types now block for IO on multiple descriptors, the X or tty descriptor PLUS the subprocess output descriptors. They no longer use permanent IO thread events to handle the latter. Edwin's remaining uses of permanently-register-io-thread-event are in single-threaded OS2 and Win32 worlds. The runtime's only uses are in the OS2 and X11 graphics devices where the IO *is* consumed during the event. --- diff --git a/src/edwin/edwin.pkg b/src/edwin/edwin.pkg index b559d5633..cb38f658f 100644 --- a/src/edwin/edwin.pkg +++ b/src/edwin/edwin.pkg @@ -984,7 +984,10 @@ USA. (parent (edwin screen)) (export (edwin) resize-screen) + (import (edwin process) + register-process-output-events) (import (runtime primitive-io) + channel-descriptor-for-select %channel-read channel-type=terminal? have-select? @@ -1038,6 +1041,8 @@ USA. screen-xterm xterm-screen/set-icon-name xterm-screen/set-name) + (import (edwin process) + register-process-output-events) (initialization (initialize-package!))) (define-package (edwin x-keys) diff --git a/src/edwin/process.scm b/src/edwin/process.scm index 8c63693f9..9b8e5b39a 100644 --- a/src/edwin/process.scm +++ b/src/edwin/process.scm @@ -34,7 +34,6 @@ USA. (add-event-receiver! editor-initializations (lambda () (set! edwin-processes '()) - (set! process-input-queue (cons '() '())) (set-variable! exec-path (os/exec-path)) (set-variable! shell-file-name (os/shell-file-name)))) @@ -79,8 +78,7 @@ Initialized from the SHELL environment variable." (filter #f) (sentinel #f) (kill-without-query #f) - (notification-tick (cons #f #f)) - (input-registration #f)) + (notification-tick (cons #f #f))) (define-integrable (process-arguments process) (subprocess-arguments (process-subprocess process))) @@ -127,13 +125,6 @@ Initialized from the SHELL environment variable." (let ((buffer (process-buffer process))) (and buffer (mark-right-inserting-copy (buffer-end buffer)))))) - -(define (deregister-process-input process) - (let ((registration (process-input-registration process))) - (if registration - (begin - (set-process-input-registration! process #f) - (deregister-io-thread-event registration))))) (define (start-process name buffer environment program . arguments) (let ((make-subprocess @@ -161,9 +152,7 @@ Initialized from the SHELL environment variable." buffer))) (let ((channel (subprocess-input-channel subprocess))) (if channel - (begin - (channel-nonblocking channel) - (register-process-input process channel)))) + (channel-nonblocking channel))) (update-process-mark! process) (subprocess-put! subprocess 'EDWIN-PROCESS process) (set! edwin-processes (cons process edwin-processes)) @@ -185,7 +174,6 @@ Initialized from the SHELL environment variable." (begin (subprocess-kill subprocess) (%perform-status-notification process 'SIGNALLED #f))) - (deregister-process-input process) (let ((buffer (process-buffer process))) (if (buffer-alive? buffer) (buffer-modeline-event! buffer 'PROCESS-STATUS))) @@ -214,75 +202,49 @@ Initialized from the SHELL environment variable." ;;;; Input and Output -(define process-input-queue) - -(define (register-process-input process channel) - (set-process-input-registration! - process - (permanently-register-io-thread-event - (channel-descriptor-for-select channel) - 'READ - (current-thread) - (lambda (mode) - mode - (let ((queue process-input-queue)) - (if (not (memq process (car queue))) - (let ((tail (list process))) - (if (null? (cdr queue)) - (set-car! queue tail) - (set-cdr! (cdr queue) tail)) - (set-cdr! queue tail)))))))) - (define (process-output-available?) - (not (null? (car process-input-queue)))) - -(define (accept-process-output) - (let ((queue process-input-queue)) - (let loop ((output? #f)) - (if (null? (car queue)) - output? - (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (let ((process (caar queue))) - (set-car! queue (cdar queue)) - (if (null? (car queue)) - (set-cdr! queue '())) - (let ((output? - (if (poll-process-for-output process #t) #t output?))) - (set-interrupt-enables! interrupt-mask) - (loop output?)))))))) - -(define (poll-process-for-output process do-status?) - (and (let ((channel (subprocess-input-channel (process-subprocess process)))) - (and channel - (channel-open? channel))) - (let ((port (subprocess-input-port (process-subprocess process))) - (buffer (make-string 512)) - (output? #f)) - (let ((close-input - (lambda () - (deregister-process-input process) - (close-port port) - (if do-status? - (begin - (%update-global-notification-tick) - (if (poll-process-for-status-change process) - (set! output? #t))))))) - (let loop () - (let ((n + (let loop ((processes edwin-processes)) + (and (pair? processes) + (or (let ((port (subprocess-input-port + (process-subprocess (car processes))))) + (and port + (port/open? port) (call-with-current-continuation (lambda (k) - (bind-condition-handler (list condition-type:port-error) - (lambda (condition) condition (k 0)) + (bind-condition-handler + (list condition-type:port-error) + (lambda (condition) condition (k #f)) (lambda () - (input-port/read-string! port buffer))))))) - (if n - (if (fix:= n 0) - (close-input) - (begin - (if (output-substring process buffer n) - (set! output? #t)) - (loop))))))) - output?))) + (input-port/peek-char port))))))) + (loop (cdr processes)))))) + +(define (accept-process-output) + (let loop ((processes edwin-processes) + (output? #f)) + (if (pair? processes) + (loop (or (poll-process-for-output (car processes)) + output?) + (cdr processes)) + output?))) + +(define input-buffer (make-string 512)) + +(define (poll-process-for-output process) + (let ((port (subprocess-input-port (process-subprocess process)))) + (and (port/open? port) + (let ((n + (call-with-current-continuation + (lambda (k) + (bind-condition-handler (list condition-type:port-error) + (lambda (condition) condition (k #t)) + (lambda () + (input-port/read-string! port input-buffer))))))) + (if (or (not (fixnum? n)) + (fix:= n 0)) + (close-port port) + (output-substring process input-buffer n)) + (and (fixnum? n) + (fix:> n 0)))))) (define (process-send-eof process) (process-send-char process #\EOT)) @@ -337,8 +299,24 @@ Initialized from the SHELL environment variable." status (process-exit-reason process))))) +(define (register-process-output-events thread event) + (append-map! + (lambda (process) + (let* ((subprocess (process-subprocess process)) + (channel (subprocess-output-channel subprocess))) + (if (channel-open? channel) + (list (register-io-thread-event + (channel-descriptor-for-select channel) 'READ + thread event)) + '()))) + edwin-processes)) + (define (perform-status-notification process status reason) - (poll-process-for-output process #f) + (if (or (eq? 'EXITED status) + (eq? 'SIGNALLED status)) + (let drain () + (if (poll-process-for-output process) + (drain)))) (let ((value (%perform-status-notification process status reason))) (if (and (or (eq? 'EXITED status) (eq? 'SIGNALLED status)) diff --git a/src/edwin/tterm.scm b/src/edwin/tterm.scm index 308cc7ff1..5bf4077a6 100644 --- a/src/edwin/tterm.scm +++ b/src/edwin/tterm.scm @@ -222,10 +222,7 @@ USA. (find (cdr key-pairs) possible-pending?)))))))))) (read-more? ; -> #F or #T if some octets were read - (named-lambda (read-more? block?) - (if block? - (channel-blocking channel) - (channel-nonblocking channel)) + (named-lambda (read-more?) (let ((n (%channel-read channel buffer end input-buffer-size))) (cond ((not n) #F) ((eq? n #T) #F) @@ -239,35 +236,28 @@ USA. (named-lambda (match-event block?) (let loop () (or (begin - (read-more? #f) + (read-more?) (match-key)) - ;; Atomically poll async event sources and block. - (let ((mask (set-interrupt-enables! interrupt-mask/gc-ok))) + ;; Poll event sources and block. + (begin (cond (inferior-thread-changes? - (set-interrupt-enables! mask) (or (->update-event (accept-thread-output)) (loop))) ((process-output-available?) - (set-interrupt-enables! mask) (or (->update-event (accept-process-output)) (loop))) ((process-status-changes?) - (set-interrupt-enables! mask) (or (->update-event (handle-process-status-changes)) (loop))) ((not have-select?) - (set-interrupt-enables! mask) (and block? (loop))) (incomplete-pending ;; Must busy-wait. - (set-interrupt-enables! mask) (loop)) (block? - (read-more? #t) - (set-interrupt-enables! mask) + (block-for-event) (loop)) (else - (set-interrupt-enables! mask) #f))))))) (->update-event (named-lambda (->update-event redisplay?) @@ -309,11 +299,41 @@ USA. match) ((pair? match) (cdr match)) - (else (error "Bogus input match:" match)))))) + (else (error "Bogus input match:" match))))) + (block-for-event + (named-lambda (block-for-event) + (let ((input-available? #f) + (output-available? #f) + (registrations)) + (dynamic-wind + (lambda () + (let ((thread (current-thread))) + (set! registrations + (cons + (register-io-thread-event + (channel-descriptor-for-select channel) 'READ + thread (lambda (mode) + mode + (set! input-available? #t))) + (register-process-output-events + thread (lambda (mode) + mode + (set! output-available? #t))))))) + (lambda () + (with-thread-events-blocked + (lambda () + (if (and (not input-available?) + (not output-available?) + (not (process-status-changes?)) + (not inferior-thread-changes?)) + (suspend-current-thread)))) + unspecific) + (lambda () + (for-each deregister-io-thread-event registrations))))))) (values (named-lambda (halt-update?) (or (fix:< start end) - (read-more? #f))) + (read-more?))) (named-lambda (peek-no-hang) (let ((event (->event (match-event #f)))) (if (input-event? event) @@ -376,6 +396,7 @@ USA. (lambda (get-outside-state) (terminal-operation terminal-raw-input (port/input-channel console-i/o-port)) + (channel-nonblocking (port/input-channel console-i/o-port)) (terminal-operation terminal-raw-output (port/output-channel console-i/o-port)) (tty-set-interrupt-enables 2) diff --git a/src/edwin/xterm.scm b/src/edwin/xterm.scm index e4930b1c8..cc7b474f8 100644 --- a/src/edwin/xterm.scm +++ b/src/edwin/xterm.scm @@ -496,24 +496,23 @@ USA. (guarantee-result))))))))))) (define (read-event queue display block?) + (preview-events display queue) + (let ((event + (if (queue-empty? queue) + (if (eq? 'IN-UPDATE block?) + #f + (read-event-1 display block?)) + (dequeue!/unsafe queue)))) + (if (and event trace-port) + (write-line event trace-port)) + event)) + +(define (preview-events display queue) (let loop () - (set! reading-event? #t) - (let ((event - (if (queue-empty? queue) - (if (eq? 'IN-UPDATE block?) - (x-display-process-events display 2) - (read-event-1 display block?)) - (dequeue!/unsafe queue)))) - (set! reading-event? #f) - (if (and (vector? event) - (fix:= (vector-ref event 0) event-type:expose)) - (begin - (process-expose-event event) - (loop)) - (begin - (if (and event trace-port) - (write-line event trace-port)) - event))))) + (let ((event (x-display-process-events display 2))) + (if event + (begin (preview-event event queue) + (loop)))))) (define trace-port #f) @@ -542,60 +541,78 @@ USA. (vector-ref event 5)))) (define (read-event-1 display block?) - (or (x-display-process-events display 2) + ;; Now consider other (non-X) events. + (if (eq? '#T block?) (let loop () - (let ((interrupt-mask (set-interrupt-enables! interrupt-mask/gc-ok))) - (cond (inferior-thread-changes? - (set-interrupt-enables! interrupt-mask) - event:inferior-thread-output) - ((process-output-available?) - (set-interrupt-enables! interrupt-mask) - event:process-output) - ((process-status-changes?) - (set-interrupt-enables! interrupt-mask) - event:process-status) - (else - (let ((flag - (test-for-io-on-descriptor - (x-display-descriptor display) - block? - 'READ))) - (set-interrupt-enables! interrupt-mask) - (case flag - ((#F) #f) - ((PROCESS-STATUS-CHANGE) event:process-status) - ((INTERRUPT) (loop)) - (else (read-event-1 display block?)))))))))) - -(define (preview-event-stream) - (set! previewer-registration - (permanently-register-io-thread-event - (x-display-descriptor x-display-data) - 'READ - (current-thread) - (lambda (mode) - mode - (if (not reading-event?) - (let loop () - (let ((event (x-display-process-events x-display-data 2))) - (if event - (begin (preview-event event) - (loop))))))))) - unspecific) + (let ((event (block-for-event display))) + (or event + (loop)))) + (cond (inferior-thread-changes? + event:inferior-thread-output) + ((process-output-available?) + event:process-output) + ((process-status-changes?) + event:process-status) + (else #f)))) + +(define (block-for-event display) + (let ((x-events-available? #f) + (output-available? #f) + (registrations)) + (dynamic-wind + (lambda () + (let ((thread (current-thread))) + (set! registrations + (cons + (register-io-thread-event + (x-display-descriptor display) 'READ + thread (lambda (mode) + mode + (set! x-events-available? #t))) + (register-process-output-events + thread (lambda (mode) + mode + (set! output-available? #t))))))) + (lambda () + (let loop () + (with-thread-events-blocked + (lambda () + (if (and (not x-events-available?) + (not output-available?) + (not (process-status-changes?)) + (not inferior-thread-changes?)) + (suspend-current-thread)))) + (cond (x-events-available? + (let ((queue x-display-events)) + (preview-events display queue) + (if (queue-empty? queue) + #f + (dequeue!/unsafe queue)))) + ((process-status-changes?) + event:process-status) + (output-available? + event:process-output) + (inferior-thread-changes? + event:inferior-thread-output) + (else + (loop))))) + (lambda () + (for-each deregister-io-thread-event registrations) + (set! registrations))))) (define (wait-for-event interval predicate process-event) (let ((timeout (+ (real-time-clock) interval))) - (fluid-let ((reading-event? #t)) - (let loop () - (let ((event (x-display-process-events x-display-data 2))) - (if event - (if (and (vector? event) (predicate event)) - (or (process-event event) (loop)) - (begin (preview-event event) (loop))) - (and (< (real-time-clock) timeout) - (loop)))))))) - -(define (preview-event event) + (let loop () + (let ((event (x-display-process-events x-display-data 2))) + (if event + (if (and (vector? event) (predicate event)) + (or (process-event event) (loop)) + (begin (preview-event event x-display-events) (loop))) + ;; Busy loop! + (and (< (real-time-clock) timeout) + (loop))))))) + +(define (preview-event event queue) (cond ((and signal-interrupts? (vector? event) (fix:= event-type:key-press (vector-ref event 0)) @@ -605,7 +622,7 @@ USA. (merge-bucky-bits (string-ref string 0) (vector-ref event 3))) (string-find-next-char string #\BEL)))) - (clean-event-queue x-display-events) + (clean-event-queue queue) (signal-interrupt!)) ((and (vector? event) (fix:= event-type:expose (vector-ref event 0))) @@ -616,9 +633,9 @@ USA. (fix:= event-type:visibility (vector-ref event 0)))) (let ((result (process-special-event event))) (if result - (enqueue!/unsafe x-display-events result)))) + (enqueue!/unsafe queue result)))) (else - (enqueue!/unsafe x-display-events event)))) + (enqueue!/unsafe queue event)))) (define (clean-event-queue queue) ;; Flush keyboard and mouse events from the input queue. Other @@ -640,8 +657,8 @@ USA. (enqueue!/unsafe queue (car events)))) (define (process-change-event event) - (cond ((fix:= event event:process-output) (accept-process-output)) - ((fix:= event event:process-status) (handle-process-status-changes)) + (cond ((fix:= event event:process-status) (handle-process-status-changes)) + ((fix:= event event:process-output) (accept-process-output)) ((fix:= event event:inferior-thread-output) (accept-thread-output)) (else (error "Illegal change event:" event)))) @@ -1312,23 +1329,15 @@ Otherwise, it is copied from the primary selection." ;;;; Interrupts -(define reading-event?) (define signal-interrupts?) (define last-focus-time) -(define previewer-registration) (define ignore-button-state) (define (with-editor-interrupts-from-x receiver) - (fluid-let ((reading-event? #f) - (signal-interrupts? #t) + (fluid-let ((signal-interrupts? #t) (last-focus-time #f) - (previewer-registration) (ignore-button-state #f)) - (dynamic-wind - preview-event-stream - (lambda () (receiver (lambda (thunk) (thunk)) '())) - (lambda () - (deregister-io-thread-event previewer-registration))))) + (receiver (lambda (thunk) (thunk)) '()))) (define (with-x-interrupts-enabled thunk) (with-signal-interrupts #t thunk))