+ 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))
|
(force-output fdport))
|
||||||
|
|
||||||
(define (flush-all-ports)
|
(define (flush-all-ports)
|
||||||
(weak-table-walk
|
(let ((thunks (output-port-forcers #f)))
|
||||||
(lambda (i fdport)
|
(cond ((null? thunks)
|
||||||
(if (and fdport (open-output-port? fdport)) (flush-fdport fdport)))
|
#f)
|
||||||
fdports))
|
(else
|
||||||
|
(for-each (structure-ref threads spawn) thunks)
|
||||||
|
#t))))
|
||||||
|
|
||||||
;;; Extend R4RS i/o ops to handle file descriptors.
|
;;; Extend R4RS i/o ops to handle file descriptors.
|
||||||
;;; -----------------------------------------------
|
;;; -----------------------------------------------
|
||||||
|
@ -697,61 +699,3 @@
|
||||||
;;; replace rts/channel-port.scm end
|
;;; 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