From a062862de2acbaf4059f4898971a5285099d7211 Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?= 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