diff --git a/scheduler.scm b/scheduler.scm index e31f6c8..7a0b4c6 100644 --- a/scheduler.scm +++ b/scheduler.scm @@ -384,17 +384,34 @@ EOF (define ##sys#fd-list '()) ; ((FD1 THREAD1 ...) ...) (define (create-fdset) + (define (remove-empty ls) + (if (null? ls) + '() + (if (null? (cdar ls)) + (remove-empty (cdr ls)) + (cons (car ls) (remove-empty (cdr ls)))))) ((foreign-lambda void "C_prepare_fdset" int) (##sys#length ##sys#fd-list)) - (let loop ((lst ##sys#fd-list)) - (unless (null? lst) - (let ((fd (caar lst))) - (for-each - (lambda (t) - (let ((p (##sys#slot t 11))) - (when (pair? p) ; (FD . RWFLAGS)? (can also be mutex or thread) - (fdset-set fd (cdr p))))) - (cdar lst)) - (loop (cdr lst)))))) + ; Loop through ##sys#fd-list, calling fdset-set on the threaads blocking on + ; each fd. If a thread is not blocking on a fd (i.e. its block object in + ; slot 11 is not a (fd . rwflags) pair) then remove it from the list. + (for-each + (lambda (item) + (let* ((fd (car item))) + (set-cdr! + item + (let loop-ts ((ts (cdr item)) + (acc '())) + (if (null? ts) + acc + (let* ((t (car ts)) + (p (##sys#slot t 11))) + (if (pair? p) ; (FD . RWFLAGS)? (can also be mutex or thread) + (begin + (fdset-set fd (cdr p)) + (loop-ts (cdr ts) (cons t acc))) + (loop-ts (cdr ts) acc)))))))) + ##sys#fd-list) + (set! ##sys#fd-list (remove-empty ##sys#fd-list))) (define (fdset-set fd i/o) (let ((fdset-add! (foreign-lambda void "C_fdset_add" int bool bool)))