>From b517e5d75e04c96f0ea06d5ae7c322a2a3b39f4d Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?= Date: Wed, 25 Nov 2015 10:57:33 +0100 Subject: [PATCH] Fix in mutex handling. So far a thread calling (mutex-lock! #f #f) did own the mutex if, and only if, it had to wait for it. In consequence those mutexes became abandoned when the calling thread terminates, while the correct state would be locked/not-owned. --- srfi-18.scm | 81 +++++++++++++++++++++++++++------------------------- tests/mutex-test.scm | 53 ++++++++++++++++++++++++++++++++++ 2 files changed, 95 insertions(+), 39 deletions(-) diff --git a/srfi-18.scm b/srfi-18.scm index 2ae489d..e355e1f 100644 --- a/srfi-18.scm +++ b/srfi-18.scm @@ -276,45 +276,44 @@ (##sys#schedule) ) (define (check) (when (##sys#slot mutex 4) ; abandoned - (return - (##sys#signal - (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) ) - (dbg ct ": locking " (mutex-name mutex)) + (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) ) + (define (assign) + (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)) + (begin + (##sys#setslot mutex 2 t) + (##sys#setislot mutex 5 #t) + (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) ) ) ) ) + (return #t)) + (dbg ct ": locking " mutex) (cond [(not (##sys#slot mutex 5)) - (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)) - (##sys#setislot mutex 4 #t) - (begin - (##sys#setislot mutex 5 #t) - (##sys#setslot t 8 (cons mutex (##sys#slot t 8))) - (##sys#setslot t 11 mutex) - (##sys#setslot mutex 2 t) ) ) ) ) - (check) - (return #t) ] + (assign) ] [limit (check) (##sys#setslot ct 1 (lambda () - (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3))) - (unless (##sys#slot ct 13) ; not unblocked by timeout - (##sys#remove-from-timeout-list ct)) - (check) - (##sys#setslot ct 8 (cons mutex (##sys#slot ct 8))) - (##sys#setslot ct 11 #f) - (##sys#setslot mutex 2 thread) - (return #f) )) + (if (##sys#slot ct 13) ; unblocked by timeout + (return #f) + (begin + (##sys#remove-from-timeout-list ct) + (assign))) )) (##sys#thread-block-for-timeout! ct limit) (switch) ] [else (##sys#setslot ct 3 'sleeping) (##sys#setslot ct 11 mutex) - (##sys#setslot ct 1 (lambda () (check) (return #t))) + (##sys#setslot ct 1 assign) (switch) ] ) ) ) ) ) ) ) (define mutex-unlock! @@ -334,6 +333,7 @@ (##sys#setislot mutex 5 #f) ; blocked (let ((t (##sys#slot mutex 2))) (when t + (##sys#setislot mutex 2 #f) (##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ; unown from owner (when cvar (##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2) (##sys#list ct))) @@ -341,11 +341,12 @@ (cond (limit (##sys#setslot ct 1 - (lambda () - (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2))) - (##sys#setslot ct 11 #f) ; block object + (lambda () + (##sys#setislot ct 11 #f) (if (##sys#slot ct 13) ; unblocked by timeout - (return #f) + (begin + (##sys#setslot cvar 2 (##sys#delq ct (##sys#slot cvar 2))) + (return #f)) (begin (##sys#remove-from-timeout-list ct) (return #t))) ) ) @@ -354,15 +355,17 @@ (##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)] ) + (let* ((wt (##sys#slot waiting 0)) + (wts (##sys#slot wt 3)) ) (##sys#setslot mutex 3 (##sys#slot waiting 1)) (##sys#setislot mutex 5 #t) - (when (or (eq? wts 'blocked) (eq? wts 'sleeping)) - (##sys#setslot mutex 2 wt) - (##sys#setslot wt 8 (cons mutex (##sys#slot wt 8))) - (##sys#setslot wt 11 #f) - (when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) ) ) + (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))) ) ) (if (eq? (##sys#slot ct 3) 'running) (return #t) (##sys#schedule)) ) ) ) ) )) diff --git a/tests/mutex-test.scm b/tests/mutex-test.scm index 8962a1e..ed2bfa6 100644 --- a/tests/mutex-test.scm +++ b/tests/mutex-test.scm @@ -3,6 +3,59 @@ (require-extension srfi-18) +; Make a locked mutex +(define mux (make-mutex 'foo)) +(mutex-lock! mux #f #f) + +;; Have a thread waiting for it. + +(define t1 + (thread-start! + (lambda () + (mutex-lock! mux #f #f) + (when (not (eq? (mutex-state mux) 'not-owned)) + (print "Got " mux " state " (mutex-state mux) " expected " 'not-owned "\n") + (exit 1))))) + +;; Give it time to actually wait. + +(thread-yield!) + +;; Let it lock the mux + +(mutex-unlock! mux) + +(thread-yield!) + +(or (eq? (mutex-state mux) 'not-owned) + (error "Expected 'not-owned got" (mutex-state mux))) + +(set! t1 + (thread-start! + (lambda () + (mutex-lock! mux) + (when (not (eq? (mutex-state mux) (current-thread))) + (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n") + (exit 1))))) + +(mutex-unlock! mux) + +(thread-yield!) + +;; check that it is properly abandoned + +(when (not (handle-exceptions ex (abandoned-mutex-exception? ex) (and (mutex-lock! mux #f) #f))) + (print "Abandoned Mutex not abandoned " mux "\n") + (exit 1)) + +(mutex-unlock! mux) + +(mutex-lock! mux) + +(when (not (eq? (mutex-state mux) (current-thread))) + (print "Got " mux " state " (mutex-state mux) " expected " (current-thread) "\n") + (exit 1)) + (cond-expand (dribble (define-for-syntax count 0) (define-syntax trail -- 2.6.2