From cfc4f0515c0998f0f069d75dc53f097fe8cfd4cb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
Date: Tue, 26 Jan 2016 13:25:50 +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. --- NEWS | 4 ++ srfi-18.scm | 83 +++++++++++++++++++----------------- tests/mutex-test.scm | 117 ++++++++++++++++++++++++++++++++++++++++++++++++++- 3 files changed, 164 insertions(+), 40 deletions(-) diff --git a/NEWS b/NEWS index 401a192..4cdeedf 100644 --- a/NEWS +++ b/NEWS @@ -27,6 +27,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). - Irregex has been updated to 0.9.4, which fixes severe performance problems with {n,m} repeating patterns (thanks to Caolan McMahon). - Unit "posix": The following posix procedures now work on port diff --git a/srfi-18.scm b/srfi-18.scm index 2ae489d..5f74cfb 100644 --- a/srfi-18.scm +++ b/srfi-18.scm @@ -276,45 +276,46 @@ (##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 + (begin + (##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex 3))) + (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 +335,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 +343,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 +357,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 "