Hi all, attached a plain text file to be viewed with a rather wide screen containing some explanations wrt. the old and the new code.
Best /Jörg Am 26.01.2016 um 13:32 schrieb Jörg F. Wittenberger: > Hi all, > > attached a fresh patch. Fixes actually three bugs, adds tests for all > of them.
Hi all,
to simplify the reviews job wrt the mutex locking fixes I posted the
other day, let me give some more explanations regarding those changes.
I hope this helps a bit.
Best
/Jörg
# What's wrong so far?
Parameter 1: A memory leak
Parameter 2: Timeouts will disown the mutex.
Parameter 3: Mutex-giveaway and unowned locking does not work.
Details:
1. Let's hide 10.000.000 bytes:
------
(use srfi-18)
(define m (make-mutex))
(thread-start!
(lambda ()
(mutex-lock! m)
(mutex-unlock! m)
(make-string 10000000 #\X)))
(thread-yield!)
(print (string-length (thread-join! (##sys#slot m 2))))
-------
2. Timeouts
The srfi-18 document suggests a semaphore
implementations (a.k.a. recursive mutex like this one):
-------
(use srfi-18)
(define m (make-mutex))
(define (mutex-lock-recursively! mutex . timeout)
(if (eq? (mutex-state mutex) (current-thread))
(let ((n (mutex-specific mutex)))
(mutex-specific-set! mutex (+ n 1)))
(begin
(mutex-lock! mutex (and (pair? timeout) (car timeout)))
(mutex-specific-set! mutex 0))))
(define (mutex-unlock-recursively! mutex)
(let ((n (mutex-specific mutex)))
(if (= n 0)
(mutex-unlock! mutex)
(mutex-specific-set! mutex (- n 1)))))
(define t1
(thread-start!
(lambda ()
(mutex-lock-recursively! m)
(thread-sleep! 1)
(mutex-lock-recursively! m)
;; Never reached. Deadlock before.
(mutex-unlock-recursively! m)
(mutex-unlock-recursively! m))))
(thread-yield!)
(mutex-lock-recursively! m 0.05)
(thread-join! t1)
-------
Let's successfully lock a mutex and find the return value #f
indicating a timeout. (Will print "Failed" even though the mux was
successfully locked.)
-------
(use srfi-18)
(define m (make-mutex))
(mutex-lock! m)
(define t1
(thread-start!
(lambda ()
(if (mutex-lock! m 0.5) 'GotIt 'Failed))))
(thread-yield!)
(mutex-unlock! m)
(print (thread-join! t1))
-------
3. This was documented before, though only for #f as third parameter
to mutex-lock! However it's rather obvious that it does not matter
much whether a thread or #f is passed.
The problem is that mutex-unlock! does now know anything about the
optional thread/#f parameter. Thus it can not do the assignment.
# The old code
Comments at the right side behind the "|" character. Needs a wide screen.
========================================================================================================================
(define mutex-lock!
(lambda (mutex . ms-and-t)
(##sys#check-structure mutex 'mutex 'mutex-lock!)
(let* ([limitsup (pair? ms-and-t)]
[limit (and limitsup (compute-time-limit (car ms-and-t)
'mutex-lock!))]
[threadsup (fx> (length ms-and-t) 1)]
[thread (and threadsup (cadr ms-and-t))] )
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
(##sys#call-with-current-continuation
(lambda (return)
(let ([ct ##sys#current-thread])
(define (switch)
(dbg ct " sleeping on mutex " (mutex-name mutex))
(##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list
ct)))
(##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))
(cond [(not (##sys#slot mutex 5))
(if (and threadsup (not thread))
| This correctly locks
(begin
| and assigns the mutex
(##sys#setislot mutex 2 #f)
|
(##sys#setislot mutex 5 #t) )
| Moved into new local
(let* ([t (or thread ct)]
| procedure "(assign)"
[ts (##sys#slot t 3)] )
| for reuse.
(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) ]
| A bit late, we should not modify the mux before
[limit
(check)
(##sys#setslot
ct 1
(lambda ()
(##sys#setslot mutex 3 (##sys#delq ct (##sys#slot mutex
3))) | done by mutex-unlock! except for timeout
(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)))
| wrong if unblocked by timeout
(##sys#setslot ct 11 #f)
(##sys#setslot mutex 2 thread)
| wrong if unblocked by timeout
(return #f) ))
| wrong if mutex was successfully locked
(##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)))
(switch) ] ) ) ) ) ) ) )
(define mutex-unlock!
(lambda (mutex . cvar-and-to)
(##sys#check-structure mutex 'mutex 'mutex-unlock!)
(let ([ct ##sys#current-thread]
[cvar (and (pair? cvar-and-to) (car cvar-and-to))]
[timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
(dbg ct ": unlocking " (mutex-name mutex))
(when cvar
(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
(##sys#call-with-current-continuation
(lambda (return)
(let ([waiting (##sys#slot mutex 3)]
[limit (and timeout (compute-time-limit timeout
'mutex-unlock!))] )
(##sys#setislot mutex 4 #f) ; abandoned
(##sys#setislot mutex 5 #f) ; blocked
(let ((t (##sys#slot mutex 2)))
(when t
(##sys#setslot t 8 (##sys#delq mutex (##sys#slot t 8))))) ;
unown from owner | Leaves memory leak - see (1.)
(when cvar
(##sys#setslot cvar 2 (##sys#append (##sys#slot cvar 2)
(##sys#list ct)))
(##sys#setslot ct 11 cvar) ; block object
(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
(if (##sys#slot ct 13) ; unblocked by timeout
(return #f)
(begin
(##sys#remove-from-timeout-list ct)
(return #t))) ) )
(##sys#thread-block-for-timeout! ct limit) )
(else
(##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)] )
(##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)
| which thread or #f is
(##sys#setslot wt 8 (cons mutex (##sys#slot wt 8)))
| only know to mutex-lock!
(##sys#setslot wt 11 #f)
(when (eq? wts 'sleeping) (##sys#add-to-ready-queue wt) ) ) )
)
(if (eq? (##sys#slot ct 3) 'running)
(return #t)
(##sys#schedule)) ) ) ) ) ))
========================================================================================================================
# The new code
========================================================================================================================
(define mutex-lock!
(lambda (mutex . ms-and-t)
(##sys#check-structure mutex 'mutex 'mutex-lock!)
(let* ([limitsup (pair? ms-and-t)]
[limit (and limitsup (compute-time-limit (car ms-and-t)
'mutex-lock!))]
[threadsup (fx> (length ms-and-t) 1)]
[thread (and threadsup (cadr ms-and-t))] )
(when thread (##sys#check-structure thread 'thread 'mutex-lock!))
(##sys#call-with-current-continuation
(lambda (return)
(let ([ct ##sys#current-thread])
(define (switch)
(dbg ct " sleeping on mutex " (mutex-name mutex))
(##sys#setslot mutex 3 (##sys#append (##sys#slot mutex 3) (list
ct)))
(##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)
| Here the lock/assign code.
(check)
| First check,
(if (and threadsup (not thread))
| rest mostly unchanged
(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)
|
(check))
|
(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))
(assign) ]
| call the new proc
[limit
(check)
(##sys#setslot
ct 1
(lambda ()
(if (##sys#slot ct 13) ; unblocked by timeout
(begin
(##sys#setslot mutex 3 (##sys#delq ct (##sys#slot
mutex 3))) | move here, otherwise mux-unlock did it
(return #f))
| return #f only in this case
(begin
(##sys#remove-from-timeout-list ct)
(assign))) ))
| re-use the assignement code
(##sys#thread-block-for-timeout! ct limit)
(switch) ]
[else
(##sys#setslot ct 3 'sleeping)
(##sys#setslot ct 11 mutex)
(##sys#setslot ct 1 assign)
| re-use the assig-code
(switch) ] ) ) ) ) ) ) )
(define mutex-unlock!
(lambda (mutex . cvar-and-to)
(##sys#check-structure mutex 'mutex 'mutex-unlock!)
(let ([ct ##sys#current-thread]
[cvar (and (pair? cvar-and-to) (car cvar-and-to))]
[timeout (and (fx> (length cvar-and-to) 1) (cadr cvar-and-to))] )
(dbg ct ": unlocking " (mutex-name mutex))
(when cvar
(##sys#check-structure cvar 'condition-variable 'mutex-unlock!))
(##sys#call-with-current-continuation
(lambda (return)
(let ([waiting (##sys#slot mutex 3)]
[limit (and timeout (compute-time-limit timeout
'mutex-unlock!))] )
(##sys#setislot mutex 4 #f) ; abandoned
(##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)))
(##sys#setslot ct 11 cvar) ; block object
(cond (limit
(##sys#setslot
ct 1
(lambda ()
(##sys#setislot ct 11 #f)
(if (##sys#slot ct 13) ; unblocked by timeout
(begin
(##sys#setslot cvar 2 (##sys#delq ct (##sys#slot
cvar 2)))
(return #f))
(begin
(##sys#remove-from-timeout-list ct)
(return #t))) ) )
(##sys#thread-block-for-timeout! ct limit) )
(else
(##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)) )
(##sys#setslot mutex 3 (##sys#slot waiting 1))
(##sys#setislot mutex 5 #t)
| assignment code is gone.
(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)) ) ) ) ) ))
_______________________________________________ Chicken-hackers mailing list Chicken-hackers@nongnu.org https://lists.nongnu.org/mailman/listinfo/chicken-hackers
