~ chicken-core (chicken-5) ce09af5dd7e014c07afb3b44c4a89e130a0997f0
commit ce09af5dd7e014c07afb3b44c4a89e130a0997f0
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Tue Jul 27 00:27:17 2010 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Tue Jul 27 00:27:17 2010 +0200
applied srfi-18 and scheduler fixes by Joerg Wittenberger
diff --git a/files.scm b/files.scm
index 9fbc27db..2c1c167f 100644
--- a/files.scm
+++ b/files.scm
@@ -259,7 +259,7 @@ EOF
(if (absolute-pathname? dir)
dir
(##sys#string-append def-pds dir)) )
- file ext pds) ) ) )
+ file ext def-pds) ) ) )
(define decompose-pathname
(let ((string-match string-match))
diff --git a/library.scm b/library.scm
index 91a72ef6..9d725885 100644
--- a/library.scm
+++ b/library.scm
@@ -3930,7 +3930,7 @@ EOF
q ; #9 quantum
(##core#undefined) ; #10 specific
#f ; #11 block object (type depends on blocking type)
- '() ; #12 recipients (currently unused)
+ '() ; #12 recipients
#f) ) ; #13 unblocked by timeout?
(define ##sys#primordial-thread (##sys#make-thread #f 'running 'primordial ##sys#default-thread-quantum))
@@ -3946,17 +3946,6 @@ EOF
#f ; #5 locked
(##core#undefined) ) ) ; #6 specific
-(define (##sys#abandon-mutexes thread)
- (let ([ms (##sys#slot thread 8)])
- (unless (null? ms)
- (##sys#for-each
- (lambda (m)
- (##sys#setislot m 2 #f)
- (##sys#setislot m 4 #t)
- (##sys#setislot m 5 #f)
- (##sys#setislot m 3 '()) )
- ms) ) ) )
-
(define (##sys#schedule) ((##sys#slot ##sys#current-thread 1)))
(define (##sys#thread-yield!)
diff --git a/scheduler.scm b/scheduler.scm
index e4512a46..240b3ce1 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -34,7 +34,7 @@
##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#clear-i/o-state-for-thread!)
+ ##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook)
(foreign-declare #<<EOF
#ifdef HAVE_ERRNO_H
@@ -241,15 +241,40 @@ EOF
(##sys#setislot t 13 #f)
(##sys#setslot t 11 t2) ) ) )
+(define (##sys#abandon-mutexes thread)
+ (let ((ms (##sys#slot thread 8)))
+ (unless (null? ms)
+ (##sys#for-each
+ (lambda (m)
+ (##sys#setislot m 2 #f)
+ (##sys#setislot m 4 #t)
+ (##sys#setislot m 5 #f)
+ (let ((wts (##sys#slot m 3)))
+ (unless (null? wts)
+ (for-each
+ (lambda (t2)
+ (dbg " unblocking: " t2)
+ (##sys#thread-basic-unblock! t2) )
+ wts) ) )
+ (##sys#setislot m 3 '()) )
+ ms) ) ) )
+
(define (##sys#thread-kill! t s)
(dbg "killing: " t " -> " s ", recipients: " (##sys#slot t 12))
(##sys#abandon-mutexes t)
+ (let ((blocked (##sys#slot t 11)))
+ (cond
+ ((##sys#structure? blocked 'condition-variable)
+ (##sys#setslot blocked 2 (##sys#delq thread (##sys#slot blocked 2))))
+ ((##sys#structure? blocked 'thread)
+ (##sys#setslot blocked 12 (##sys#delq thread (##sys#slot blocked 12))))) )
+ (##sys#remove-from-timeout-list t)
+ (##sys#clear-i/o-state-for-thread! t)
(##sys#setslot t 3 s)
(##sys#setislot t 4 #f)
(##sys#setislot t 11 #f)
(##sys#setislot t 8 '())
- (##sys#remove-from-timeout-list t)
- (let ([rs (##sys#slot t 12)])
+ (let ((rs (##sys#slot t 12)))
(unless (null? rs)
(for-each
(lambda (t2)
@@ -461,7 +486,8 @@ EOF
;;; Unblock thread cleanly:
(define (##sys#thread-unblock! t)
- (when (eq? 'blocked (##sys#slot t 3))
+ (when (or (eq? 'blocked (##sys#slot t 3))
+ (eq? 'sleeping (##sys#slot r 3)))
(##sys#remove-from-timeout-list t)
(set! ##sys#fd-list
(let loop ([fdl ##sys#fd-list])
@@ -472,5 +498,4 @@ EOF
(cons (##sys#slot a 0)
(##sys#delq t (##sys#slot a 1)) )
(loop (##sys#slot fdl 1)) ) ) ) ) )
- (##sys#setislot t 12 '())
(##sys#thread-basic-unblock! t) ) )
diff --git a/srfi-18.scm b/srfi-18.scm
index 48dd8853..75d98890 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -307,8 +307,7 @@ EOF
(let* ([limitsup (pair? ms-and-t)]
[limit (and limitsup (##sys#compute-time-limit (car ms-and-t)))]
[threadsup (fx> (length ms-and-t) 1)]
- [thread (and threadsup (cadr ms-and-t))]
- [abd (##sys#slot mutex 4)] )
+ [thread (and threadsup (cadr ms-and-t))] )
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
(##sys#call-with-current-continuation
(lambda (return)
@@ -317,7 +316,7 @@ EOF
(##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
(##sys#schedule) )
(define (check)
- (when abd
+ (when (##sys#slot mutex 4) ; abandoned
(return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
(dbg ct ": locking " mutex)
(cond [(not (##sys#slot mutex 5))
@@ -344,6 +343,7 @@ EOF
(##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
(unless (##sys#slot ct 13) ; not unblocked by timeout
(##sys#remove-from-timeout-list ct))
+ (check)
(##sys#setslot ct 8 (cons mutex (##sys#slot ct 8)))
(##sys#setslot ct 11 #f)
(##sys#setslot mutex 2 thread)
@@ -353,7 +353,7 @@ EOF
[else
(##sys#setslot ct 3 'sleeping)
(##sys#setslot ct 11 mutex)
- (##sys#setslot ct 1 (lambda () (return #t)))
+ (##sys#setslot ct 1 (lambda () (check) (return #t)))
(switch) ] ) ) ) ) ) ) )
(define mutex-unlock!
@@ -371,7 +371,8 @@ EOF
[limit (and timeout (##sys#compute-time-limit timeout))] )
(##sys#setislot mutex 4 #f)
(##sys#setislot mutex 5 #f)
- (##sys#setslot ct 8 (##sys#delq mutex (##sys#slot ct 8)))
+ (let ((t (##sys#slot mutex 2)))
+ (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))
(when cvar
(##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct)))
(##sys#setslot ct 11 cvar)
@@ -468,7 +469,9 @@ EOF
((##sys#structure? blocked 'condition-variable)
(##sys#setslot blocked 2 (##sys#delq thread (##sys#slot blocked 2))))
((##sys#structure? blocked 'mutex)
- (##sys#setslot blocked 3 (##sys#delq thread (##sys#slot blocked 3)))))
+ (##sys#setslot blocked 3 (##sys#delq thread (##sys#slot blocked 3))))
+ ((##sys#structure? blocked 'thread)
+ (##sys#setslot blocked 12 (##sys#delq thread (##sys#slot blocked 12)))))
(##sys#setslot
thread 1
(lambda ()
Trap