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.
Index: scheduler.scm
===================================================================
--- scheduler.scm (Revision 11967)
+++ scheduler.scm (Arbeitskopie)
@@ -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)])
@@ -247,6 +248,14 @@
(lambda (t2)
(dbg " checking: " t2 " (" (##sys#slot t2 3) ") -> " (##sys#slot t2 11))
(when (eq? (##sys#slot t2 11) 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) t2)
+ (##sys#slot l 1)
+ (cons h (loop (##sys#slot l 1))))))))
(##sys#thread-basic-unblock! t2) ) )
rs) ) )
(##sys#setislot t 12 '()) )
@@ -408,12 +456,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)
_______________________________________________
Chicken-users mailing list
[email protected]
http://lists.nongnu.org/mailman/listinfo/chicken-users
