65 lines
2.7 KiB
Racket
65 lines
2.7 KiB
Racket
#lang scheme/base
|
|
|
|
(provide wait-for-lock)
|
|
|
|
;; wait-for-lock : string -> void
|
|
;; Gets a lock on `user' for the calling thread; the lock lasts until the
|
|
;; calling thread terminates. If the lock was actually acquired, then on
|
|
;; release the cleanup-thunk will be executed (unless it is #f), even if it
|
|
;; was released when the acquiring thread crashed.
|
|
;; *** Warning: It's vital that a clean-up thunk doesn't raise an exception,
|
|
;; since this will kill the lock thread which will lock down everything
|
|
(define (wait-for-lock user . cleanup-thunk)
|
|
(let ([s (make-semaphore)])
|
|
(channel-put req-ch
|
|
(make-req (thread-dead-evt (current-thread)) user s
|
|
(and (pair? cleanup-thunk) (car cleanup-thunk))))
|
|
(semaphore-wait s)))
|
|
|
|
(define req-ch (make-channel))
|
|
|
|
(define-struct req (thread-dead-evt user sema cleanup-thunk))
|
|
|
|
(define (lock-loop)
|
|
(let loop ([locks null]
|
|
[reqs null])
|
|
(let-values ([(locks reqs)
|
|
;; Try to satisfy lock requests:
|
|
(let loop ([reqs (reverse reqs)]
|
|
[locks locks]
|
|
[new-reqs null])
|
|
(if (null? reqs)
|
|
(values locks new-reqs)
|
|
(let ([req (car reqs)]
|
|
[rest (cdr reqs)])
|
|
(if (assoc (req-user req) locks)
|
|
;; Lock not available:
|
|
(loop rest locks (cons req new-reqs))
|
|
;; Lock is available, so take it:
|
|
(begin (semaphore-post (req-sema req))
|
|
(loop (cdr reqs)
|
|
(cons (cons (req-user req) req) locks)
|
|
new-reqs))))))])
|
|
(sync
|
|
(handle-evt req-ch (lambda (req) (loop locks (cons req reqs))))
|
|
;; Release a lock whose thread is gone:
|
|
(apply choice-evt
|
|
(map (lambda (name+req)
|
|
(handle-evt
|
|
(req-thread-dead-evt (cdr name+req))
|
|
(lambda (v)
|
|
;; releasing a lock => run cleanup
|
|
(cond [(req-cleanup-thunk (cdr name+req))
|
|
=> (lambda (t) (t))])
|
|
(loop (remq name+req locks) reqs))))
|
|
locks))
|
|
;; Throw away a request whose thread is gone:
|
|
(apply choice-evt
|
|
(map (lambda (req)
|
|
(handle-evt
|
|
(req-thread-dead-evt req)
|
|
(lambda (v) (loop locks (remq req reqs)))))
|
|
reqs))))))
|
|
|
|
(define lock-thread (thread lock-loop))
|