+ Use S48's nonblocking facility to flush the ports
+ Deleted bogus select implementation
This commit is contained in:
parent
be129cadc7
commit
4efe1a4cd8
|
@ -541,10 +541,12 @@
|
|||
(force-output fdport))
|
||||
|
||||
(define (flush-all-ports)
|
||||
(weak-table-walk
|
||||
(lambda (i fdport)
|
||||
(if (and fdport (open-output-port? fdport)) (flush-fdport fdport)))
|
||||
fdports))
|
||||
(let ((thunks (output-port-forcers #f)))
|
||||
(cond ((null? thunks)
|
||||
#f)
|
||||
(else
|
||||
(for-each (structure-ref threads spawn) thunks)
|
||||
#t))))
|
||||
|
||||
;;; Extend R4RS i/o ops to handle file descriptors.
|
||||
;;; -----------------------------------------------
|
||||
|
@ -697,61 +699,3 @@
|
|||
;;; replace rts/channel-port.scm end
|
||||
|
||||
|
||||
|
||||
(define (nselect rvec wvec evec timeout)
|
||||
(let ((rlist (vector->list rvec))
|
||||
(wlist (vector->list wvec)))
|
||||
(let ((imm-r (filter char-ready? rlist))
|
||||
(imm-w (filter output-port-ready? wlist)))
|
||||
(if (and (null? imm-r)
|
||||
(null? imm-w))
|
||||
(select-threaded rlist wlist timeout)
|
||||
(values (list->vector imm-r)
|
||||
(list->vector imm-w)
|
||||
'#())))))
|
||||
|
||||
(define (timeout-thread result-lock timeout)
|
||||
(lambda ()
|
||||
((structure-ref threads sleep) timeout)
|
||||
(release-lock result-lock)))
|
||||
|
||||
(define (select-threaded rlist wlist timeout)
|
||||
(let ((result-lock (make-lock))
|
||||
(ready-lock (make-lock))
|
||||
(read-ready (cons 'cell '()))
|
||||
(write-ready (cons 'cell '()))
|
||||
(are-we-ready? #f))
|
||||
(let* ((port-waiter
|
||||
(lambda (ready? ready-list)
|
||||
(lambda (port)
|
||||
(lambda ()
|
||||
; ((structure-ref interrupts disable-interrupts!))
|
||||
; (if (ready? port)
|
||||
; ((structure-ref interrupts enable-interrupts!))
|
||||
; (wait-for-channel ; enables interrupts
|
||||
; (fdport-data:channel
|
||||
; (fdport-data port))))
|
||||
(let lp ()
|
||||
(if (ready? port)
|
||||
(begin
|
||||
(obtain-lock ready-lock)
|
||||
(set-cdr! ready-list (cons port (cdr ready-list)))
|
||||
(release-lock ready-lock)
|
||||
(release-lock result-lock))
|
||||
(if (not are-we-ready?)
|
||||
(begin ((structure-ref threads sleep) 20)
|
||||
(lp)))))))))
|
||||
(read-waiter (port-waiter char-ready? read-ready))
|
||||
(write-waiter (port-waiter output-port-ready? write-ready)))
|
||||
(obtain-lock result-lock)
|
||||
(for-each spawn (map read-waiter rlist))
|
||||
(for-each spawn (map write-waiter wlist))
|
||||
(if timeout (spawn (timeout-thread result-lock timeout)))
|
||||
(obtain-lock result-lock)
|
||||
(set! are-we-ready? #t)
|
||||
; (relinquish-timeslice)
|
||||
(values (cdr read-ready)
|
||||
(cdr write-ready)
|
||||
'#()))))
|
||||
|
||||
|
Loading…
Reference in New Issue