From 307e9d806f421bd13e4b6f30a8cdb86378b8c1dd Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?= 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 #<= 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) | # | # + #;(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) | # | # + (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