From 88199f5164e5f327b1d40308198e2911b3fe9cc2 Mon Sep 17 00:00:00 2001 From: felix Date: Wed, 10 Feb 2016 15:21:01 +0100 Subject: [PATCH] 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 --- NEWS | 4 ++ srfi-18.scm | 88 ++++++++++++++++++++----------------- tests/mutex-test.scm | 117 +++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 168 insertions(+), 41 deletions(-) diff --git a/NEWS b/NEWS index fcdbe1c..6355b98 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 2ae489d..09888ff 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 8962a1e..873e812 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-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)) -- 1.7.9.5