Fcalva/chibi-scheme
1
0
Fork 0
mirror of https://github.com/ashinn/chibi-scheme.git synced 2025-05-20 14:19:18 +02:00
Code Issues Projects Releases Packages Wiki Activity Actions

Fixing mutex-unlock! with paused thread waiting on mutex-lock!

Browse source
This commit is contained in:
Alex Shinn 2012-08-08 00:21:00 +09:00
parent 9510e5b5c2
commit 10b1110439
2 changed files with 71 additions and 18 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

22
lib/srfi/18/interface.scm
View file

@ -36,18 +36,24 @@
(define (mutex-lock! mutex . o)
(let ((timeout (and (pair? o) (car o)))
(thread (if (and (pair? o) (pair? (cdr o))) (cadr o) #t)))
(cond ((%mutex-lock! mutex (timeout->seconds timeout) thread))
(else
(thread-yield!)
(not (thread-timeout?))))))
(cond
((%mutex-lock! mutex (timeout->seconds timeout) thread))
(else
(thread-yield!)
;; If we timed out, fail.
(if (thread-timeout?)
#f
;; Otherwise the lock was released, try again.
(mutex-lock! mutex timeout thread))))))
(define (mutex-unlock! mutex . o)
(let ((condvar (and (pair? o) (car o)))
(timeout (if (and (pair? o) (pair? (cdr o))) (cadr o) #f)))
(cond ((%mutex-unlock! mutex condvar (timeout->seconds timeout)))
(else
(thread-yield!)
(not (thread-timeout?))))))
(cond
((%mutex-unlock! mutex condvar (timeout->seconds timeout)))
(else
(thread-yield!)
(not (thread-timeout?))))))
(define (join-timeout-exception? x)
(and (exception? x)

67
tests/thread-tests.scm
View file

@ -5,17 +5,64 @@
(test-begin "threads")
(test "no threads" (begin 'ok) 'ok)
(test "unstarted thread" (let ((t (make-thread (lambda () (error "oops"))))) 'ok) 'ok)
(test "ignored thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok) 'ok)
(test "ignored thread hangs" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) 'ok) 'ok)
(test "joined thread terminates" (let ((t (make-thread (lambda () 'oops)))) (thread-start! t) (thread-join! t) 'ok) 'ok)
(test "joined thread hangs, timeout" (let ((t (make-thread (lambda () (let lp () (lp)))))) (thread-start! t) (thread-join! t 0.1 'timeout)) 'timeout)
(test "no threads" 'ok (begin 'ok))
(test "basic mutex" (let ((m (make-mutex))) (and (mutex? m) 'ok)) 'ok)
(test "mutex unlock" (let ((m (make-mutex))) (and (mutex-unlock! m) 'ok)) 'ok)
(test "mutex lock/unlock" (let ((m (make-mutex))) (and (mutex-lock! m) (mutex-unlock! m) 'ok)) 'ok)
(test "mutex lock timeout" (let* ((m (make-mutex)) (t (make-thread (lambda () (mutex-lock! m))))) (thread-start! t) (thread-yield!) (if (mutex-lock! m 0.1) 'fail 'timeout)) 'timeout)
(test "unstarted thread" 'ok
(let ((t (make-thread (lambda () (error "oops"))))) 'ok))
(test "ignored thread terminates" 'ok
(let ((t (make-thread (lambda () 'oops)))) (thread-start! t) 'ok))
(test "ignored thread hangs" 'ok
(let ((t (make-thread (lambda () (let lp () (lp))))))
(thread-start! t)
'ok))
(test "joined thread terminates" 'ok
(let ((t (make-thread (lambda () 'oops))))
(thread-start! t)
(thread-join! t)
'ok))
(test "joined thread hangs, timeout" 'timeout
(let ((t (make-thread (lambda () (let lp () (lp))))))
(thread-start! t)
(thread-join! t 0.1 'timeout)))
(test "basic mutex" 'ok
(let ((m (make-mutex)))
(and (mutex? m) 'ok)))
(test "mutex unlock" 'ok
(let ((m (make-mutex)))
(and (mutex-unlock! m) 'ok)))
(test "mutex lock/unlock" 'ok
(let ((m (make-mutex)))
(and (mutex-lock! m)
(mutex-unlock! m)
'ok)))
(test "mutex lock/lock" 'timeout
(let ((m (make-mutex)))
(and (mutex-lock! m)
(if (mutex-lock! m 0.1) 'fail 'timeout))))
(test "mutex lock timeout" 'timeout
(let* ((m (make-mutex))
(t (make-thread (lambda () (mutex-lock! m)))))
(thread-start! t)
(thread-yield!)
(if (mutex-lock! m 0.1) 'fail 'timeout)))
(test "mutex lock/unlock/lock/lock" 'timeout
(let* ((m (make-mutex))
(t (make-thread (lambda () (mutex-unlock! m)))))
(mutex-lock! m)
(thread-start! t)
(if (mutex-lock! m 0.1)
(if (mutex-lock! m 0.1) 'fail-second 'timeout)
'bad-timeout)))
;(test "basic condition-variable" () 'ok)
;(test "condition-variable signal" () 'ok)