From 056ca07a7f16c077357939c401b2e789f6b4d3b2 Mon Sep 17 00:00:00 2001 From: Eli Barzilay Date: Sat, 20 Sep 2008 13:53:22 +0000 Subject: [PATCH] avoid showing the lock thread svn: r11824 --- collects/handin-server/private/lock.ss | 83 +++++++++++++------------- 1 file changed, 42 insertions(+), 41 deletions(-) diff --git a/collects/handin-server/private/lock.ss b/collects/handin-server/private/lock.ss index 9804eb8f0c..c9c9f1cc36 100644 --- a/collects/handin-server/private/lock.ss +++ b/collects/handin-server/private/lock.ss @@ -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))