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