Argh! Sorry.
The fix I sent is not that complete. Attached a better one, which
touches srfi-18.scm too.
Am Freitag, den 19.09.2008, 23:17 +0200 schrieb Jörg F. Wittenberger:
> Hi all,
>
> these days Felix asked for a test case of multiple entries of the same
> thread in the ##sys#timeout-list -- I don't have any, but I've got
> around to nail it down.
>
> The attached patch fixes ##sys#thread-kill! wrt. to join timeouts.
>
> Besides the fix it includes a compatible modification to
> ##sys#all-threads, which I'd hereby like propose to go (probably in an
> improved form) into core chicken, since it allows one to get better
> impression of the system state than the current version. [It was very
> valuable when tracking down the double entry.] The modification allows
> two optional arguments, a fold-type of a function (which receives the
> enumerated queue, a possible wait reason argument, the enumerated thread
> and the accumulate result) and the initial fold-value.
>
> Best regards
>
> /Jörg
>
> BTW: the line numbers in the patch might be off: it's still hand edited,
> since I can't live without chicken handling bad file descriptors.
>
> _______________________________________________
> Chicken-users mailing list
> [email protected]
> http://lists.nongnu.org/mailman/listinfo/chicken-users
>
> --=-7iI9OtPFZMwn3sn9k0�
Index: scheduler.scm
===================================================================
--- scheduler.scm (Revision 11967)
+++ 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])
@@ -408,12 +458,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 +504,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)
Index: srfi-18.scm
===================================================================
--- srfi-18.scm (Revision 11967)
+++ srfi-18.scm (Arbeitskopie)
@@ -239,8 +239,11 @@
ct 1
(lambda ()
(case (##sys#slot thread 3)
- [(dead) (apply return (##sys#slot thread 2))]
+ [(dead)
+ (##sys#remove-from-timeout-list! ct)
+ (apply return (##sys#slot thread 2))]
[(terminated)
+ (##sys#remove-from-timeout-list! ct)
(return
(##sys#signal
(##sys#make-structure
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
