yet another instance of left over entries: threads unblocked by i/o
should not be any longer on the timeout list, otherwise the next timeout
*could* be quite short. ;-)
Am Sonntag, den 21.09.2008, 13:31 +0200 schrieb Jörg F. Wittenberger:
> Am Freitag, den 19.09.2008, 23:30 +0200 schrieb Jörg F. Wittenberger:
> > > The attached patch fixes ##sys#thread-kill! wrt. to join timeouts.
>
> The attached fix adds code to mutex-lock! and mutex-unlock! to remove
> the thread from the timeout-list when a timeout was supplied and the
> thread was not unblocked by timeout.
BTW: sorry for the fix still containing the bad-fd handling code and -
too - the extended ##sys#all-threads. It's getting messy with the diffs
here around. Please cherry-pick.
Index: scheduler.scm
===================================================================
--- scheduler.scm (Revision 11974)
+++ scheduler.scm (Arbeitskopie)
@@ -46,6 +46,8 @@
# define C_signal_interrupted_p C_SCHEME_FALSE
#endif
+# include <sys/stat.h>
+
#ifdef _WIN32
# if _MSC_VER > 1300
# include <winsock2.h>
@@ -145,9 +147,8 @@
;; Unblock threads blocked by I/O:
(if eintr
(##sys#force-primordial)
- (begin
- (unless (null? ##sys#fd-list)
- (##sys#unblock-threads-for-i/o) ) ) )
+ (unless (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)])
@@ -212,6 +213,16 @@
(define ##sys#timeout-list '())
+(define (##sys#remove-from-timeout-list! t)
+ (set! ##sys#timeout-list
+ (let loop ((l ##sys#timeout-list))
+ (if (null? l)
+ l
+ (let ((h (##sys#slot l 0)))
+ (if (eq? (##sys#slot h 1) t)
+ (##sys#slot l 1)
+ (cons h (loop (##sys#slot l 1)))))))))
+
(define (##sys#thread-block-for-timeout! t tm)
(dbg t " blocks for " tm)
;; This should really use a balanced tree:
@@ -341,6 +352,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) (list (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 +388,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])
@@ -376,6 +426,7 @@
(when (and (pair? p)
(eq? fd (car p))
(not (##sys#slot t 13) ) ) ; not unblocked by timeout
+ (##sys#remove-from-timeout-list! t)
(##sys#thread-basic-unblock! t) )
(loop2 (cdr threads)) ) ) )
(cons a (loop n (cdr lst))) ) ) ) ) ) ] )
@@ -408,12 +459,28 @@
;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
-(define (##sys#all-threads)
- (append ##sys#ready-queue-head
- (apply append (map cdr ##sys#fd-list))
- (map cdr ##sys#timeout-list)))
+(define (##sys#all-threads . cons+init)
+ (let ((cons (if (null? cons+init)
+ (lambda (queue arg val init)
+ (cons val init))
+ (car cons+init)))
+ (init (if (and (pair? cons+init) (pair? (cdr cons+init)))
+ (cadr cons+init) '())))
+ (let loop ((l ##sys#ready-queue-head) (i init))
+ (if (pair? l)
+ (loop (cdr l) (cons 'ready #f (car l) i))
+ (let loop ((l ##sys#fd-list) (i i))
+ (if (pair? l)
+ (loop (cdr l)
+ (let ((fd (caar l)))
+ (let loop ((l (cdar l)))
+ (if (null? l) i
+ (cons 'i/o fd (car l) (loop (cdr l)))))))
+ (let loop ((l ##sys#timeout-list) (i i))
+ (if (pair? l)
+ (loop (cdr l) (cons 'timeout (caar l) (cdar l) i))
+ i))))))))
-
;;; Remove all waiting threads from the relevant queues with the exception of the current thread:
(define (##sys#fetch-and-clear-threads)
@@ -438,14 +505,7 @@
(define (##sys#thread-unblock! t)
(when (eq? 'blocked (##sys#slot t 3))
- (set! ##sys#timeout-list
- (let loop ((l ##sys#timeout-list))
- (if (null? l)
- l
- (let ((h (##sys#slot l 0)))
- (if (eq? (##sys#slot h 1) t)
- (##sys#slot l 1)
- (cons h (loop (##sys#slot l 1))))))))
+ (##sys#remove-from-timeout-list! t)
(set! ##sys#fd-list
(let loop ([fdl ##sys#fd-list])
(if (null? fdl)
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
