Hi Felix & All,
I observed a starvation of some threads, when there's concurrent i/o
going on.
The attached patch improves fairness in most cases by eating up the
(new) current-ready-queue before refilling it. But it does obviously
not fix 100% of possible cases of the starvation problem.
I have no environment to quantify the improvement. But the patch avoids
some needless select(2) handling and improves responsiveness to an
extend that I can "feel it in the mouse".
Unfortunately I'm unable to reproduce the starvation without handling
bad fd's too. Therefor I must regret to include that change in the
attached patch.
best regards
/Jörg
Index: scheduler.scm
===================================================================
--- scheduler.scm (Revision 11689)
+++ scheduler.scm (Arbeitskopie)
@@ -33,10 +33,11 @@
(emit-exports "scheduler.exports")
(disable-warning var)
(hide ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#timeout-list
+ ##sys#current-ready-queue ##sys#remove-from-current-ready-queue
##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-restore ##sys#handle-bad-fd!
##sys#clear-i/o-state-for-thread!)
(foreign-declare #<<EOF
#ifdef HAVE_ERRNO_H
@@ -60,6 +61,7 @@
# include <sys/types.h>
# include <sys/time.h>
# include <time.h>
+# include <sys/stat.h>
static C_word C_msleep(C_word ms);
C_word C_msleep(C_word ms) {
#ifdef __CYGWIN__
@@ -91,10 +93,24 @@
#;(define-macro (dbg . args)
`(print "DBG: " ,@args) )
+(define ##sys#current-ready-queue '())
+(define (##sys#remove-from-current-ready-queue)
+ (let ((h ##sys#current-ready-queue))
+ (or (and (pair? h)
+ (let ((r (cdr h)))
+ (set! ##sys#current-ready-queue r)
+ (car h) ) )
+ (begin
+ (set! ##sys#current-ready-queue ##sys#ready-queue-head)
+ (set! ##sys#ready-queue-head '())
+ (set! ##sys#ready-queue-tail '())
+ (and (pair? ##sys#current-ready-queue)
+ (##sys#remove-from-current-ready-queue)))) ) )
+
(define (##sys#schedule)
(define (switch thread)
- (dbg "switching to " thread)
+ (dbg "switching to ~a" thread)
(set! ##sys#current-thread thread)
(##sys#setslot thread 3 'running)
(##sys#restore-thread-state-buffer thread)
@@ -111,7 +127,7 @@
(##sys#add-to-ready-queue ct) )
(let loop1 ()
;; Unblock threads waiting for timeout:
- (unless (null? ##sys#timeout-list)
+ (unless (or (pair? ##sys#current-ready-queue)) (null? ##sys#timeout-list)
(let ([now (##sys#fudge 16)])
(dbg "timeout (" now ") list: " ##sys#timeout-list)
(let loop ([lst ##sys#timeout-list])
@@ -145,12 +161,11 @@
;; Unblock threads blocked by I/O:
(if eintr
(##sys#force-primordial)
- (begin
- (unless (null? ##sys#fd-list)
- (##sys#unblock-threads-for-i/o) ) ) )
+ (unless (or (pair? ##sys#current-ready-queue) (null? ##sys#fd-list))
+ (##sys#unblock-threads-for-i/o) ) )
;; Fetch and activate next ready thread:
(let loop2 ()
- (let ([nt (##sys#remove-from-ready-queue)])
+ (let ([nt (##sys#remove-from-current-ready-queue)])
(cond [(not nt)
(if (and (null? ##sys#timeout-list) (null? ##sys#fd-list))
(##sys#signal-hook #:runtime-error "deadlock")
@@ -160,6 +175,7 @@
(define (##sys#force-primordial)
(dbg "primordial thread forced due to interrupt")
+ ;(display "switching to primordial thread\n" debug-port)
(##sys#thread-unblock! ##sys#primordial-thread) )
(define ##sys#ready-queue-head '())
@@ -341,6 +357,30 @@
(##sys#setislot t 13 #f)
(##sys#setslot t 11 (cons fd i/o)) )
+(define-foreign-variable error-bad-file int "(errno == EBADF)")
+
+(define (##sys#handle-bad-fd! e)
+ (dbg "check bad" e)
+ (let ((bad ((foreign-lambda*
+ bool ((integer fd))
+ "struct stat buf;"
+ "int i = ( (fstat(fd, &buf) == -1 && errno == EBADF) ? 1 : 0);"
+ "return(i);")
+ (car e))))
+ (if bad
+ (for-each
+ (lambda (thread)
+ (thread-signal!
+ thread
+ (##sys#make-structure
+ 'condition
+ '(exn i/o) ;; better? '(exn i/o net)
+ (list '(exn . message) "bad file descriptor"
+ '(exn . arguments) (car e)
+ '(exn . location) thread) )))
+ (cdr e)))
+ bad))
+
(define (##sys#unblock-threads-for-i/o)
(dbg "fd-list: " ##sys#fd-list)
(let* ([to? (pair? ##sys#timeout-list)]
@@ -353,8 +393,23 @@
(fxmax 0 (- tmo1 now)) )
0) ) ] ) ; otherwise immediate timeout.
(dbg n " fds ready")
- (cond [(eq? -1 n)
- (##sys#force-primordial)]
+ (cond [(eq? -1 n)
+ (cond
+ (error-bad-file
+ (set! ##sys#fd-list
+ (let loop ((l ##sys#fd-list))
+ (cond
+ ((null? l) l)
+ ((##sys#handle-bad-fd! (car l))
+ (##sys#fdset-clear (caar l))
+ ;; This is supposed to be a rare case, catch
+ ;; them one by one.
+ ;; (loop (cdr l))
+ (cdr l))
+ (else (cons (car l) (loop (cdr l)))))))
+ (##sys#fdset-restore)
+ (##sys#unblock-threads-for-i/o))
+ (else (##sys#force-primordial))) ]
[(fx> n 0)
(set! ##sys#fd-list
(let loop ([n n] [lst ##sys#fd-list])
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
