~ chicken-core (chicken-5) c87b7eb2d4fe286149bb417eea7f1b9e0a209002
commit c87b7eb2d4fe286149bb417eea7f1b9e0a209002
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Fri Aug 27 21:00:04 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Fri Aug 27 21:00:04 2010 +0200
insane debugging and dump mistakes
diff --git a/posixunix.scm b/posixunix.scm
index 2260c671..c484bc86 100644
--- a/posixunix.scm
+++ b/posixunix.scm
@@ -1398,7 +1398,7 @@ EOF
(cond [(fx= cnt -1)
(if (fx= _errno _ewouldblock)
(begin
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
(##sys#thread-yield!)
(loop) )
(posix-error #:file-error loc "cannot read" fd nam) )]
diff --git a/scheduler.scm b/scheduler.scm
index e085d9e2..0df90b81 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -28,12 +28,12 @@
(declare
(unit scheduler)
(disable-interrupts)
- (hide ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#timeout-list
+ (hide ready-queue-head ready-queue-tail ##sys#timeout-list
##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-set
- ##sys#create-fdset
+ remove-from-ready-queue ##sys#unblock-threads-for-i/o ##sys#force-primordial
+ fdset-input-set fdset-output-set fdset-clear
+ fdset-select-timeout fdset-set fdset-test
+ create-fdset
##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook)
(unsafe)
@@ -82,10 +82,21 @@ EOF
(include "common-declarations.scm")
-(define-syntax dbg
+(define (dbg . args)
+ (for-each
+ (lambda (x)
+ (display x ##sys#standard-error))
+ args)
+ (newline ##sys#standard-error))
+
+#;(define-syntax dbg
(syntax-rules ()
((_ . _) #f)))
+(define-syntax panic
+ (syntax-rules ()
+ ((_ msg) (##core#inline "C_halt" msg))))
+
(define (##sys#schedule)
(define (switch thread)
(dbg "switching to " thread)
@@ -97,7 +108,7 @@ EOF
(let* ([ct ##sys#current-thread]
[eintr #f]
[cts (##sys#slot ct 3)] )
- (dbg "scheduling, current: " ct ", ready: " ##sys#ready-queue-head)
+ (dbg "==================== scheduling, current: " ct ", ready: " ready-queue-head)
(##sys#update-thread-state-buffer ct)
;; Put current thread on ready-queue:
(when (or (eq? cts 'running) (eq? cts 'ready)) ; should ct really be 'ready? - normally not.
@@ -107,14 +118,13 @@ EOF
;; Unblock threads waiting for timeout:
(unless (null? ##sys#timeout-list)
(let ((now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
- (dbg "timeout (" now ") list: " ##sys#timeout-list)
(let loop ((lst ##sys#timeout-list))
(if (null? lst)
(set! ##sys#timeout-list '())
(let* ([tmo1 (caar lst)] ; timeout of thread on list
[tto (cdar lst)] ; thread on list
[tmo2 (##sys#slot tto 4)] ) ; timeout value stored in thread
- (dbg " " tto " -> " tmo2)
+ (dbg "timeout: " tto " -> " tmo2 " (now: " now ")")
(if (equal? tmo1 tmo2) ;XXX why do we check this?
(if (fp>= now tmo1) ; timeout reached?
(begin
@@ -127,7 +137,7 @@ EOF
;; If there are no threads blocking on a select call (fd-list)
;; but there are threads in the timeout list then sleep for
;; the number of milliseconds of next thread to wake up.
- (when (and (null? ##sys#ready-queue-head)
+ (when (and (null? ready-queue-head)
(null? ##sys#fd-list)
(pair? ##sys#timeout-list))
(let ((tmo1 (caar ##sys#timeout-list)))
@@ -148,7 +158,7 @@ EOF
(##sys#unblock-threads-for-i/o) ) ) )
;; Fetch and activate next ready thread:
(let loop2 ()
- (let ([nt (##sys#remove-from-ready-queue)])
+ (let ([nt (remove-from-ready-queue)])
(cond [(not nt)
(if (and (null? ##sys#timeout-list) (null? ##sys#fd-list))
(##sys#signal-hook #:runtime-error "deadlock")
@@ -160,25 +170,25 @@ EOF
(dbg "primordial thread forced due to interrupt")
(##sys#thread-unblock! ##sys#primordial-thread) )
-(define ##sys#ready-queue-head '())
-(define ##sys#ready-queue-tail '())
+(define ready-queue-head '())
+(define ready-queue-tail '())
-(define (##sys#ready-queue) ##sys#ready-queue-head)
+(define (##sys#ready-queue) ready-queue-head)
(define (##sys#add-to-ready-queue thread)
(##sys#setslot thread 3 'ready)
(let ((new-pair (cons thread '())))
- (cond ((eq? '() ##sys#ready-queue-head)
- (set! ##sys#ready-queue-head new-pair))
- (else (set-cdr! ##sys#ready-queue-tail new-pair)) )
- (set! ##sys#ready-queue-tail new-pair) ) )
+ (cond ((eq? '() ready-queue-head)
+ (set! ready-queue-head new-pair))
+ (else (set-cdr! ready-queue-tail new-pair)) )
+ (set! ready-queue-tail new-pair) ) )
-(define (##sys#remove-from-ready-queue)
- (let ((first-pair ##sys#ready-queue-head))
+(define (remove-from-ready-queue)
+ (let ((first-pair ready-queue-head))
(and (not (null? first-pair))
(let ((first-cdr (cdr first-pair)))
- (set! ##sys#ready-queue-head first-cdr)
- (when (eq? '() first-cdr) (set! ##sys#ready-queue-tail '()))
+ (set! ready-queue-head first-cdr)
+ (when (eq? '() first-cdr) (set! ready-queue-tail '()))
(car first-pair) ) ) ) )
(define (##sys#update-thread-state-buffer thread)
@@ -223,7 +233,9 @@ EOF
(loop r l))))))
(define (##sys#thread-block-for-timeout! t tm)
- (dbg t " blocks for " tm)
+ (dbg t " blocks for timeout " tm)
+ (unless (flonum? tm)
+ (panic "##sys#thread-block-for-timeout!: invalid timeout"))
;; This should really use a balanced tree:
(let loop ([tl ##sys#timeout-list] [prev #f])
(if (or (null? tl) (fp< tm (caar tl)))
@@ -289,7 +301,7 @@ EOF
(define (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
- (##sys#setislot t 11 #f)
+ (##sys#setislot t 11 #f) ; (FD . RWFLAGS)
(##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
@@ -328,48 +340,59 @@ EOF
(define ##sys#fd-list '()) ; ((FD1 THREAD1 ...) ...)
-(define (##sys#create-fdset)
- (##sys#fdset-clear)
+(define (create-fdset)
+ (fdset-clear)
(let loop ((lst ##sys#fd-list))
(unless (null? lst)
(let ((fd (caar lst)))
(for-each
(lambda (t)
(let ((p (##sys#slot t 11)))
- (##sys#fdset-set fd (cdr p))))
+ (fdset-set fd (cdr p))))
(cdar lst))
(loop (cdr lst))))))
-(define ##sys#fdset-select-timeout
+(define fdset-select-timeout
(foreign-lambda* int ([bool to] [double tm])
"struct timeval timeout;"
"timeout.tv_sec = tm / 1000;"
"timeout.tv_usec = fmod(tm, 1000) * 1000;"
"C_return(select(FD_SETSIZE, &C_fdset_input, &C_fdset_output, NULL, to ? &timeout : NULL));") )
-(define (##sys#fdset-clear)
+(define fdset-clear
(foreign-lambda* void ()
"FD_ZERO(&C_fdset_input);"
"FD_ZERO(&C_fdset_output);") )
-(define ##sys#fdset-input-set
+(define fdset-input-set
(foreign-lambda* void ([int fd])
"FD_SET(fd, &C_fdset_input);" ) )
-(define ##sys#fdset-output-set
+(define fdset-output-set
(foreign-lambda* void ([int fd])
"FD_SET(fd, &C_fdset_output);" ) )
-(define (##sys#fdset-set fd i/o)
+(define (fdset-set fd i/o)
+ (dbg "setting fdset for " fd " to " i/o)
(case i/o
- ((#t #:input) (##sys#fdset-input-set fd))
- ((#f #:output) (##sys#fdset-output-set fd))
+ ((#:input) (fdset-input-set fd))
+ ((#:output) (fdset-output-set fd))
((#:all)
- (##sys#fdset-input-set fd)
- (##sys#fdset-output-set fd) ) ))
+ (fdset-input-set fd)
+ (fdset-output-set fd) )
+ (else (panic "fdset-set: invalid i/o direction"))))
+
+(define (fdset-test inf outf i/o)
+ (case i/o
+ ((#:input) inf)
+ ((#:output) outf)
+ ((#:all) (or inf outf))
+ (else (panic "fdset-test: invalid i/o direction"))))
(define (##sys#thread-block-for-i/o! t fd i/o)
- (dbg t " blocks for I/O " fd)
+ (dbg t " blocks for I/O " fd " in mode " i/o)
+ (unless (memq i/o '(#:all #:input #:output))
+ (panic "##sys#thread-block-for-i/o!: invalid i/o mode"))
(let loop ([lst ##sys#fd-list])
(if (null? lst)
(set! ##sys#fd-list (cons (list fd t) ##sys#fd-list))
@@ -383,41 +406,54 @@ EOF
(define (##sys#unblock-threads-for-i/o)
(dbg "fd-list: " ##sys#fd-list)
- (##sys#create-fdset)
- (let* ([to? (pair? ##sys#timeout-list)]
- [rq? (pair? ##sys#ready-queue-head)]
- [n (##sys#fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
- (or rq? to?)
- (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
- (let* ((tmo1 (caar ##sys#timeout-list))
- (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
- (fpmax 0.0 (fp- tmo1 now)) )
- 0.0) ) ] ) ; otherwise immediate timeout.
- (dbg n " fds ready")
- (cond [(eq? -1 n)
- (##sys#force-primordial)]
- [(fx> n 0)
- (set! ##sys#fd-list
- (let loop ([n n] [lst ##sys#fd-list])
- (if (or (zero? n) (null? lst))
- lst
- (let* ([a (car lst)]
- [fd (car a)]
- [inf (##core#inline "C_fd_test_input" fd)]
- [outf (##core#inline "C_fd_test_output" fd)] )
- (dbg "fd " fd " ready: input=" inf ", output=" outf)
- (if (or inf outf)
- (let loop2 ([threads (cdr a)])
- (if (null? threads)
- (loop (sub1 n) (cdr lst))
- (let* ([t (car threads)]
- [p (##sys#slot t 11)] )
- (when (and (pair? p)
- (eq? fd (car p))
- (not (##sys#slot t 13) ) ) ; not unblocked by timeout
- (##sys#thread-basic-unblock! t) )
- (loop2 (cdr threads)) ) ) )
- (cons a (loop n (cdr lst))) ) ) ) ) ) ] )))
+ (create-fdset)
+ (let* ((to? (pair? ##sys#timeout-list))
+ (rq? (pair? ready-queue-head))
+ (tmo (if (and to? (not rq?)) ; no thread was unblocked by timeout, so wait
+ (let* ((tmo1 (caar ##sys#timeout-list))
+ (now (##core#inline_allocate ("C_a_i_current_milliseconds" 4) #f)))
+ (fpmax 0.0 (fp- tmo1 now)) )
+ 0.0) ) ) ; otherwise immediate timeout.
+ (dbg "waiting for I/O with timeout " tmo)
+ (let ((n (fdset-select-timeout ; we use FD_SETSIZE, but really should use max fd
+ (or rq? to?)
+ tmo)))
+ (dbg n " fds ready")
+ (cond [(eq? -1 n)
+ (##sys#force-primordial)]
+ [(fx> n 0)
+ (set! ##sys#fd-list
+ (let loop ([n n] [lst ##sys#fd-list])
+ (if (or (zero? n) (null? lst))
+ lst
+ (let* ([a (car lst)]
+ [fd (car a)]
+ [inf (##core#inline "C_fd_test_input" fd)]
+ [outf (##core#inline "C_fd_test_output" fd)] )
+ (dbg "fd " fd " ready: input=" inf ", output=" outf)
+ (if (or inf outf)
+ (let loop2 ((threads (cdr a)) (keep '()))
+ (if (null? threads)
+ (if (null? keep)
+ (loop (sub1 n) (cdr lst))
+ (cons (cons fd keep) (loop (sub1 n) (cdr lst))))
+ (let* ((t (car threads))
+ (p (##sys#slot t 11)) )
+ (dbg "checking " t " " p)
+ (cond ((##sys#slot t 13) ; unblocked by timeout?
+ (dbg t " unblocked by timeout")
+ (loop2 (cdr threads) keep))
+ ((not (pair? p)) ; not blocked for I/O?
+ (panic
+ "##sys#unblock-threads-for-i/o: thread on fd-list is not blocked for I/O"))
+ ((not (eq? fd (car p)))
+ (panic
+ "##sys#unblock-threads-for-i/o: thread on fd-list has wrong FD"))
+ ((fdset-test inf outf (cdr p))
+ (##sys#thread-basic-unblock! t)
+ (loop2 (cdr threads) keep))
+ (else (loop2 (cdr threads) (cons t keep)))))))
+ (cons a (loop n (cdr lst))) ) ) ) ) ) ] ))) )
;;; Clear I/O state for unblocked thread
@@ -448,7 +484,7 @@ EOF
(cns (lambda (queue arg val init)
(cons val init)))
(init '()))
- (let loop ((l ##sys#ready-queue-head) (i init))
+ (let loop ((l ready-queue-head) (i init))
(if (pair? l)
(loop (cdr l) (cns 'ready #f (car l) i))
(let loop ((l ##sys#fd-list) (i i))
@@ -467,9 +503,9 @@ EOF
;;; Remove all waiting threads from the relevant queues with the exception of the current thread:
(define (##sys#fetch-and-clear-threads)
- (let ([all (vector ##sys#ready-queue-head ##sys#ready-queue-tail ##sys#fd-list ##sys#timeout-list)])
- (set! ##sys#ready-queue-head '())
- (set! ##sys#ready-queue-tail '())
+ (let ([all (vector ready-queue-head ready-queue-tail ##sys#fd-list ##sys#timeout-list)])
+ (set! ready-queue-head '())
+ (set! ready-queue-tail '())
(set! ##sys#fd-list '())
(set! ##sys#timeout-list '())
all) )
@@ -478,8 +514,8 @@ EOF
;;; Restore list of waiting threads:
(define (##sys#restore-threads vec)
- (set! ##sys#ready-queue-head (##sys#slot vec 0))
- (set! ##sys#ready-queue-tail (##sys#slot vec 1))
+ (set! ready-queue-head (##sys#slot vec 0))
+ (set! ready-queue-tail (##sys#slot vec 1))
(set! ##sys#fd-list (##sys#slot vec 2))
(set! ##sys#timeout-list (##sys#slot vec 3)) )
diff --git a/srfi-18.scm b/srfi-18.scm
index d9ad0bf0..36c48fbf 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -29,7 +29,7 @@
(unit srfi-18)
(uses scheduler)
(disable-interrupts)
- (hide ##sys#compute-time-limit) )
+ (hide compute-time-limit) )
(include "common-declarations.scm")
@@ -45,7 +45,7 @@
;;; Helper routines:
-(define (##sys#compute-time-limit tm loc)
+(define (compute-time-limit tm loc)
(cond ((not tm) #f)
((##sys#structure? tm 'time) (##sys#slot tm 1))
((number? tm) (+ (current-milliseconds) (* tm 1000)))
@@ -170,7 +170,7 @@
(lambda (thread . timeout)
(##sys#check-structure thread 'thread 'thread-join!)
(let* ((limit (and (pair? timeout)
- (##sys#compute-time-limit (##sys#slot timeout 0) 'thread-join!)))
+ (compute-time-limit (##sys#slot timeout 0) 'thread-join!)))
(rest (and (pair? timeout) (##sys#slot timeout 1)))
(tosupplied (and rest (pair? rest)))
(toval (and tosupplied (##sys#slot rest 0))) )
@@ -234,7 +234,7 @@
(##sys#thread-block-for-timeout! ct limit)
(##sys#schedule) ) ) ) )
(unless tm (##sys#signal-hook #:type-error 'thread-sleep! "invalid timeout argument" tm))
- (sleep (##sys#compute-time-limit tm 'thread-sleep!)) )
+ (sleep (compute-time-limit tm 'thread-sleep!)) )
;;; Mutexes:
@@ -269,7 +269,7 @@
(lambda (mutex . ms-and-t)
(##sys#check-structure mutex 'mutex 'mutex-lock!)
(let* ([limitsup (pair? ms-and-t)]
- [limit (and limitsup (##sys#compute-time-limit (car ms-and-t) 'mutex-lock!))]
+ [limit (and limitsup (compute-time-limit (car ms-and-t) 'mutex-lock!))]
[threadsup (fx> (length ms-and-t) 1)]
[thread (and threadsup (cadr ms-and-t))] )
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
@@ -334,7 +334,7 @@
(##sys#call-with-current-continuation
(lambda (return)
(let ([waiting (##sys#slot mutex 3)]
- [limit (and timeout (##sys#compute-time-limit timeout 'mutex-unlock!))] )
+ [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
(##sys#setislot mutex 4 #f)
(##sys#setislot mutex 5 #f)
(let ((t (##sys#slot mutex 2)))
@@ -455,7 +455,7 @@
(lambda ()
(when (or (##sys#fudge 12) (##sys#tty-port? ##sys#standard-input))
(old)
- (##sys#thread-block-for-i/o! ##sys#current-thread 0 #t)
+ (##sys#thread-block-for-i/o! ##sys#current-thread 0 #:input)
(thread-yield!)))) ) )
diff --git a/support.scm b/support.scm
index a60c7ab8..43bd2444 100644
--- a/support.scm
+++ b/support.scm
@@ -762,7 +762,9 @@
[(##core#variable quote ##core#undefined ##core#proc ##core#global-ref) #f]
[(##core#lambda)
(let ([id (first (node-parameters n))])
- (find (lambda (fs) (eq? id (foreign-callback-stub-id fs))) foreign-callback-stubs) ) ]
+ (find (lambda (fs)
+ (eq? id (foreign-callback-stub-id fs)))
+ foreign-callback-stubs) ) ]
[(if let) (any walk subs)]
[else #t] ) ) ) )
diff --git a/tcp.scm b/tcp.scm
index 96299349..1365c249 100644
--- a/tcp.scm
+++ b/tcp.scm
@@ -349,7 +349,7 @@ EOF
(##sys#thread-block-for-timeout!
##sys#current-thread
(+ (current-milliseconds) tmr) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
(yield)
(when (##sys#slot ##sys#current-thread 13)
(##sys#signal-hook
@@ -457,7 +457,7 @@ EOF
(##sys#thread-block-for-timeout!
##sys#current-thread
(+ (current-milliseconds) tmw) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #f)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:output)
(yield)
(when (##sys#slot ##sys#current-thread 13)
(##sys#signal-hook
@@ -525,7 +525,7 @@ EOF
(##sys#thread-block-for-timeout!
##sys#current-thread
(+ (current-milliseconds) tma) ) )
- (##sys#thread-block-for-i/o! ##sys#current-thread fd #t)
+ (##sys#thread-block-for-i/o! ##sys#current-thread fd #:input)
(yield)
(when (##sys#slot ##sys#current-thread 13)
(##sys#signal-hook
Trap