scsh-conservatory
/
scsh-0.6
1
0
Fork 0
Code Issues Pull Requests Packages Projects Releases Wiki Activity

Revamped the SELECT implementation to properly distinguish between 

input and output port.  Also, SELECT and SELECT! are no longer
squashed into one silly procedure.
This commit is contained in:
sperber 2002-10-30 12:00:15 +00:00
parent a8ad3e0c71
commit d0977ea4d4
1 changed files with 205 additions and 153 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

152
scsh/newports.scm
View File

@ -733,16 +733,30 @@
;;; select ;;; select
;;; ----- ;;; -----
(define (port/fdes->port port/fd) (define (port/fdes->input-port port/fd)
(if (port? port/fd) (if (port? port/fd)
port/fd port/fd
(fdes->inport port/fd))) ; #### (fdes->inport port/fd)))
(define (port/fdes-ready? port/fd) (define (port/fdes->output-port port/fd)
(let ((port (port/fdes->port port/fd))) (if (port? port/fd)
port/fd
(fdes->outport port/fd)))
(define (input-port/fdes-ready? port/fd)
(let ((port (port/fdes->input-port port/fd)))
((port-handler-ready? (port-handler port)) port))) ((port-handler-ready? (port-handler port)) port)))
(define (any-ready port/fds) (define (output-port/fdes-ready? port/fd)
(let ((port (port/fdes->output-port port/fd)))
((port-handler-ready? (port-handler port)) port)))
(define (make-any-ready input?)
(let ((port/fdes-ready?
(if input?
input-port/fdes-ready?
output-port/fdes-ready?)))
(lambda (port/fds)
(let loop ((port/fds port/fds)) (let loop ((port/fds port/fds))
(if (null? port/fds) (if (null? port/fds)
'() '()
@ -757,40 +771,105 @@
(loop (cdr rest) (cons (car rest) ready))) (loop (cdr rest) (cons (car rest) ready)))
(else (else
(loop (cdr rest) ready)))) (loop (cdr rest) ready))))
(loop (cdr port/fds))))))) (loop (cdr port/fds)))))))))
(define (port/fdes-check-unlocked port/fd) (define any-input-ready (make-any-ready #t))
(define any-output-ready (make-any-ready #f))
(define (make-port/fdes-check-unlocked input?)
(let ((port/fdes->port
(if input?
port/fdes->input-port
port/fdes->output-port)))
(lambda (port/fd)
(if (port-locked? (port/fdes->port port/fd)) (if (port-locked? (port/fdes->port port/fd))
(begin (begin
((structure-ref interrupts enable-interrupts!)) ((structure-ref interrupts enable-interrupts!))
(error "SELECT on port with pending operation" (error "SELECT on port with pending operation"
port/fd)))) port/fd))))))
(define (port/fdes->channel port/fd) (define input-port/fdes-check-unlocked (make-port/fdes-check-unlocked #t))
(define output-port/fdes-check-unlocked (make-port/fdes-check-unlocked #f))
(define (port/fdes->input-channel port/fd)
(fdport-data:channel (fdport-data:channel
(fdport-data (fdport-data
(port/fdes->port port/fd)))) (port/fdes->input-port port/fd))))
;; this is way too epic and probably should just be split up once the (define (port/fdes->output-channel port/fd)
;; dust has settled ---Mike (fdport-data:channel
(fdport-data
(port/fdes->output-port port/fd))))
(define (make-select !?) (define (select read-vec write-vec exception-vec . maybe-timeout)
(lambda (read-vec write-vec exception-vec . maybe-timeout)
(let ((read-list (vector->list read-vec)) (let ((read-list (vector->list read-vec))
(write-list (vector->list write-vec)) (write-list (vector->list write-vec))
(timeout (:optional maybe-timeout #f))) (timeout (:optional maybe-timeout #f)))
((structure-ref interrupts disable-interrupts!)) ((structure-ref interrupts disable-interrupts!))
(for-each port/fdes-check-unlocked read-list) (for-each input-port/fdes-check-unlocked read-list)
(for-each port/fdes-check-unlocked write-list) (for-each output-port/fdes-check-unlocked write-list)
(let ((any-read (any-input-ready read-list))
(any-write (any-output-ready write-list)))
(let ((any-read (any-ready read-list))
(any-write (any-ready write-list)))
(if (or (pair? any-read) (pair? any-write)) (if (or (pair? any-read) (pair? any-write))
(begin (begin
((structure-ref interrupts enable-interrupts!)) ((structure-ref interrupts enable-interrupts!))
(if !? ; we're SELECT! (values (list->vector any-read)
(list->vector any-write)
(make-vector 0)))
;; we need to block
(let ((read-channels (map port/fdes->input-channel read-list))
(write-channels (map port/fdes->output-channel write-list)))
(for-each (lambda (channel)
(add-pending-channel channel #t))
read-channels)
(for-each (lambda (channel)
(add-pending-channel channel #f))
write-channels)
(call-with-values
(lambda ()
(wait-for-channels read-channels write-channels timeout))
;; re-enables interrupts
(lambda (ready-read-channels ready-write-channels)
(let ((ready-read-port/fds '())
(ready-write-port/fds '()))
(for-each (lambda (port/fd channel)
(if (memq channel ready-read-channels)
(set! ready-read-port/fds
(cons port/fd ready-read-port/fds))))
read-list read-channels)
(for-each (lambda (port/fd channel)
(if (memq channel ready-write-channels)
(set! ready-write-port/fds
(cons port/fd ready-write-port/fds))))
write-list write-channels)
(values (list->vector (reverse ready-read-port/fds))
(list->vector (reverse ready-write-port/fds))
(make-vector 0))))))))))
(define (select! read-vec write-vec exception-vec . maybe-timeout)
(let ((read-list (vector->list read-vec))
(write-list (vector->list write-vec))
(timeout (:optional maybe-timeout #f)))
((structure-ref interrupts disable-interrupts!))
(for-each input-port/fdes-check-unlocked read-list)
(for-each output-port/fdes-check-unlocked write-list)
(let ((any-read (any-input-ready read-list))
(any-write (any-output-ready write-list)))
(if (or (pair? any-read) (pair? any-write))
(begin
((structure-ref interrupts enable-interrupts!))
(let ((n-read-ready (let ((n-read-ready
(let ((length (vector-length read-vec))) (let ((length (vector-length read-vec)))
(let loop ((i 0) (n 0)) (let loop ((i 0) (n 0))
@ -820,15 +899,11 @@
(vector-set! exception-vec i #f) (vector-set! exception-vec i #f)
(loop (+ 1 i)))))) (loop (+ 1 i))))))
(values n-read-ready n-write-ready 0)) (values n-read-ready n-write-ready 0)))
;; we're vanilla SELECT
(values (list->vector any-read)
(list->vector any-write)
(make-vector 0))))
;; we need to block ;; we need to block
(let ((read-channels (map port/fdes->channel read-list)) (let ((read-channels (map port/fdes->input-channel read-list))
(write-channels (map port/fdes->channel write-list))) (write-channels (map port/fdes->output-channel write-list)))
(for-each (lambda (channel) (for-each (lambda (channel)
(add-pending-channel channel #t)) (add-pending-channel channel #t))
@ -844,8 +919,6 @@
;; re-enables interrupts ;; re-enables interrupts
(lambda (ready-read-channels ready-write-channels) (lambda (ready-read-channels ready-write-channels)
;; too many free variables ...
(if !? ; we're SELECT!
(let ((n-read-ready (let ((n-read-ready
(let loop ((read-channels read-channels) (let loop ((read-channels read-channels)
(n-ready 0) (n-ready 0)
@ -884,26 +957,5 @@
(vector-set! exception-vec i #f) (vector-set! exception-vec i #f)
(loop (+ 1 i)))))) (loop (+ 1 i))))))
(values n-read-ready n-write-ready 0)) (values n-read-ready n-write-ready 0)))))))))
;; we're vanilla SELECT
(let ((ready-read-port/fds '())
(ready-write-port/fds '()))
(for-each (lambda (port/fd channel)
(if (memq channel ready-read-channels)
(set! ready-read-port/fds
(cons port/fd ready-read-port/fds))))
read-list read-channels)
(for-each (lambda (port/fd channel)
(if (memq channel ready-write-channels)
(set! ready-write-port/fds
(cons port/fd ready-write-port/fds))))
write-list write-channels)
(values (list->vector (reverse ready-read-port/fds))
(list->vector (reverse ready-write-port/fds))
(make-vector 0))))))))))))
(define select (make-select #f))
(define select! (make-select #t))