From 1ded337d535d328673ce006aa0f22c20066688b0 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Fri, 28 Jul 2006 20:41:57 +0000 Subject: [PATCH] up svn: r3882 --- .../dispatchers/dispatch-servlets.ss | 35 +++++++++++-------- collects/web-server/managers/lru.ss | 27 ++++++++++---- collects/web-server/managers/manager.ss | 4 +++ collects/web-server/managers/timeouts.ss | 20 ++++++++--- collects/web-server/private/cache-table.ss | 34 +++++++++--------- 5 files changed, 77 insertions(+), 43 deletions(-) diff --git a/collects/web-server/dispatchers/dispatch-servlets.ss b/collects/web-server/dispatchers/dispatch-servlets.ss index 4a10cc0356..76609ddf4d 100644 --- a/collects/web-server/dispatchers/dispatch-servlets.ss +++ b/collects/web-server/dispatchers/dispatch-servlets.ss @@ -118,20 +118,25 @@ (custodian-shutdown-all instance-custodian))) (parameterize ([exit-handler the-exit-handler]) (define instance-id ((manager-create-instance manager) data the-exit-handler)) - (thread-cell-set! current-servlet-instance-id instance-id) - (with-handlers ([(lambda (x) #t) - (make-servlet-exception-handler data)]) - ;; Two possibilities: - ;; - module servlet. start : Request -> Void handles - ;; output-response via send/finish, etc. - ;; - unit/sig or simple xexpr servlet. These must produce a - ;; response, which is then output by the server. - ;; Here, we do not know if the servlet was a module, - ;; unit/sig, or Xexpr; we do know whether it produces a - ;; response. - (define r ((servlet-handler the-servlet) req)) - (when (response? r) - (send/back r)))))))) + (parameterize ([exit-handler (lambda x + ((manager-instance-unlock! manager) instance-id) + (the-exit-handler x))]) + (thread-cell-set! current-servlet-instance-id instance-id) + ((manager-instance-lock! manager) instance-id) + (with-handlers ([(lambda (x) #t) + (make-servlet-exception-handler data)]) + ;; Two possibilities: + ;; - module servlet. start : Request -> Void handles + ;; output-response via send/finish, etc. + ;; - unit/sig or simple xexpr servlet. These must produce a + ;; response, which is then output by the server. + ;; Here, we do not know if the servlet was a module, + ;; unit/sig, or Xexpr; we do know whether it produces a + ;; response. + (define r ((servlet-handler the-servlet) req)) + (when (response? r) + (send/back r))) + ((manager-instance-unlock! manager) instance-id))))))) (thread-cell-set! current-servlet last-servlet) (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) (semaphore-post servlet-mutex))) @@ -215,6 +220,7 @@ req) (request-method req)))]) (define data ((manager-instance-lookup-data manager) instance-id)) + ((manager-instance-lock! manager) instance-id) ; We don't use call-with-semaphore or dynamic-wind because we ; always call a continuation. The exit-handler above ensures that ; the post is done. @@ -227,6 +233,7 @@ conn req (lambda () (suspend #t)))) (k req)) (semaphore-post (servlet-instance-data-mutex data)))) + ((manager-instance-unlock! manager) instance-id) (thread-cell-set! current-servlet-instance-id last-servlet-instance-id) (thread-cell-set! current-servlet last-servlet)) diff --git a/collects/web-server/managers/lru.ss b/collects/web-server/managers/lru.ss index 1c1873b092..1165b676ea 100644 --- a/collects/web-server/managers/lru.ss +++ b/collects/web-server/managers/lru.ss @@ -30,12 +30,12 @@ (define instances (make-hash-table)) (define next-instance-id (make-counter)) - (define-struct instance (data k-table)) + (define-struct instance (data k-table use-count)) (define (create-instance data expire-fn) (define instance-id (next-instance-id)) (hash-table-put! instances instance-id - (make-instance data (create-k-table))) + (make-instance data (create-k-table) 0)) instance-id) (define (adjust-timeout! instance-id secs) (void)) @@ -51,6 +51,15 @@ instance-expiration-handler))))) instance) + (define (instance-lock! instance-id) + (define instance (instance-lookup instance-id)) + (set-instance-use-count! instance + (add1 (instance-use-count instance)))) + (define (instance-unlock! instance-id) + (define instance (instance-lookup instance-id)) + (set-instance-use-count! instance + (sub1 (instance-use-count instance)))) + ;; Continuation table (define-struct k-table (next-id-fn htable)) (define (create-k-table) @@ -62,7 +71,7 @@ (define (clear-continuations! instance-id) (match (instance-lookup instance-id) - [(struct instance (data (and k-table (struct k-table (next-id-fn htable))))) + [(struct instance (data (and k-table (struct k-table (next-id-fn htable))) locked?)) (hash-table-for-each htable (match-lambda* @@ -72,7 +81,7 @@ (define (continuation-store! instance-id k expiration-handler) (match (instance-lookup instance-id) - [(struct instance (data (struct k-table (next-id-fn htable)))) + [(struct instance (data (struct k-table (next-id-fn htable)) _)) (define k-id (next-id-fn)) (define salt (random 100000000)) (hash-table-put! htable @@ -81,7 +90,7 @@ (list k-id salt)])) (define (continuation-lookup instance-id a-k-id a-salt) (match (instance-lookup instance-id) - [(struct instance (data (struct k-table (next-id-fn htable)))) + [(struct instance (data (struct k-table (next-id-fn htable)) _)) (match (hash-table-get htable a-k-id (lambda () @@ -108,6 +117,8 @@ (make-LRU-manager create-instance adjust-timeout! instance-lookup-data + instance-lock! + instance-unlock! clear-continuations! continuation-store! continuation-lookup @@ -124,7 +135,7 @@ (hash-table-for-each instances (match-lambda* - [(list instance-id (struct instance (_ (struct k-table (next-id-fn htable))))) + [(list instance-id (struct instance (_ (struct k-table (next-id-fn htable)) use-count))) (define empty? (box #t)) (hash-table-for-each htable @@ -136,7 +147,9 @@ (begin (set-box! empty? #f) (hash-table-put! htable k-id (list s k eh (sub1 count)))))])) - (when (unbox empty?) + (when (and (unbox empty?) + ; XXX race condition + (zero? use-count)) (set-box! removed (add1 (unbox removed))) (hash-table-remove! instances instance-id))]))) (unless (zero? (unbox removed)) diff --git a/collects/web-server/managers/manager.ss b/collects/web-server/managers/manager.ss index 5e0164b0cc..7a1a6923fb 100644 --- a/collects/web-server/managers/manager.ss +++ b/collects/web-server/managers/manager.ss @@ -5,6 +5,8 @@ (define-struct manager (create-instance adjust-timeout! instance-lookup-data + instance-lock! + instance-unlock! clear-continuations! continuation-store! continuation-lookup)) @@ -16,6 +18,8 @@ [struct manager ([create-instance (any/c (-> void) . -> . number?)] [adjust-timeout! (number? number? . -> . void)] [instance-lookup-data (number? . -> . any/c)] + [instance-lock! (number? . -> . void)] + [instance-unlock! (number? . -> . void)] [clear-continuations! (number? . -> . void)] [continuation-store! (number? procedure? expiration-handler? . -> . (list/c number? number?))] [continuation-lookup (number? number? number? . -> . procedure?)])] diff --git a/collects/web-server/managers/timeouts.ss b/collects/web-server/managers/timeouts.ss index 5ecfffefb6..f6fdba05f9 100644 --- a/collects/web-server/managers/timeouts.ss +++ b/collects/web-server/managers/timeouts.ss @@ -28,7 +28,7 @@ (define instances (make-hash-table)) (define next-instance-id (make-counter)) - (define-struct instance (data k-table timer)) + (define-struct instance (data k-table timer locked?)) (define (create-instance data expire-fn) (define instance-id (next-instance-id)) (hash-table-put! instances @@ -38,7 +38,8 @@ (start-timer instance-timer-length (lambda () (expire-fn) - (hash-table-remove! instances instance-id))))) + (hash-table-remove! instances instance-id))) + #t)) instance-id) (define (adjust-timeout! instance-id secs) (reset-timer! (instance-timer (instance-lookup instance-id)) @@ -57,6 +58,13 @@ instance-timer-length) instance) + (define (instance-lock! instance-id) + (define instance (instance-lookup instance-id)) + (set-instance-locked?! instance #t)) + (define (instance-unlock! instance-id) + (define instance (instance-lookup instance-id)) + (set-instance-locked?! instance #f)) + ;; Continuation table (define-struct k-table (next-id-fn htable)) (define (create-k-table) @@ -68,7 +76,7 @@ (define (clear-continuations! instance-id) (match (instance-lookup instance-id) - [(struct instance (data (and k-table (struct k-table (next-id-fn htable))) instance-timer)) + [(struct instance (data (and k-table (struct k-table (next-id-fn htable))) instance-timer locked?)) (hash-table-for-each htable (match-lambda* @@ -78,7 +86,7 @@ (define (continuation-store! instance-id k expiration-handler) (match (instance-lookup instance-id) - [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer)) + [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer locked?)) (define k-id (next-id-fn)) (define salt (random 100000000)) (hash-table-put! htable @@ -92,7 +100,7 @@ (list k-id salt)])) (define (continuation-lookup instance-id a-k-id a-salt) (match (instance-lookup instance-id) - [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer)) + [(struct instance (data (struct k-table (next-id-fn htable)) instance-timer locked?)) (match (hash-table-get htable a-k-id (lambda () @@ -118,6 +126,8 @@ (make-timeout-manager create-instance adjust-timeout! instance-lookup-data + instance-lock! + instance-unlock! clear-continuations! continuation-store! continuation-lookup diff --git a/collects/web-server/private/cache-table.ss b/collects/web-server/private/cache-table.ss index 5ee5743ec6..86c9a38a1a 100644 --- a/collects/web-server/private/cache-table.ss +++ b/collects/web-server/private/cache-table.ss @@ -1,6 +1,6 @@ (module cache-table mzscheme (require (lib "contract.ss")) - + (define-struct cache-table (hash semaphore)) (define (new-cache-table) @@ -15,22 +15,22 @@ (set-cache-table-hash! ct (make-hash-table))))) (define (cache-table-lookup! ct entry-id entry-thunk) - (let ([ht (cache-table-hash ct)] - [sema (cache-table-semaphore ct)]) - ; Fast lookup - (hash-table-get - ht entry-id - (lambda () - ; Now lock for relookup and computation - (call-with-semaphore - sema - (lambda () - (hash-table-get - ht entry-id - (lambda () - (let ([entry (entry-thunk)]) - (hash-table-put! ht entry-id entry) - entry))))))))) + (define ht (cache-table-hash ct)) + (define sema (cache-table-semaphore ct)) + ; Fast lookup + (hash-table-get + ht entry-id + (lambda () + ; Now lock for relookup and computation + (call-with-semaphore + sema + (lambda () + (hash-table-get + ht entry-id + (lambda () + (define entry (entry-thunk)) + (hash-table-put! ht entry-id entry) + entry))))))) (provide/contract [rename new-cache-table make-cache-table