~ chicken-core (chicken-5) 027b8cbb97edcdc412529cc867bb7a1442b0afd5
commit 027b8cbb97edcdc412529cc867bb7a1442b0afd5
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Thu Aug 26 16:50:26 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Thu Aug 26 16:50:26 2010 +0200
simplified fdset handling; fixed incorrectly named variable in ##sys#thread-unblock<bang>
diff --git a/scheduler.scm b/scheduler.scm
index 15d100be..93697522 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -32,7 +32,8 @@
##sys#update-thread-state-buffer ##sys#restore-thread-state-buffer
##sys#remove-from-ready-queue ##sys#unblock-threads-for-i/o ##sys#force-primordial
##sys#fdset-input-set ##sys#fdset-output-set ##sys#fdset-clear
- ##sys#fdset-select-timeout ##sys#fdset-restore
+ ##sys#fdset-select-timeout ##sys#fdset-set
+ ##sys#create-fdset
##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook)
(unsafe)
@@ -73,7 +74,7 @@ C_word C_msleep(C_word ms) {
return C_SCHEME_TRUE;
}
#endif
-static fd_set C_fdset_input, C_fdset_output, C_fdset_input_2, C_fdset_output_2;
+static fd_set C_fdset_input, C_fdset_output;
#define C_fd_test_input(fd) C_mk_bool(FD_ISSET(C_unfix(fd), &C_fdset_input))
#define C_fd_test_output(fd) C_mk_bool(FD_ISSET(C_unfix(fd), &C_fdset_output))
EOF
@@ -326,25 +327,31 @@ EOF
;;; `select()'-based blocking:
-(define ##sys#fd-list '())
+(define ##sys#fd-list '()) ; ((FD1 THREAD1 ...) ...)
+
+(define (##sys#create-fdset)
+ (##sys#fdset-clear)
+ (let loop ((lst ##sys#fd-list))
+ (unless (null? lst)
+ (let ((fd (caar lst)))
+ (for-each
+ (lambda (t)
+ (let ((p (##sys#slot t 11)))
+ (##sys#fdset-set fd (cdr p))))
+ (cdar lst))
+ (loop (cdr lst))))))
(define ##sys#fdset-select-timeout
(foreign-lambda* int ([bool to] [double tm])
"struct timeval timeout;"
"timeout.tv_sec = tm / 1000;"
"timeout.tv_usec = fmod(tm, 1000) * 1000;"
- "C_fdset_input_2 = C_fdset_input;"
- "C_fdset_output_2 = C_fdset_output;"
"C_return(select(FD_SETSIZE, &C_fdset_input, &C_fdset_output, NULL, to ? &timeout : NULL));") )
-(define ##sys#fdset-restore
+(define (##sys#fdset-clear)
(foreign-lambda* void ()
- "C_fdset_input = C_fdset_input_2;"
- "C_fdset_output = C_fdset_output_2;") )
-
-((foreign-lambda* void ()
- "FD_ZERO(&C_fdset_input);"
- "FD_ZERO(&C_fdset_output);") )
+ "FD_ZERO(&C_fdset_input);"
+ "FD_ZERO(&C_fdset_output);") )
(define ##sys#fdset-input-set
(foreign-lambda* void ([int fd])
@@ -354,10 +361,13 @@ EOF
(foreign-lambda* void ([int fd])
"FD_SET(fd, &C_fdset_output);" ) )
-(define ##sys#fdset-clear
- (foreign-lambda* void ([int fd])
- "FD_CLR(fd, &C_fdset_input_2);"
- "FD_CLR(fd, &C_fdset_output_2);") )
+(define (##sys#fdset-set fd i/o)
+ (case i/o
+ ((#t #:input) (##sys#fdset-input-set fd))
+ ((#f #:output) (##sys#fdset-output-set fd))
+ ((#:all)
+ (##sys#fdset-input-set fd)
+ (##sys#fdset-output-set fd) ) ))
(define (##sys#thread-block-for-i/o! t fd i/o)
(dbg t " blocks for I/O " fd)
@@ -368,23 +378,18 @@ EOF
(if (fx= fd (car a))
(##sys#setslot a 1 (cons t (cdr a)))
(loop (cdr lst)) ) ) ) )
- (case i/o
- ((#t #:input) (##sys#fdset-input-set fd))
- ((#f #:output) (##sys#fdset-output-set fd))
- ((#:all)
- (##sys#fdset-input-set fd)
- (##sys#fdset-output-set fd) ) )
(##sys#setslot t 3 'blocked)
(##sys#setislot t 13 #f)
(##sys#setslot t 11 (cons fd i/o)) )
(define (##sys#unblock-threads-for-i/o)
(dbg "fd-list: " ##sys#fd-list)
+ (##sys#create-fdset)
(let* ([to? (pair? ##sys#timeout-list)]
[rq? (pair? ##sys#ready-queue-head)]
[n (##sys#fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
(or rq? to?)
- (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
+ (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
(let* ((tmo1 (caar ##sys#timeout-list))
(now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
(fpmax 0.0 (fp- tmo1 now)) )
@@ -405,9 +410,7 @@ EOF
(if (or inf outf)
(let loop2 ([threads (cdr a)])
(if (null? threads)
- (begin
- (##sys#fdset-clear fd)
- (loop (sub1 n) (cdr lst)) )
+ (loop (sub1 n) (cdr lst))
(let* ([t (car threads)]
[p (##sys#slot t 11)] )
(when (and (pair? p)
@@ -415,32 +418,28 @@ EOF
(not (##sys#slot t 13) ) ) ; not unblocked by timeout
(##sys#thread-basic-unblock! t) )
(loop2 (cdr threads)) ) ) )
- (cons a (loop n (cdr lst))) ) ) ) ) ) ] )
- (##sys#fdset-restore) ) )
+ (cons a (loop n (cdr lst))) ) ) ) ) ) ] )))
;;; Clear I/O state for unblocked thread
(define (##sys#clear-i/o-state-for-thread! t)
(when (pair? (##sys#slot t 11))
- (let ((fd (##sys#slot (##sys#slot t 11) 0)))
+ (let ((fd (car (##sys#slot t 11))))
(set! ##sys#fd-list
(let loop ([lst ##sys#fd-list])
(if (null? lst)
'()
- (let* ([a (##sys#slot lst 0)]
- [fd2 (##sys#slot a 0)] )
+ (let* ([a (car lst)]
+ [fd2 (car a)] )
(if (eq? fd fd2)
- (let ((ts (##sys#delq t (##sys#slot a 1)))) ; remove from fd-list entry
+ (let ((ts (##sys#delq t (cdr a)))) ; remove from fd-list entry
(cond ((null? ts)
- ;;(pp `(CLEAR FD: ,fd ,t) ##sys#standard-error)
- (##sys#fdset-clear fd) ; no more threads waiting for this fd
- (##sys#fdset-restore)
- (##sys#slot lst 1) )
+ (cdr lst) )
(else
(##sys#setslot a 1 ts) ; fd-list entry is list with t removed
lst) ) )
- (cons a (loop (##sys#slot lst 1)))))))))))
+ (cons a (loop (cdr lst)))))))))))
;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
@@ -491,7 +490,7 @@ EOF
(define (##sys#thread-unblock! t)
(when (or (eq? 'blocked (##sys#slot t 3))
- (eq? 'sleeping (##sys#slot r 3)))
+ (eq? 'sleeping (##sys#slot t 3)))
(##sys#remove-from-timeout-list t)
(set! ##sys#fd-list
(let loop ([fdl ##sys#fd-list])
Trap