From 8bbf2faab72df7a0653da5bc999266f0a0cb5171 Mon Sep 17 00:00:00 2001
From: Matt Birkholz <puck@birchwood-abbey.net>
Date: Fri, 19 Dec 2014 14:50:27 -0700
Subject: [PATCH] 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.
---
src/runtime/thread.scm | 219 +++++++++++++++++++----------------------
1 file changed, 100 insertions(+), 119 deletions(-)
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))))
--
2.25.1