From b6837b2c94feb5f8348965f538b5a45bf01a7506 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
Date: Mon, 3 Dec 2018 21:06:26 +0100
Subject: [PATCH] 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 #<= 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) | # | #
+ #;(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) | # | #
+ (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