Hi all,
while this patch does fix two bugs in the old code, it introduces a new one.
I'm in the middle of expanding the test case and will soon post a new
patch. (The difference to the patch I attached to ticket 1231 is only
one line - iff I don't find more.)
To make it easier for the reviewers to grok the code, I'll put more
comments into the test case.
For the curious attached my current version of the test.
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
>
;;;; 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 boolean (struct thread))
3 (list-of (struct thread)) waiting thread
4 boolean abandoned
5 boolean locked
|#
(define-record-printer (mutex x out)
(format out "<mutex ~a ~a~a ~a waiting ~a>"
(mutex-name x)
(if (##sys#slot x 5) "LOCKED" "FREE")
(if (##sys#slot x 4) "/ABANDONED" "")
(mutex-state x)
(##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)))))
;;============
; 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
(lambda (form r c) ; doesn't bother much with renaming
(let ((loc (cadr form))
(expr (caddr form)))
(set! count (add1 count))
`(,(r 'begin)
(print "(" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
(let ((xxx ,expr))
(print " (" ,count ") " ,loc ": " ',expr ": get: " (##sys#slot get-mutex 5) ", put: " (##sys#slot put-mutex 5))
xxx) ) ))))
(else (define-syntax trail (syntax-rules () ((_ loc expr) expr)))))
(define (tprint . x)
(printf "~a " (current-milliseconds))
(apply print x))
(define (make-empty-mailbox)
(let ((put-mutex (make-mutex)) ; allow put! operation
(get-mutex (make-mutex))
(cell #f))
(define (put! obj)
(trail 'put! (mutex-lock! put-mutex #f #f)) ; prevent put! operation
(set! cell obj)
(trail 'put! (mutex-unlock! get-mutex)) )
(define (get!)
(trail 'get! (mutex-lock! get-mutex #f #f)) ; wait until object in mailbox
(let ((result cell))
(set! cell #f) ; prevent space leaks
(trail 'get! (mutex-unlock! put-mutex)) ; allow put! operation
result))
(trail 'main (mutex-lock! get-mutex #f #f)) ; prevent get! operation
(lambda (print)
(case print
((put!) put!)
((get!) get!)
(else (error "unknown message"))))))
(define (mailbox-put! m obj) ((m 'put!) obj))
(define (mailbox-get! m) ((m 'get!)))
;(tprint 'start)
(define mb (make-empty-mailbox))
(thread-start!
(make-thread
(lambda ()
(let lp ()
;(print "1: get")
(let ((x (mailbox-get! mb)))
;(tprint "read: " x)
(assert x)
(lp))))))
(thread-start!
(make-thread
(lambda ()
(thread-sleep! 1)
;(tprint 'put)
;(print "2: put")
(mailbox-put! mb 'test)
#;(print "2: endput"))))
(thread-sleep! 3)
;(tprint 'exit)
(if test-has-failed (exit 1) (exit 0))
_______________________________________________
Chicken-users mailing list
[email protected]
https://lists.nongnu.org/mailman/listinfo/chicken-users
