suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

avoid showing the lock thread

Browse Source 
svn: r11824
This commit is contained in:
Eli Barzilay 2008-09-20 13:53:22 +00:00
parent 6f9b5ad586
commit 056ca07a7f
1 changed files with 42 additions and 41 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

83
collects/handin-server/private/lock.ss
View File

@ -20,44 +20,45 @@
(define-struct req (thread-dead-evt user sema cleanup-thunk))
(thread
(lambda ()
(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-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))