Hi,
try the test case:
(use 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)
(print "Got " mux " state " (mutex-state mux) "\n"))))
;; Give it time to actually wait.
(thread-sleep! 1)
;; Let it lock the mux
(mutex-unlock! mux)
(exit 0)
-----
>From my reading of srfi-18 I would expect it to print
Got #<mutex> state not-owned
but it prints
Got #<mutex> state #<thread: thread7>
With the attached patch it prints what I'd expect.
Best
/Jörg
From d5d02fe1e20c9ade17fcaf43d8ef39cdc05a0e16 Mon Sep 17 00:00:00 2001
From: =?UTF-8?q?J=C3=B6rg=20F=2E=20Wittenberger?=
<joerg.wittenber...@softeyes.net>
Date: Sat, 7 Nov 2015 21:48:56 +0100
Subject: [PATCH] Fix mutex-lock! so that (mutex-lock! <mutex> #f #f) results
in mutex-state 'not-owned as required. (Was incorrectly owned by the locking
thread, but only if the thread had to wait.)
---
srfi-18.scm | 56 +++++++++++++++++++++++++++++---------------------------
1 file changed, 29 insertions(+), 27 deletions(-)
diff --git a/srfi-18.scm b/srfi-18.scm
index 2ae489d..4e23bd4 100644
--- a/srfi-18.scm
+++ b/srfi-18.scm
@@ -276,45 +276,47 @@
(##sys#schedule) )
(define (check)
(when (##sys#slot mutex 4) ; abandoned
+ (return (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))) ) )
+ (define (assign)
+ (let ((abd (##sys#slot mutex 4)))
+ (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
- (##sys#signal
- (##sys#make-structure 'condition '(abandoned-mutex-exception) '()))) ) )
- (dbg ct ": locking " (mutex-name mutex))
+ (if abd
+ (##sys#signal (##sys#make-structure 'condition '(abandoned-mutex-exception) (list (##sys#slot mutex 1))))
+ #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!
--
2.6.1
_______________________________________________
Chicken-hackers mailing list
Chicken-hackers@nongnu.org
https://lists.nongnu.org/mailman/listinfo/chicken-hackers
