From 73631332650baee292f19cb89bb6329830b8c1eb 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 mutex-lock ownership when passed #f as owner. 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. Signed-off-by: Peter Bex --- NEWS | 2 ++ srfi-18.scm | 81 +++++++++++++++++++++++++++------------------------- tests/mutex-test.scm | 53 ++++++++++++++++++++++++++++++++++ 3 files changed, 97 insertions(+), 39 deletions(-) diff --git a/NEWS b/NEWS index 6abe42d..745e68b 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,8 @@ - Core libraries - SRFI-18: thread-join! no longer gives an error when passed a thread in the "sleeping" state (thanks to Joerg Wittenberger) + - SRFI-18: mutex-lock! will not set ownership of mutexes when + passed #f as the owner (#1231, thanks to Joerg Wittenberger). - Irregex has been updated to 0.9.4, which fixes severe performance problems with {n,m} repeating patterns (thanks to Caolan McMahon). 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.1.4