Hi all,
attached several patches I owe you.
Patches 0001-0004 should apply on chicken 4.13, i.e. 68eeaaef3fc.
Patches 0005 and 0006 are against master (9f55823852).
Patches 0007 and 0008 are against srfi-18 egg source.
0002 - Fix 1564: This establishes the invariant that slot #11, the
blocking object and thread being in the relevant blocking queue are
always in sync. This eases reasoning about the code and fixes the
bug. Added advantage: Having a single spot to clear blocking objects
might allow eggs to introduce additional objects to block on.
0003 - Test case regarding abandoned mutex handling: This warrents
doube checking wrt. srfi-18. The test checks for my understanding of
srfi-18 and fails without 0004 applied.
0004- Change abandoned mutexs state according to srfi-18: This passes
the test cases added by 0003. Additionally it establishes a similar
invariant as 0002 wrt. slot #4 and the timeout queue. Contains
consistency checks to be phased out after testing.
Best
/Jörg
From 7288c18082a6334be0548e2e23ca13921f99076f Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Tue, 18 Dec 2018 14:26:03 +0100
Subject: [PATCH 2/4] Add test case catching #1564 almost for sure.
---
tests/mutex-test.scm | 23 +++++++++++++++++++++++
1 file changed, 23 insertions(+)
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 873e812c..738e73d3 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -55,6 +55,29 @@ Slot Type Meaning
(print "Got " mux1 " state " (mutex-state mux1) " expected " owner1 "\n")
(test-exit 1)))))
+(let ((m1 (make-mutex)))
+ ;; This fails if we manage to sort primorial before t1 and unleash
+ ;; both in one turn.
+ (define (sys-thread-sleep! limit)
+ ;; a copy from srfi-18 which expects pre-computed goal time.
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ((ct ##sys#current-thread))
+ (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+ (##sys#thread-block-for-timeout! ct limit)
+ (##sys#schedule) ) ) ) )
+ #;(print "mutex state changes atomically wrt. blocking queues")
+ (mutex-lock! m1)
+ (let ((t1 (thread-start! (lambda () (mutex-lock! m1 0.1)))))
+ #;(print "have t1 it wait for m1")
+ (thread-yield!)
+ (let* ((to (##sys#slot t1 4))
+ (hit (- to 0.0001)))
+ #;(print "waiting ever so slightly less than to " to " i.e. " hit "\n")
+ (sys-thread-sleep! hit))
+ ;; catch inconsistent state
+ (mutex-unlock! m1)))
+
(set! mux1 (make-mutex 'unlock-leaves-no-memory-leak))
(mutex-lock! mux1)
(mutex-unlock! mux1)
--
2.11.0
From b6837b2c94feb5f8348965f538b5a45bf01a7506 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Mon, 3 Dec 2018 21:06:26 +0100
Subject: [PATCH 1/4] Fix 1564 internal scheduler error.
---
scheduler.scm | 80 ++++++++++++++++++++++++++++++-----------------------------
1 file changed, 41 insertions(+), 39 deletions(-)
diff --git a/scheduler.scm b/scheduler.scm
index 0b292f7f..a1a03293 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -34,7 +34,7 @@
;; This isn't hidden ATM to allow set!ing it as a hook/workaround
; ##sys#force-primordial
fdset-set fdset-test create-fdset stderr
- ##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
+ ##sys#thread-clear-blocking-state! ##sys#abandon-mutexes)
(not inline ##sys#interrupt-hook ##sys#force-primordial)
(unsafe)
(foreign-declare #<<EOF
@@ -185,7 +185,7 @@ EOF
(if (fp>= now tmo1) ; timeout reached?
(begin
(##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
- (##sys#clear-i/o-state-for-thread! tto)
+ (##sys#thread-clear-blocking-state! tto)
(##sys#thread-basic-unblock! tto)
(loop (cdr lst)) )
(begin
@@ -335,17 +335,9 @@ EOF
(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 t (##sys#slot blocked 2))))
- ((##sys#structure? blocked 'thread)
- (##sys#setslot blocked 12 (##sys#delq t (##sys#slot blocked 12))))) )
(##sys#remove-from-timeout-list t)
- (##sys#clear-i/o-state-for-thread! t)
+ (##sys#thread-clear-blocking-state! t)
(##sys#setslot t 3 s)
- (##sys#setislot t 4 #f)
- (##sys#setislot t 11 #f)
(##sys#setislot t 8 '())
(let ((rs (##sys#slot t 12)))
(unless (null? rs)
@@ -353,13 +345,15 @@ EOF
(lambda (t2)
(dbg " checking: " t2 " (" (##sys#slot t2 3) ") -> " (##sys#slot t2 11))
(when (eq? (##sys#slot t2 11) t)
- (##sys#thread-basic-unblock! t2) ) )
- rs) ) )
- (##sys#setislot t 12 '()) )
+ (##sys#thread-unblock! t2) ) )
+ rs)
+ (##sys#setislot t 12 '()) ) ) )
(define (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
- (##sys#setislot t 11 #f) ; (FD . RWFLAGS) | #<MUTEX> | #<THREAD>
+ #;(if (##sys#slot t 11) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unclean unblock"
+ (##sys#slot t 11)))
(##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
@@ -489,39 +483,20 @@ EOF
;; is incorrect but will be ignored, just let it run
(when (##sys#slot t 4) ; also blocked for timeout?
(##sys#remove-from-timeout-list t))
- (##sys#thread-basic-unblock! t)
+ (##sys#thread-clear-blocking-state! t)
+ (##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
((not (eq? fd (car p)))
(panic (sprintf "thread is registered for I/O on unknown file-descriptor: ~S (expected ~S)" (car p) fd)))
((fdset-test inf outf (cdr p))
(when (##sys#slot t 4) ; also blocked for timeout?
(##sys#remove-from-timeout-list t))
+ (##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
(else (loop2 (cdr threads) (cons t keep)))))))
(cons a (loop n (add1 pos) (cdr lst))) ) ) ) ) ) ] ))) )
-
-;;; Clear I/O state for unblocked thread
-
-(define (##sys#clear-i/o-state-for-thread! t)
- (when (pair? (##sys#slot t 11))
- (let ((fd (car (##sys#slot t 11))))
- (set! ##sys#fd-list
- (let loop ((lst ##sys#fd-list))
- (if (null? lst)
- '()
- (let* ((a (car lst))
- (fd2 (car a)) )
- (if (eq? fd fd2)
- (let ((ts (##sys#delq t (cdr a)))) ; remove from fd-list entry
- (cond ((null? ts) (cdr lst))
- (else
- (##sys#setslot a 1 ts) ; fd-list entry is list with t removed
- lst) ) )
- (cons a (loop (cdr lst)))))))))))
-
-
;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
;
; (contributed by Joerg Wittenberger)
@@ -565,6 +540,34 @@ EOF
(set! ##sys#fd-list (##sys#slot vec 2))
(set! ##sys#timeout-list (##sys#slot vec 3)) )
+;;; Clear blocking queues
+
+(define (##sys#thread-clear-blocking-state! t)
+ (let ((blocked (##sys#slot t 11))) ; (FD . RWFLAGS) | #<MUTEX> | #<THREAD>
+ (dbg "clear-blocking " t " from " blocked)
+ (cond
+ ((pair? blocked)
+ (let ((fd (car (##sys#slot t 11))))
+ (set! ##sys#fd-list
+ (let loop ((lst ##sys#fd-list))
+ (if (null? lst)
+ '()
+ (let* ((a (car lst))
+ (fd2 (car a)) )
+ (if (eq? fd fd2)
+ (let ((ts (##sys#delq t (cdr a)))) ; remove from fd-list entry
+ (cond ((null? ts) (cdr lst))
+ (else
+ (##sys#setslot a 1 ts) ; fd-list entry is list with t removed
+ lst) ) )
+ (cons a (loop (cdr lst))))))))))
+ ((##sys#structure? blocked 'condition-variable)
+ (##sys#setslot blocked 2 (##sys#delq t (##sys#slot blocked 2))))
+ ((##sys#structure? blocked 'mutex)
+ (##sys#setslot blocked 3 (##sys#delq t (##sys#slot blocked 3))))
+ ((##sys#structure? blocked 'thread)
+ (##sys#setslot blocked 12 (##sys#delq t (##sys#slot blocked 12)))))
+ (##sys#setislot t 11 #f)))
;;; Unblock thread cleanly:
@@ -572,10 +575,9 @@ EOF
(when (or (eq? 'blocked (##sys#slot t 3))
(eq? 'sleeping (##sys#slot t 3)))
(##sys#remove-from-timeout-list t)
- (##sys#clear-i/o-state-for-thread! t)
+ (##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t) ) )
-
;;; Kill all threads in fd-, io- and timeout-lists and assign one thread as the
; new primordial one. Overrides "##sys#kill-other-threads" in library.scm.
--
2.11.0
From aae2f95d0452ce7908eb281bbde90b22b8329429 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Tue, 18 Dec 2018 15:46:46 +0100
Subject: [PATCH 3/4] Add test case for properly abondons of mutexs.
---
tests/mutex-test.scm | 38 ++++++++++++++++++++++++++++++++++++++
1 file changed, 38 insertions(+)
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 738e73d3..035d7092 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -86,6 +86,27 @@ Slot Type Meaning
(test-error "thread still held in mutex after unlock: " mux1))
;;============
+(let* ((cv (make-condition-variable))
+ (m (begin
+ (condition-variable-specific-set! cv #f)
+ (make-mutex)))
+ (t (thread-start!
+ (lambda ()
+ (do ()
+ ((condition-variable-specific cv))
+ (mutex-unlock! m cv))))))
+ (thread-yield!)
+ (when
+ (not (eq? (##sys#slot t 3) 'sleeping))
+ (test-error "thread not sleeping " t))
+ (condition-variable-specific-set! cv #t)
+ (condition-variable-signal! cv)
+ (thread-yield!)
+ (when
+ (not (eq? (##sys#slot t 3) 'dead))
+ (test-error "thread not completed " t)))
+
+;;============
; Make a locked mutex
(define mux (make-mutex 'foo))
(mutex-lock! mux #f #f)
@@ -131,6 +152,23 @@ Slot Type Meaning
(print "Abandoned Mutex not abandoned " mux "\n")
(test-exit 1))
+(unless (eq? (mutex-state mux) (current-thread))
+ (print "Mutex " mux " locked/not-owned but left in state " (mutex-state mux) "\n")
+ (test-exit 1))
+
+;; repeat with owned mutex
+(set! mux (make-mutex 'foobar))
+(thread-start! (lambda () (mutex-lock! mux)))
+(thread-yield!)
+
+(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux) #f)))
+ (print "Abandoned Mutex not abandoned " mux "\n")
+ (test-exit 1))
+
+(unless (eq? (mutex-state mux) (current-thread))
+ (print "Mutex " mux " not assigned to " (current-thread) " but left in state " (mutex-state mux) "\n")
+ (test-exit 1))
+
(mutex-unlock! mux)
(mutex-lock! mux)
--
2.11.0
From a062862de2acbaf4059f4898971a5285099d7211 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Tue, 18 Dec 2018 22:40:34 +0100
Subject: [PATCH 4/4] Change abandoned mutexs state according to srfi-18.
Also some cleanup prefering ##sys#thread-unblock! when appropriate.
---
scheduler.scm | 53 +++++++++++++++------------
srfi-18.scm | 113 ++++++++++++++++++++--------------------------------------
2 files changed, 69 insertions(+), 97 deletions(-)
diff --git a/scheduler.scm b/scheduler.scm
index c4b79f46..de008a1d 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -185,6 +185,7 @@ EOF
(if (fp>= now tmo1) ; timeout reached?
(begin
(##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
+ (##sys#setislot tto 4 #f) ; clear timeout
(##sys#thread-clear-blocking-state! tto)
(##sys#thread-basic-unblock! tto)
(loop (cdr lst)) )
@@ -277,16 +278,20 @@ EOF
(define ##sys#timeout-list '())
(define (##sys#remove-from-timeout-list t)
- (let loop ((l ##sys#timeout-list) (prev #f))
- (if (null? l)
- l
- (let ((h (##sys#slot l 0))
- (r (##sys#slot l 1)))
- (if (eq? (##sys#slot h 1) t)
- (if prev
- (set-cdr! prev r)
- (set! ##sys#timeout-list r))
- (loop r l))))))
+ (define (removeit t)
+ (let loop ((l ##sys#timeout-list) (prev #f))
+ (if (null? l)
+ l
+ (let ((h (##sys#slot l 0))
+ (r (##sys#slot l 1)))
+ (if (eq? (##sys#slot h 1) t)
+ (if prev
+ (set-cdr! prev r)
+ (set! ##sys#timeout-list r))
+ (loop r l))))))
+ (when (##sys#slot t 4) ;; no need to walk the queue without timeout
+ (removeit t)
+ (##sys#setislot t 4 #f))) ;; keep queue and thread state lexically in sync
(define (##sys#thread-block-for-timeout! t tm)
(dbg t " blocks for timeout " tm)
@@ -351,11 +356,12 @@ EOF
(define (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
- (##sys#setslot t 11 #f) ;; still require from condition-variable-*!
- #;(if (##sys#slot t 11) ;; remove this case after testing
- (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unclean unblock"
+ (if (##sys#slot t 11) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with block object"
+ (##sys#slot t 11)))
+ (if (##sys#slot t 4) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with timeout"
(##sys#slot t 11)))
- (##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
(define (##sys#default-exception-handler arg)
@@ -482,16 +488,14 @@ EOF
((not (pair? p)) ; not blocked for I/O?
;; thread on fd-list is not blocked for I/O - this
;; is incorrect but will be ignored, just let it run
- (when (##sys#slot t 4) ; also blocked for timeout?
- (##sys#remove-from-timeout-list t))
+ (##sys#remove-from-timeout-list t) ; also blocked for timeout?
(##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
((not (eq? fd (car p)))
(panic (sprintf "thread is registered for I/O on unknown file-descriptor: ~S (expected ~S)" (car p) fd)))
((fdset-test inf outf (cdr p))
- (when (##sys#slot t 4) ; also blocked for timeout?
- (##sys#remove-from-timeout-list t))
+ (##sys#remove-from-timeout-list t)
(##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
@@ -572,12 +576,15 @@ EOF
;;; Unblock thread cleanly:
+;;(: ##sys#thread-unblock! ((struct thread) -> boolean))
(define (##sys#thread-unblock! t)
- (when (or (eq? 'blocked (##sys#slot t 3))
- (eq? 'sleeping (##sys#slot t 3)))
- (##sys#remove-from-timeout-list t)
- (##sys#thread-clear-blocking-state! t)
- (##sys#thread-basic-unblock! t) ) )
+ (and (let ((ts (##sys#slot t 3)))
+ (or (eq? 'blocked ts) (eq? 'sleeping ts)))
+ (begin
+ (##sys#remove-from-timeout-list t)
+ (##sys#thread-clear-blocking-state! t)
+ (##sys#thread-basic-unblock! t)
+ #t) ) )
;;; Kill all threads in fd-, io- and timeout-lists and assign one thread as the
; new primordial one. Overrides "##sys#kill-other-threads" in library.scm.
diff --git a/srfi-18.scm b/srfi-18.scm
index 5d5c5305..dbb572bb 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -174,8 +174,6 @@
(lambda ()
(case (##sys#slot thread 3)
((dead)
- (unless (##sys#slot ct 13) ; not unblocked by timeout
- (##sys#remove-from-timeout-list ct))
(apply return (##sys#slot thread 2)))
((terminated)
(return
@@ -271,7 +269,7 @@
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
(##sys#call-with-current-continuation
(lambda (return)
- (let ([ct ##sys#current-thread])
+ (let ((ct ##sys#current-thread))
(define (switch)
(dbg ct " sleeping on mutex " (mutex-name mutex))
(##sys#setslot ct 11 mutex)
@@ -281,25 +279,26 @@
(when (##sys#slot mutex 4) ; abandoned
(return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
(define (assign)
- (##sys#setislot ct 11 #f)
- (check)
- (if (and threadsup (not thread))
- (begin
- (##sys#setislot mutex 2 #f)
- (##sys#setislot mutex 5 #t) )
- (let* ([t (or thread ct)]
- [ts (##sys#slot t 3)] )
- (if (or (eq? 'terminated ts) (eq? 'dead ts))
- (begin
- (##sys#setislot mutex 2 #f)
- (##sys#setislot mutex 5 #f)
- (##sys#setislot mutex 4 #t)
- (check))
- (begin
- (##sys#setslot mutex 2 t)
- (##sys#setislot mutex 5 #t)
- (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
- (return #t))
+ (let ((abd (##sys#slot mutex 4)))
+ (if (and threadsup (not thread))
+ (begin
+ (##sys#setislot mutex 2 #f)
+ (##sys#setislot mutex 5 #t) )
+ (let* ([t (or thread ct)]
+ [ts (##sys#slot t 3)] )
+ (if (or (eq? 'terminated ts) (eq? 'dead ts))
+ (begin
+ (##sys#setislot mutex 2 #f)
+ (##sys#setislot mutex 5 #f)
+ (##sys#setislot mutex 4 #t))
+ (begin
+ (##sys#setslot mutex 2 t)
+ (##sys#setislot mutex 5 #t)
+ (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
+ (return
+ (if abd
+ (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))
+ #t))))
(dbg ct ": locking " mutex)
(cond [(not (##sys#slot mutex 5))
(assign) ]
@@ -309,13 +308,8 @@
ct 1
(lambda ()
(if (##sys#slot ct 13) ; unblocked by timeout
- (begin
- (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3)))
- (##sys#setislot ct 11 #f)
- (return #f))
- (begin
- (##sys#remove-from-timeout-list ct)
- (assign))) ))
+ (return #f)
+ (assign)) ))
(##sys#thread-block-for-timeout! ct limit)
(switch) ]
[else
@@ -326,16 +320,16 @@
(define mutex-unlock!
(lambda (mutex . cvar-and-to)
(##sys#check-structure mutex 'mutex 'mutex-unlock!)
- (let ([ct ##sys#current-thread]
- [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
- [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
+ (let ((ct ##sys#current-thread)
+ (cvar (and (pair? cvar-and-to) (car cvar-and-to)))
+ (timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))) )
(dbg ct ": unlocking " (mutex-name mutex))
(when cvar
(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
(##sys#call-with-current-continuation
(lambda (return)
- (let ([waiting (##sys#slot mutex 3)]
- [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
+ (let ((waiting (##sys#slot mutex 3))
+ (limit (and timeout (compute-time-limit timeout 'mutex-unlock!))) )
(##sys#setislot mutex 4 #f) ; abandoned
(##sys#setislot mutex 5 #f) ; blocked
(let ((t (##sys#slot mutex 2)))
@@ -348,31 +342,16 @@
(cond (limit
(##sys#setslot
ct 1
- (lambda ()
- (##sys#setislot ct 11 #f)
- (if (##sys#slot ct 13) ; unblocked by timeout
- (begin
- (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2)))
- (return #f))
- (begin
- (##sys#remove-from-timeout-list ct)
- (return #t))) ) )
+ (lambda () (return (not (##sys#slot ct 13))) ) )
(##sys#thread-block-for-timeout! ct limit) )
(else
(##sys#setslot ct 1 (lambda () (return #t)))
(##sys#setslot ct 3 'sleeping)) ) )
(unless (null? waiting)
- (let* ((wt (##sys#slot waiting 0))
- (wts (##sys#slot wt 3)) )
- (##sys#setslot mutex 3 (##sys#slot waiting 1))
- (##sys#setislot mutex 5 #t)
- (case wts
- ((blocked sleeping)
- (##sys#setslot wt 11 #f)
- (##sys#add-to-ready-queue wt))
- (else
- (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state"
- wt wts))) ) )
+ (let ((wt (##sys#slot waiting 0)))
+ (or (##sys#thread-unblock! wt)
+ (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state"
+ wt (##sys#slot wt 3)))))
(if (eq? (##sys#slot ct 3) 'running)
(return #t)
(##sys#schedule)) ) ) ) ) ))
@@ -407,24 +386,18 @@
(define (condition-variable-signal! cvar)
(##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
(dbg "signalling " cvar)
- (let ([ts (##sys#slot cvar 2)])
- (unless (null? ts)
- (let* ([t0 (##sys#slot ts 0)]
- [t0s (##sys#slot t0 3)] )
- (##sys#setslot cvar 2 (##sys#slot ts 1))
- (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
- (##sys#thread-basic-unblock! t0) ) ) ) ) )
+ (let ((ts (##sys#slot cvar 2)))
+ (unless (null? ts) (##sys#thread-unblock! (##sys#slot ts 0)) ) ) )
(define (condition-variable-broadcast! cvar)
(##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
(dbg "broadcasting " cvar)
(##sys#for-each
(lambda (ti)
- (let ([tis (##sys#slot ti 3)])
+ (let ((tis (##sys#slot ti 3)))
(when (or (eq? tis 'blocked) (eq? tis 'sleeping))
- (##sys#thread-basic-unblock! ti) ) ) )
- (##sys#slot cvar 2) )
- (##sys#setislot cvar 2 '()) )
+ (##sys#thread-unblock! ti) ) ) )
+ (##sys#slot cvar 2) ) )
;;; Change continuation of thread to signal an exception:
@@ -434,15 +407,7 @@
(dbg "signal " thread exn)
(if (eq? thread ##sys#current-thread)
(##sys#signal exn)
- (let ([old (##sys#slot thread 1)]
- [blocked (##sys#slot thread 11)])
- (cond
- ((##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#structure? blocked 'thread)
- (##sys#setslot blocked 12 (##sys#delq thread (##sys#slot blocked 12)))))
+ (let ((old (##sys#slot thread 1)))
(##sys#setslot
thread 1
(lambda ()
--
2.11.0
From 307e9d806f421bd13e4b6f30a8cdb86378b8c1dd Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Mon, 3 Dec 2018 22:22:05 +0100
Subject: [PATCH] Fix 1564 internal scheduler error.
---
scheduler.scm | 79 +++++++++++++++++++++++++++++++----------------------------
1 file changed, 41 insertions(+), 38 deletions(-)
diff --git a/scheduler.scm b/scheduler.scm
index 238c348e..32c2743c 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -35,7 +35,7 @@
;; This isn't hidden ATM to allow set!ing it as a hook/workaround
; ##sys#force-primordial
remove-from-ready-queue fdset-test create-fdset stderr delq
- ##sys#clear-i/o-state-for-thread! ##sys#abandon-mutexes)
+ ##sys#thread-clear-blocking-state! ##sys#abandon-mutexes)
(not inline chicken.base#sleep-hook ##sys#interrupt-hook ##sys#force-primordial)
(unsafe)
(foreign-declare #<<EOF
@@ -197,7 +197,7 @@ EOF
(if (>= now tmo1) ; timeout reached?
(begin
(##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
- (##sys#clear-i/o-state-for-thread! tto)
+ (##sys#thread-clear-blocking-state! tto)
(##sys#thread-basic-unblock! tto)
(loop (cdr lst)) )
(begin
@@ -343,17 +343,9 @@ EOF
(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 (delq t (##sys#slot blocked 2))))
- ((##sys#structure? blocked 'thread)
- (##sys#setslot blocked 12 (delq t (##sys#slot blocked 12))))) )
(##sys#remove-from-timeout-list t)
- (##sys#clear-i/o-state-for-thread! t)
+ (##sys#thread-clear-blocking-state! t)
(##sys#setslot t 3 s)
- (##sys#setislot t 4 #f)
- (##sys#setislot t 11 #f)
(##sys#setislot t 8 '())
(let ((rs (##sys#slot t 12)))
(unless (null? rs)
@@ -361,13 +353,15 @@ EOF
(lambda (t2)
(dbg " checking: " t2 " (" (##sys#slot t2 3) ") -> " (##sys#slot t2 11))
(when (eq? (##sys#slot t2 11) t)
- (##sys#thread-basic-unblock! t2) ) )
- rs) ) )
- (##sys#setislot t 12 '()) )
+ (##sys#thread-unblock! t2) ) )
+ rs)
+ (##sys#setislot t 12 '()) ) ) )
(define (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
- (##sys#setislot t 11 #f) ; (FD . RWFLAGS) | #<MUTEX> | #<THREAD>
+ #;(if (##sys#slot t 11) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unclean unblock"
+ (##sys#slot t 11)))
(##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
@@ -498,39 +492,20 @@ EOF
;; is incorrect but will be ignored, just let it run
(when (##sys#slot t 4) ; also blocked for timeout?
(##sys#remove-from-timeout-list t))
- (##sys#thread-basic-unblock! t)
+ (##sys#thread-clear-blocking-state! t)
+ (##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
((not (eq? fd (car p)))
(panic (sprintf "thread is registered for I/O on unknown file-descriptor: ~S (expected ~S)" (car p) fd)))
((fdset-test inf outf (cdr p))
(when (##sys#slot t 4) ; also blocked for timeout?
(##sys#remove-from-timeout-list t))
+ (##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
(else (loop2 (cdr threads) (cons t keep)))))))
(cons a (loop n (add1 pos) (cdr lst))) ) ) ) ) ) ] ))) )
-
-;;; Clear I/O state for unblocked thread
-
-(define (##sys#clear-i/o-state-for-thread! t)
- (when (pair? (##sys#slot t 11))
- (let ((fd (car (##sys#slot t 11))))
- (set! ##sys#fd-list
- (let loop ((lst ##sys#fd-list))
- (if (null? lst)
- '()
- (let* ((a (car lst))
- (fd2 (car a)) )
- (if (eq? fd fd2)
- (let ((ts (delq t (cdr a)))) ; remove from fd-list entry
- (cond ((null? ts) (cdr lst))
- (else
- (##sys#setslot a 1 ts) ; fd-list entry is list with t removed
- lst) ) )
- (cons a (loop (cdr lst)))))))))))
-
-
;;; Get list of all threads that are ready or waiting for timeout or waiting for I/O:
;
; (contributed by Joerg Wittenberger)
@@ -574,6 +549,34 @@ EOF
(set! ##sys#fd-list (##sys#slot vec 2))
(set! ##sys#timeout-list (##sys#slot vec 3)) )
+;;; Clear blocking queues
+
+(define (##sys#thread-clear-blocking-state! t)
+ (let ((blocked (##sys#slot t 11))) ; (FD . RWFLAGS) | #<MUTEX> | #<THREAD>
+ (dbg "clear-blocking " t " from " blocked)
+ (cond
+ ((pair? blocked)
+ (let ((fd (car (##sys#slot t 11))))
+ (set! ##sys#fd-list
+ (let loop ((lst ##sys#fd-list))
+ (if (null? lst)
+ '()
+ (let* ((a (car lst))
+ (fd2 (car a)) )
+ (if (eq? fd fd2)
+ (let ((ts (delq t (cdr a)))) ; remove from fd-list entry
+ (cond ((null? ts) (cdr lst))
+ (else
+ (##sys#setslot a 1 ts) ; fd-list entry is list with t removed
+ lst) ) )
+ (cons a (loop (cdr lst))))))))))
+ ((##sys#structure? blocked 'condition-variable)
+ (##sys#setslot blocked 2 (delq t (##sys#slot blocked 2))))
+ ((##sys#structure? blocked 'mutex)
+ (##sys#setslot blocked 3 (delq t (##sys#slot blocked 3))))
+ ((##sys#structure? blocked 'thread)
+ (##sys#setslot blocked 12 (delq t (##sys#slot blocked 12)))))
+ (##sys#setislot t 11 #f)))
;;; Unblock thread cleanly:
@@ -581,7 +584,7 @@ EOF
(when (or (eq? 'blocked (##sys#slot t 3))
(eq? 'sleeping (##sys#slot t 3)))
(##sys#remove-from-timeout-list t)
- (##sys#clear-i/o-state-for-thread! t)
+ (##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t) ) )
--
2.11.0
From 5da7a55bacfc6b1597eb4c5126005536aa3d0801 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Wed, 19 Dec 2018 12:47:28 +0100
Subject: [PATCH 2/2] Modifiy internals to line up with fixes in srfi-18.
---
scheduler.scm | 53 ++++++++++++++++++++++++++++++-----------------------
1 file changed, 30 insertions(+), 23 deletions(-)
diff --git a/scheduler.scm b/scheduler.scm
index 32c2743c..df4db928 100644
--- a/scheduler.scm
+++ b/scheduler.scm
@@ -197,6 +197,7 @@ EOF
(if (>= now tmo1) ; timeout reached?
(begin
(##sys#setislot tto 13 #t) ; mark as being unblocked by timeout
+ (##sys#setislot tto 4 #f) ; clear timeout
(##sys#thread-clear-blocking-state! tto)
(##sys#thread-basic-unblock! tto)
(loop (cdr lst)) )
@@ -288,16 +289,20 @@ EOF
(define ##sys#timeout-list '())
(define (##sys#remove-from-timeout-list t)
- (let loop ((l ##sys#timeout-list) (prev #f))
- (if (null? l)
- l
- (let ((h (##sys#slot l 0))
- (r (##sys#slot l 1)))
- (if (eq? (##sys#slot h 1) t)
- (if prev
- (set-cdr! prev r)
- (set! ##sys#timeout-list r))
- (loop r l))))))
+ (define (removeit t)
+ (let loop ((l ##sys#timeout-list) (prev #f))
+ (if (null? l)
+ l
+ (let ((h (##sys#slot l 0))
+ (r (##sys#slot l 1)))
+ (if (eq? (##sys#slot h 1) t)
+ (if prev
+ (set-cdr! prev r)
+ (set! ##sys#timeout-list r))
+ (loop r l))))))
+ (when (##sys#slot t 4) ;; no need to walk the queue without timeout
+ (removeit t)
+ (##sys#setislot t 4 #f))) ;; keep queue and thread state lexically in sync
(define (##sys#thread-block-for-timeout! t tm)
(dbg t " blocks for timeout " tm)
@@ -359,10 +364,12 @@ EOF
(define (##sys#thread-basic-unblock! t)
(dbg "unblocking: " t)
- #;(if (##sys#slot t 11) ;; remove this case after testing
- (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unclean unblock"
+ (if (##sys#slot t 11) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with block object"
+ (##sys#slot t 11)))
+ (if (##sys#slot t 4) ;; remove this case after testing
+ (##sys#error '##sys#thread-basic-unblock! "Internal scheduler error: unblock with timeout"
(##sys#slot t 11)))
- (##sys#setislot t 4 #f)
(##sys#add-to-ready-queue t) )
(define (##sys#default-exception-handler arg)
@@ -490,16 +497,14 @@ EOF
((not (pair? p)) ; not blocked for I/O?
;; thread on fd-list is not blocked for I/O - this
;; is incorrect but will be ignored, just let it run
- (when (##sys#slot t 4) ; also blocked for timeout?
- (##sys#remove-from-timeout-list t))
+ (##sys#remove-from-timeout-list t) ; also blocked for timeout?
(##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
((not (eq? fd (car p)))
(panic (sprintf "thread is registered for I/O on unknown file-descriptor: ~S (expected ~S)" (car p) fd)))
((fdset-test inf outf (cdr p))
- (when (##sys#slot t 4) ; also blocked for timeout?
- (##sys#remove-from-timeout-list t))
+ (##sys#remove-from-timeout-list t)
(##sys#thread-clear-blocking-state! t)
(##sys#thread-basic-unblock! t)
(loop2 (cdr threads) keep))
@@ -580,13 +585,15 @@ EOF
;;; Unblock thread cleanly:
+;;(: ##sys#thread-unblock! ((struct thread) -> boolean))
(define (##sys#thread-unblock! t)
- (when (or (eq? 'blocked (##sys#slot t 3))
- (eq? 'sleeping (##sys#slot t 3)))
- (##sys#remove-from-timeout-list t)
- (##sys#thread-clear-blocking-state! t)
- (##sys#thread-basic-unblock! t) ) )
-
+ (and (let ((ts (##sys#slot t 3)))
+ (or (eq? 'blocked ts) (eq? 'sleeping ts)))
+ (begin
+ (##sys#remove-from-timeout-list t)
+ (##sys#thread-clear-blocking-state! t)
+ (##sys#thread-basic-unblock! t)
+ #t) ) )
;;; Put a thread to sleep:
--
2.11.0
From 9e66180733588860a32db479d2283b4d73d598ab Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Wed, 19 Dec 2018 12:24:29 +0100
Subject: [PATCH 1/2] Add test cases and make test effective.
---
tests/mutex-test.scm | 63 ++++++++++++++++++++++++++++++++++++++++++++++++++++
1 file changed, 63 insertions(+)
diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm
index 9c7f1e6..d052abb 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -57,6 +57,29 @@ Slot Type Meaning
(print "Got " mux1 " state " (mutex-state mux1) " expected " owner1 "\n")
(test-exit 1)))))
+(let ((m1 (make-mutex)))
+ ;; This fails if we manage to sort primorial before t1 and unleash
+ ;; both in one turn.
+ (define (sys-thread-sleep! limit)
+ ;; a copy from srfi-18 which expects pre-computed goal time.
+ (##sys#call-with-current-continuation
+ (lambda (return)
+ (let ((ct ##sys#current-thread))
+ (##sys#setslot ct 1 (lambda () (return (##core#undefined))))
+ (##sys#thread-block-for-timeout! ct limit)
+ (##sys#schedule) ) ) ) )
+ #;(print "mutex state changes atomically wrt. blocking queues")
+ (mutex-lock! m1)
+ (let ((t1 (thread-start! (lambda () (mutex-lock! m1 0.1)))))
+ #;(print "have t1 it wait for m1")
+ (thread-yield!)
+ (let* ((to (##sys#slot t1 4))
+ (hit (- to 0.0001)))
+ #;(print "waiting ever so slightly less than to " to " i.e. " hit "\n")
+ (sys-thread-sleep! hit))
+ ;; catch inconsistent state
+ (mutex-unlock! m1)))
+
(set! mux1 (make-mutex 'unlock-leaves-no-memory-leak))
(mutex-lock! mux1)
(mutex-unlock! mux1)
@@ -65,6 +88,27 @@ Slot Type Meaning
(test-error "thread still held in mutex after unlock: " mux1))
;;============
+(let* ((cv (make-condition-variable))
+ (m (begin
+ (condition-variable-specific-set! cv #f)
+ (make-mutex)))
+ (t (thread-start!
+ (lambda ()
+ (do ()
+ ((condition-variable-specific cv))
+ (mutex-unlock! m cv))))))
+ (thread-yield!)
+ (when
+ (not (eq? (##sys#slot t 3) 'sleeping))
+ (test-error "thread not sleeping " t))
+ (condition-variable-specific-set! cv #t)
+ (condition-variable-signal! cv)
+ (thread-yield!)
+ (when
+ (not (eq? (##sys#slot t 3) 'dead))
+ (test-error "thread not completed " t)))
+
+;;============
; Make a locked mutex
(define mux (make-mutex 'foo))
(mutex-lock! mux #f #f)
@@ -110,6 +154,23 @@ Slot Type Meaning
(print "Abandoned Mutex not abandoned " mux "\n")
(test-exit 1))
+(unless (eq? (mutex-state mux) (current-thread))
+ (print "Mutex " mux " locked/not-owned but left in state " (mutex-state mux) "\n")
+ (test-exit 1))
+
+;; repeat with owned mutex
+(set! mux (make-mutex 'foobar))
+(thread-start! (lambda () (mutex-lock! mux)))
+(thread-yield!)
+
+(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux) #f)))
+ (print "Abandoned Mutex not abandoned " mux "\n")
+ (test-exit 1))
+
+(unless (eq? (mutex-state mux) (current-thread))
+ (print "Mutex " mux " not assigned to " (current-thread) " but left in state " (mutex-state mux) "\n")
+ (test-exit 1))
+
(mutex-unlock! mux)
(mutex-lock! mux)
@@ -189,3 +250,5 @@ Slot Type Meaning
(thread-sleep! 3)
;(tprint 'exit)
+
+(if test-has-failed (exit 1) (exit 0))
--
2.11.0
From 1ab69bf17fe620addf4fbbc4f3fae695df243b84 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Wed, 19 Dec 2018 12:51:44 +0100
Subject: [PATCH 2/2] Change abandoned mutexs state according to srfi-18.
Also some cleanup prefering ##sys#thread-unblock! when appropriate.
---
srfi-18.scm | 117 +++++++++++++++++++++---------------------------------------
1 file changed, 41 insertions(+), 76 deletions(-)
diff --git a/srfi-18.scm b/srfi-18.scm
index f6253f1..28d3cd9 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -1,6 +1,6 @@
;;;; srfi-18.scm - Simple thread unit - felix
;
-; Copyright (c) 2008-2016, The Chicken Team
+; Copyright (c) 2008-2018, The Chicken Team
; Copyright (c) 2000-2007, Felix L. Winkelmann
; All rights reserved.
;
@@ -231,8 +231,6 @@
(lambda ()
(case (##sys#slot thread 3)
((dead)
- (unless (##sys#slot ct 13) ; not unblocked by timeout
- (##sys#remove-from-timeout-list ct))
(apply return (##sys#slot thread 2)))
((terminated)
(return
@@ -321,7 +319,7 @@
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
(##sys#call-with-current-continuation
(lambda (return)
- (let ([ct ##sys#current-thread])
+ (let ((ct ##sys#current-thread))
(define (switch)
(dbg ct " sleeping on mutex " (mutex-name mutex))
(##sys#setslot ct 11 mutex)
@@ -331,25 +329,26 @@
(when (##sys#slot mutex 4) ; abandoned
(return (signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1)))))))
(define (assign)
- (##sys#setislot ct 11 #f)
- (check)
- (if (and threadsup (not thread))
- (begin
- (##sys#setislot mutex 2 #f)
- (##sys#setislot mutex 5 #t) )
- (let* ([t (or thread ct)]
- [ts (##sys#slot t 3)] )
- (if (or (eq? 'terminated ts) (eq? 'dead ts))
- (begin
- (##sys#setislot mutex 2 #f)
- (##sys#setislot mutex 5 #f)
- (##sys#setislot mutex 4 #t)
- (check))
- (begin
- (##sys#setslot mutex 2 t)
- (##sys#setislot mutex 5 #t)
- (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
- (return #t))
+ (let ((abd (##sys#slot mutex 4)))
+ (if (and threadsup (not thread))
+ (begin
+ (##sys#setislot mutex 2 #f)
+ (##sys#setislot mutex 5 #t) )
+ (let* ([t (or thread ct)]
+ [ts (##sys#slot t 3)] )
+ (if (or (eq? 'terminated ts) (eq? 'dead ts))
+ (begin
+ (##sys#setislot mutex 2 #f)
+ (##sys#setislot mutex 5 #f)
+ (##sys#setislot mutex 4 #t))
+ (begin
+ (##sys#setslot mutex 2 t)
+ (##sys#setislot mutex 5 #t)
+ (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) )
+ (return
+ (if abd
+ (signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))
+ #t))))
(dbg ct ": locking " mutex)
(cond [(not (##sys#slot mutex 5))
(assign) ]
@@ -359,13 +358,8 @@
ct 1
(lambda ()
(if (##sys#slot ct 13) ; unblocked by timeout
- (begin
- (##sys#setslot mutex 3 (delq ct (##sys#slot mutex 3)))
- (##sys#setislot ct 11 #f)
- (return #f))
- (begin
- (##sys#remove-from-timeout-list ct)
- (assign))) ))
+ (return #f)
+ (assign)) ))
(##sys#thread-block-for-timeout! ct limit)
(switch) ]
[else
@@ -376,16 +370,16 @@
(define mutex-unlock!
(lambda (mutex . cvar-and-to)
(##sys#check-structure mutex 'mutex 'mutex-unlock!)
- (let ([ct ##sys#current-thread]
- [cvar (and (pair? cvar-and-to) (car cvar-and-to))]
- [timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
+ (let ((ct ##sys#current-thread)
+ (cvar (and (pair? cvar-and-to) (car cvar-and-to)))
+ (timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))) )
(dbg ct ": unlocking " (mutex-name mutex))
(when cvar
(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
(##sys#call-with-current-continuation
(lambda (return)
- (let ([waiting (##sys#slot mutex 3)]
- [limit (and timeout (compute-time-limit timeout 'mutex-unlock!))] )
+ (let ((waiting (##sys#slot mutex 3))
+ (limit (and timeout (compute-time-limit timeout 'mutex-unlock!))) )
(##sys#setislot mutex 4 #f) ; abandoned
(##sys#setislot mutex 5 #f) ; blocked
(let ((t (##sys#slot mutex 2)))
@@ -398,31 +392,16 @@
(cond (limit
(##sys#setslot
ct 1
- (lambda ()
- (##sys#setislot ct 11 #f)
- (if (##sys#slot ct 13) ; unblocked by timeout
- (begin
- (##sys#setslot cvar 2 (delq ct (##sys#slot cvar 2)))
- (return #f))
- (begin
- (##sys#remove-from-timeout-list ct)
- (return #t))) ) )
+ (lambda () (return (not (##sys#slot ct 13))) ) )
(##sys#thread-block-for-timeout! ct limit) )
(else
(##sys#setslot ct 1 (lambda () (return #t)))
(##sys#setslot ct 3 'sleeping)) ) )
(unless (null? waiting)
- (let* ((wt (##sys#slot waiting 0))
- (wts (##sys#slot wt 3)) )
- (##sys#setslot mutex 3 (##sys#slot waiting 1))
- (##sys#setislot mutex 5 #t)
- (case wts
- ((blocked sleeping)
- (##sys#setslot wt 11 #f)
- (##sys#add-to-ready-queue wt))
- (else
- (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state"
- wt wts))) ) )
+ (let ((wt (##sys#slot waiting 0)))
+ (or (##sys#thread-unblock! wt)
+ (##sys#error 'mutex-unlock "Internal scheduler error: unknown thread state"
+ wt (##sys#slot wt 3)))))
(if (eq? (##sys#slot ct 3) 'running)
(return #t)
(##sys#schedule)) ) ) ) ) ))
@@ -457,24 +436,18 @@
(define (condition-variable-signal! cvar)
(##sys#check-structure cvar 'condition-variable 'condition-variable-signal!)
(dbg "signalling " cvar)
- (let ([ts (##sys#slot cvar 2)])
- (unless (null? ts)
- (let* ([t0 (##sys#slot ts 0)]
- [t0s (##sys#slot t0 3)] )
- (##sys#setslot cvar 2 (##sys#slot ts 1))
- (when (or (eq? t0s 'blocked) (eq? t0s 'sleeping))
- (##sys#thread-basic-unblock! t0) ) ) ) ) )
+ (let ((ts (##sys#slot cvar 2)))
+ (unless (null? ts) (##sys#thread-unblock! (##sys#slot ts 0)) ) ) )
(define (condition-variable-broadcast! cvar)
(##sys#check-structure cvar 'condition-variable 'condition-variable-broadcast!)
(dbg "broadcasting " cvar)
(##sys#for-each
(lambda (ti)
- (let ([tis (##sys#slot ti 3)])
+ (let ((tis (##sys#slot ti 3)))
(when (or (eq? tis 'blocked) (eq? tis 'sleeping))
- (##sys#thread-basic-unblock! ti) ) ) )
- (##sys#slot cvar 2) )
- (##sys#setislot cvar 2 '()) )
+ (##sys#thread-unblock! ti) ) ) )
+ (##sys#slot cvar 2) ) )
;;; Change continuation of thread to signal an exception:
@@ -483,16 +456,8 @@
(##sys#check-structure thread 'thread 'thread-signal!)
(dbg "signal " thread exn)
(if (eq? thread ##sys#current-thread)
- (signal exn)
- (let ([old (##sys#slot thread 1)]
- [blocked (##sys#slot thread 11)])
- (cond
- ((##sys#structure? blocked 'condition-variable)
- (##sys#setslot blocked 2 (delq thread (##sys#slot blocked 2))))
- ((##sys#structure? blocked 'mutex)
- (##sys#setslot blocked 3 (delq thread (##sys#slot blocked 3))))
- ((##sys#structure? blocked 'thread)
- (##sys#setslot blocked 12 (delq thread (##sys#slot blocked 12)))))
+ (##sys#signal exn)
+ (let ((old (##sys#slot thread 1)))
(##sys#setslot
thread 1
(lambda ()
--
2.11.0
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
