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

up

Browse Source 
svn: r3882
This commit is contained in:
Jay McCarthy 2006-07-28 20:41:57 +00:00
parent 978d158687
commit 1ded337d53
5 changed files with 77 additions and 43 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/web-server/dispatchers/dispatch-servlets.ss
View File

@ -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))

27
collects/web-server/managers/lru.ss
View File

@ -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))

4
collects/web-server/managers/manager.ss
View File

@ -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?)])]

20
collects/web-server/managers/timeouts.ss
View File

@ -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

34
collects/web-server/private/cache-table.ss
View File

@ -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