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 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 #<= 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