On Fri, Jan 22, 2016 at 07:42:09PM +0100, Jörg F. Wittenberger wrote: > Hi all, > > there is a problem I have with ticket 1231. > http://bugs.call-cc.org/ticket/1231 > > In short: I'd love to see the patch applied. (Or learn about issues it > causes.)
I hadn't forgotten about the patch, I just didn't get around to it yet, and to be honest, I don't really grok this part of the code. The patch looks good as far as I can see (but like I said, I don't 100% grok this code), and I really like the test case, which is clean and simple. The test case is what boosted my confidence in it, so I've went ahead and signed it off (with a slight reformatting and rewording of the commit message, and an update to NEWS). I've attached it. Whoever pushes this, please also apply this to the CHICKEN 5 srfi-18 egg. Cheers, Peter
From 73631332650baee292f19cb89bb6329830b8c1eb Mon Sep 17 00:00:00 2001 From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?= <[email protected]> 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! <muxtex> #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 <[email protected]> --- 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
signature.asc
Description: Digital signature
_______________________________________________ Chicken-users mailing list [email protected] https://lists.nongnu.org/mailman/listinfo/chicken-users
