Hi all,
attached a fresh patch. Fixes actually three bugs, adds tests for all
of them.
Again: please take on it. Those bugs bite me all day (including some
eggs tests and probably even implementations fail).
Best
/Jörg
Am 23.01.2016 um 13:19 schrieb Peter Bex:
> 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 cfc4f0515c0998f0f069d75dc53f097fe8cfd4cb Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
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 "<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))
--
2.6.2
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
