From: Matt Birkholz Date: Sat, 27 Jun 2015 22:24:45 +0000 (-0700) Subject: Reimplement permanently-register-io-thread-event for SMPability. X-Git-Tag: mit-scheme-pucked-9.2.12~376^2~18 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d5381b09f98324e2e77f8581ed9872633af2ff21;p=mit-scheme.git Reimplement permanently-register-io-thread-event for SMPability. Remove permanent tentries (waiting thread entries) from io-registrations. Replace them with an event wrapper that loops, re-registering after the wrapped event finishes. The loop assumes IO is being consumed during the event. If not, it may spin forever. Remove the notion of registering for the "front" of the queue too. The X graphics device must take care to de-register its IO event before closing the display, else the thread system may apply test- select-registry to a closed descriptor. --- diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 13d2eed7d..a329ba2a6 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -427,7 +427,7 @@ USA. (set-thread/block-events?! thread #t) (ring/discard-all (thread/pending-events thread)) (translate-to-state-point (thread/root-state-point thread)) - (%deregister-io-thread-events thread #t) + (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (%disassociate-joined-threads thread) (%disassociate-thread-mutexes thread) @@ -487,7 +487,7 @@ USA. (del-assq! thread (thread/joined-threads (car threads))))) (set-thread/joined-to! thread '())) -;;;; I/O Thread Events +;;;; IO Thread Events (define io-registry) (define io-registrations) @@ -501,11 +501,10 @@ USA. next) (define-structure (tentry (conc-name tentry/) - (constructor make-tentry (thread event permanent?))) + (constructor make-tentry (thread event))) dentry thread event - (permanent? #f read-only #t) prev next) @@ -570,8 +569,7 @@ USA. thread (lambda (mode) (set! result mode) - unspecific) - #f #t)) + unspecific))) (set! registration-2 (%register-io-thread-event 'PROCESS-STATUS-CHANGE @@ -580,8 +578,7 @@ USA. (lambda (mode) mode (set! result 'PROCESS-STATUS-CHANGE) - unspecific) - #f #t))) + unspecific)))) (%maybe-toggle-thread-timer)) (lambda () (%suspend-current-thread) @@ -597,28 +594,52 @@ USA. (delete-tentry! tentry))) (define (permanently-register-io-thread-event descriptor mode thread event) - (register-io-thread-event-1 descriptor mode thread event - #t 'PERMANENTLY-REGISTER-IO-THREAD-EVENT)) + (let ((stop? #f) + (registration #f)) + (letrec ((handler + (named-lambda (permanent-io-event mode*) + (if (not stop?) + (event mode*)) + (if (not (or stop? (memq mode* '(ERROR HANGUP #F)))) + (register)))) + (register + (lambda () + (deregister) + (if (not stop?) + (set! registration + (register-io-thread-event descriptor mode + thread handler))))) + (deregister + (lambda () + (if registration + (begin + (deregister-io-thread-event registration) + (set! registration #f)))))) + (register) + (cons 'DEREGISTER-PERMANENT-IO-EVENT + (lambda () + (set! stop? #t) + (deregister)))))) (define (register-io-thread-event descriptor mode thread event) - (register-io-thread-event-1 descriptor mode thread event - #f 'REGISTER-IO-THREAD-EVENT)) - -(define (register-io-thread-event-1 descriptor mode thread event - permanent? caller) - (guarantee-select-mode mode caller) - (guarantee-thread thread caller) + (guarantee-select-mode mode 'REGISTER-IO-THREAD-EVENT) + (guarantee-thread thread 'REGISTER-IO-THREAD-EVENT) (without-interrupts (lambda () (let ((registration - (%register-io-thread-event descriptor mode thread event - permanent? #f))) + (%register-io-thread-event descriptor mode thread event))) (%maybe-toggle-thread-timer) registration)))) -(define (deregister-io-thread-event tentry) +(define (deregister-io-thread-event registration) + (if (and (pair? registration) + (eq? (car registration) 'DEREGISTER-PERMANENT-IO-EVENT)) + ((cdr registration)) + (deregister-io-thread-event* registration))) + +(define (deregister-io-thread-event* tentry) (if (not (tentry? tentry)) - (error:wrong-type-argument tentry "I/O thread event registration" + (error:wrong-type-argument tentry "IO thread event registration" 'DEREGISTER-IO-THREAD-EVENT)) (without-interrupts (lambda () @@ -675,9 +696,8 @@ USA. (dloop (dentry/next dentry))))) (%maybe-toggle-thread-timer)) -(define (%register-io-thread-event descriptor mode thread event permanent? - front?) - (let ((tentry (make-tentry thread event permanent?))) +(define (%register-io-thread-event descriptor mode thread event) + (let ((tentry (make-tentry thread event))) (let loop ((dentry io-registrations)) (cond ((not dentry) (let ((dentry @@ -698,17 +718,11 @@ USA. ((and (eqv? descriptor (dentry/descriptor dentry)) (eq? mode (dentry/mode dentry))) (set-tentry/dentry! tentry dentry) - (if front? - (let ((next (dentry/first-tentry dentry))) - (set-tentry/prev! tentry #f) - (set-tentry/next! tentry next) - (set-dentry/first-tentry! dentry tentry) - (set-tentry/prev! next tentry)) - (let ((prev (dentry/last-tentry dentry))) - (set-tentry/prev! tentry prev) - (set-tentry/next! tentry #f) - (set-dentry/last-tentry! dentry tentry) - (set-tentry/next! prev tentry)))) + (let ((prev (dentry/last-tentry dentry))) + (set-tentry/prev! tentry prev) + (set-tentry/next! tentry #f) + (set-dentry/last-tentry! dentry tentry) + (set-tentry/next! prev tentry))) (else (loop (dentry/next dentry))))) tentry)) @@ -717,7 +731,7 @@ USA. (if (tentry/dentry tentry) (delete-tentry! tentry))) -(define (%deregister-io-thread-events thread permanent?) +(define (%deregister-io-thread-events thread) (let loop ((dentry io-registrations) (tentries '())) (if (not dentry) (do ((tentries tentries (cdr tentries))) @@ -729,9 +743,7 @@ USA. (if (not tentry) tentries (loop (tentry/next tentry) - (if (and (eq? thread (tentry/thread tentry)) - (or permanent? - (not (tentry/permanent? tentry)))) + (if (eq? thread (tentry/thread tentry)) (cons tentry tentries) tentries)))))))) @@ -770,25 +782,12 @@ USA. (and e (lambda () (e mode))))) events))) - (if (tentry/permanent? tentry) - (move-tentry-to-back! tentry) - (delete-tentry! tentry)) + (delete-tentry! tentry) (loop (fix:+ i 1) events)))))) (do ((events events (cdr events))) ((not (pair? events))) (%signal-thread-event (caar events) (cdar events))))))) -(define (move-tentry-to-back! tentry) - (let ((next (tentry/next tentry))) - (if next - (let ((dentry (tentry/dentry tentry)) - (prev (tentry/prev tentry))) - (set-tentry/prev! tentry (dentry/last-tentry dentry)) - (set-tentry/next! tentry #f) - (set-dentry/last-tentry! dentry tentry) - (set-tentry/prev! next prev) - (if (not prev) (set-dentry/first-tentry! dentry next)))))) - (define (delete-tentry! tentry) (let ((dentry (tentry/dentry tentry)) (prev (tentry/prev tentry)) @@ -1022,7 +1021,7 @@ USA. (let ((block-events? (thread/block-events? thread))) (set-thread/block-events?! thread #t) (ring/discard-all (thread/pending-events thread)) - (%deregister-io-thread-events thread #f) + (%deregister-io-thread-events thread) (%discard-thread-timer-records thread) (set-thread/block-events?! thread block-events?)) (%maybe-toggle-thread-timer) diff --git a/src/runtime/x11graph.scm b/src/runtime/x11graph.scm index 8db486d6b..d47b5d005 100644 --- a/src/runtime/x11graph.scm +++ b/src/runtime/x11graph.scm @@ -232,6 +232,7 @@ USA. x-window/xw set-x-window/xw!) read-only #t) + (previewer-registration #f) (event-queue (make-queue)) (properties (make-1d-table) read-only #t)) @@ -257,7 +258,7 @@ USA. (error "Unable to open display:" name)) (let ((display (make-x-display name xd))) (add-to-gc-finalizer! display-finalizer display) - (make-event-previewer display) + (register-event-previewer! display) display))))) (define (x-graphics/close-display display) @@ -266,12 +267,17 @@ USA. (if (x-display/xd display) (begin (remove-all-from-gc-finalizer! (x-display/window-finalizer display)) + (let ((registration (x-display/previewer-registration display))) + (if registration + (begin + (deregister-io-thread-event registration) + (set-x-display/previewer-registration! display #f)))) (remove-from-gc-finalizer! display-finalizer display)))))) (define (x-graphics/open-display? display) (if (x-display/xd display) #t #f)) -(define (make-event-previewer display) +(define (register-event-previewer! display) (let ((registration)) (set! registration (permanently-register-io-thread-event @@ -301,7 +307,7 @@ USA. (if event (begin (process-event display event) (loop)))))))))))) - registration)) + (set-x-display/previewer-registration! display registration))) (define (read-event display) (letrec ((loop