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