~ chicken-core (chicken-5) 7fcb9fe2fd0129143f04b5462b996d3559000464
commit 7fcb9fe2fd0129143f04b5462b996d3559000464
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Wed Feb 10 15:21:01 2016 +0100
Commit: Peter Bex <peter@more-magic.net>
CommitDate: Sun Feb 14 14:52:01 2016 +0100
Fix for ticket 1231 Fix removal of owner from mutex when mutex-lock! with timeout fails. Fix memory leak in mutex-unlock! More tests.
Patch originally by Joerg Wittenberger
Signed-off-by: felix <felix@call-with-current-continuation.org>
Signed-off-by: Peter Bex <peter@more-magic.net>
diff --git a/NEWS b/NEWS
index fcdbe1c9..6355b984 100644
--- a/NEWS
+++ b/NEWS
@@ -28,6 +28,10 @@
- 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), not disown a mutex from owner if
+ locking fails for timeout and not keep the last thread which held
+ a mutex until the next lock (thanks to Joerg Wittenberger).
- SRFI-39: When a parameter's "guard" procedure raises an exception,
"parameterize" now correctly resets the original values of all
parameters (fixes #1227, thanks to Joo ChurlSoo).
diff --git a/srfi-18.scm b/srfi-18.scm
index 2ae489da..09888ff5 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -272,49 +272,53 @@
(let ([ct ##sys#current-thread])
(define (switch)
(dbg ct " sleeping on mutex " (mutex-name mutex))
+ (##sys#setslot ct 11 mutex)
(##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list ct)))
(##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)
+ (##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))
+ (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
+ (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))) ))
(##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 +338,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 +346,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 +360,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 8962a1ec..873e812c 100644
--- a/tests/mutex-test.scm
+++ b/tests/mutex-test.scm
@@ -1,8 +1,121 @@
;;;; mutex-test.scm
-
(require-extension srfi-18)
+(define test-has-failed #f)
+
+(define (test-error x . more)
+ (set! test-has-failed #t)
+ (apply print x more))
+
+(define (test-exit x)
+ (set! test-has-failed #t)
+ x)
+
+#| The mutex data structure.
+
+Slot Type Meaning
+1 * name
+2 (or false (struct thread)) owner
+3 (list-of (struct thread)) waiting thread
+4 boolean abandoned
+5 boolean blocked
+
+|#
+
+(define-record-printer (mutex x out)
+ (format out "<mutex ~a ~a~a ~a (owner ~a) waiting ~a>"
+ (mutex-name x)
+ (if (##sys#slot x 5) "LOCKED" "FREE")
+ (if (##sys#slot x 4) "/ABANDONED" "")
+ (mutex-state x)
+ (if (##sys#slot x 2) (##sys#slot x 2) "none")
+ (##sys#slot x 3)
+ ))
+
+(define (dbg l v)
+ (format (current-error-port) "D ~a: ~a\n" l v) v)
+
+(define mux1 (make-mutex 'test-lock-fail-with-timeout))
+
+(mutex-lock! mux1)
+
+(define owner1 (mutex-state mux1))
+
+(thread-join!
+ (thread-start!
+ (lambda ()
+ (assert (eq? (mutex-lock! mux1 0.1) #f))
+ (when
+ (memq (current-thread) (##sys#slot mux1 3))
+ (print "Got " mux1 " found this thread still waiting!\n")
+ (test-exit 1))
+ (when
+ (not (eq? (mutex-state mux1) owner1))
+ (print "Got " mux1 " state " (mutex-state mux1) " expected " owner1 "\n")
+ (test-exit 1)))))
+
+(set! mux1 (make-mutex 'unlock-leaves-no-memory-leak))
+(mutex-lock! mux1)
+(mutex-unlock! mux1)
+(when
+ (not (eq? (##sys#slot mux1 2) #f))
+ (test-error "thread still held in mutex after unlock: " mux1))
+
+;;============
+; 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")
+ (test-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)
+ (test-error "Expected 'not-owned got " (mutex-state mux) 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")
+ (test-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")
+ (test-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")
+ (test-exit 1))
+
(cond-expand (dribble
(define-for-syntax count 0)
(define-syntax trail
@@ -74,3 +187,5 @@
(thread-sleep! 3)
;(tprint 'exit)
+
+(if test-has-failed (exit 1) (exit 0))
Trap