From: Matt Birkholz Date: Fri, 19 Dec 2014 21:50:27 +0000 (-0700) Subject: smp: Punt "permanent" i/o thread events. X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=8bbf2faab72df7a0653da5bc999266f0a0cb5171;p=mit-scheme.git smp: Punt "permanent" i/o thread events. A "permanent" input channel in the system select registry will cause the io-waiter to spin until a thread reads the available input. Always removing an entry after its event is delivered allows the io-waiter to block until the thread processes the event, reads the available input, and blocks again. --- diff --git a/src/runtime/thread.scm b/src/runtime/thread.scm index 89e0ee9b7..aec8de6a0 100644 --- a/src/runtime/thread.scm +++ b/src/runtime/thread.scm @@ -489,7 +489,7 @@ USA. (dynamic-unwind thread) (%lock) (ring/discard-all (thread/pending-events 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) @@ -582,13 +582,12 @@ USA. next) (define-structure (tentry (conc-name tentry/) - (constructor make-tentry (thread event permanent?))) - dentry - thread - event - (permanent? #f read-only #t) - prev - next) + (constructor make-tentry (thread event))) + (dentry #f) + (thread () read-only #t) + (event () read-only #t) + (prev #f) + (next #f)) (define (reset-threads!) (reset-threads-low!) @@ -669,68 +668,71 @@ USA. (define (block-on-io-descriptor descriptor mode) (let ((result 'INTERRUPT) - (registration-1) - (registration-2)) - (dynamic-wind - (lambda () - (with-threads-locked - (lambda () - (let ((thread (%current-thread (%id)))) - (set! registration-1 - (%register-io-thread-event - descriptor - mode - thread - (lambda (mode) - (set! result mode) - unspecific) - #f #t)) - (set! registration-2 - (%register-io-thread-event - 'PROCESS-STATUS-CHANGE - 'READ - thread - (lambda (mode) - mode - (set! result 'PROCESS-STATUS-CHANGE) - unspecific) - #f #t))) - (%maybe-toggle-thread-timer)))) - (lambda () - (%suspend-current-thread) - result) - (lambda () - (with-threads-locked - (lambda () - (%maybe-deregister-io-thread-event registration-2) - (%maybe-deregister-io-thread-event registration-1) - (%maybe-toggle-thread-timer))))))) + (thread (current-thread))) + (let ((registration-1 (make-tentry + thread + (lambda (mode) + (set! result mode) + unspecific))) + (registration-2 (make-tentry + thread + (lambda (mode) + (declare (ignore mode)) + (set! result 'PROCESS-STATUS-CHANGE) + unspecific)))) + (dynamic-wind + (lambda () + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode registration-1 #t) + (%register-io-thread-event 'PROCESS-STATUS-CHANGE 'READ + registration-2 #t) + (%maybe-toggle-thread-timer)))) + (lambda () + (%suspend-current-thread) + result) + (lambda () + (with-threads-locked + (lambda () + (%maybe-deregister-io-thread-event registration-2) + (%maybe-deregister-io-thread-event registration-1) + (%maybe-toggle-thread-timer)))))))) (define (%maybe-deregister-io-thread-event tentry) ;; Ensure that another thread does not unwind our registration. (assert-locked '%maybe-deregister-io-thread-event) - (if (eq? (%current-thread (%id)) (tentry/thread tentry)) + (if (and (tentry/dentry tentry) + (eq? (%current-thread (%id)) (tentry/thread tentry))) (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)) + (guarantee-select-mode mode 'permanently-register-io-thread-event) + (guarantee-thread thread 'permanently-register-io-thread-event) + (let ((registration)) + (set! registration + (make-tentry thread + (lambda (mode*) + (event mode*) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode + registration #f) + (%maybe-toggle-thread-timer)))))) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode registration #f) + (%maybe-toggle-thread-timer))) + registration)) (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) - (with-threads-locked - (lambda () - (let ((registration - (%register-io-thread-event descriptor mode thread event - permanent? #f))) - (%maybe-toggle-thread-timer) - registration)))) + (guarantee-select-mode mode 'register-io-thread-event) + (guarantee-thread thread 'register-io-thread-event) + (let ((registration (make-tentry thread event))) + (with-threads-locked + (lambda () + (%register-io-thread-event descriptor mode registration #f) + (%maybe-toggle-thread-timer))) + registration)) (define (deregister-io-thread-event tentry) (if (not (tentry? tentry)) @@ -793,51 +795,48 @@ USA. (%maybe-toggle-thread-timer) (%unlock)) -(define (%register-io-thread-event descriptor mode thread event permanent? - front?) +(define (%register-io-thread-event descriptor mode tentry front?) (assert-locked '%register-io-thread-event) - (let ((tentry (make-tentry thread event permanent?))) - (let loop ((dentry io-registrations)) - (cond ((not dentry) - (let ((dentry - (make-dentry descriptor - mode - tentry - tentry - #f - io-registrations))) - (set-tentry/dentry! tentry dentry) - (set-tentry/prev! tentry #f) - (set-tentry/next! tentry #f) - (if io-registrations - (set-dentry/prev! io-registrations dentry)) - (set! io-registrations dentry) - (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor)) - (add-to-select-registry! io-registry descriptor mode)))) - ((and (eqv? descriptor (dentry/descriptor dentry)) - (eq? mode (dentry/mode dentry))) + (let loop ((dentry io-registrations)) + (cond ((not dentry) + (let ((dentry + (make-dentry descriptor + mode + tentry + tentry + #f + io-registrations))) (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)))) - (else - (loop (dentry/next dentry))))) - tentry)) + (set-tentry/prev! tentry #f) + (set-tentry/next! tentry #f) + (if io-registrations + (set-dentry/prev! io-registrations dentry)) + (set! io-registrations dentry) + (if (not (eq? 'PROCESS-STATUS-CHANGE descriptor)) + (add-to-select-registry! io-registry descriptor mode)))) + ((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)))) + (else + (loop (dentry/next dentry)))))) (define (%deregister-io-thread-event tentry) (assert-locked '%deregister-io-thread-event) (if (tentry/dentry tentry) (delete-tentry! tentry))) -(define (%deregister-io-thread-events thread permanent?) +(define (%deregister-io-thread-events thread) (assert-locked '%deregister-io-thread-events) (let loop ((dentry io-registrations) (tentries '())) (if (not dentry) @@ -850,9 +849,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)))))))) @@ -892,34 +889,18 @@ 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) - (assert-locked 'move-tentry-to-back!) - (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) (assert-locked 'delete-tentry!) (let ((dentry (tentry/dentry tentry)) (prev (tentry/prev tentry)) (next (tentry/next tentry))) (set-tentry/dentry! tentry #f) - (set-tentry/thread! tentry #f) - (set-tentry/event! tentry #f) (set-tentry/prev! tentry #f) (set-tentry/next! tentry #f) (if prev @@ -1173,7 +1154,7 @@ USA. (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))))