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

thread specific execution context

Browse Source 
svn: r3983
This commit is contained in:
Jay McCarthy 2006-08-08 01:05:35 +00:00
parent 8b60b3202c
commit 27e7ddad4f
5 changed files with 116 additions and 116 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -15,6 +15,7 @@
"../managers/manager.ss"
"../managers/timeouts.ss"
"../managers/lru.ss"
"../managers/none.ss"
"../private/url.ss"
"../private/servlet.ss"
"../private/cache-table.ss")
@ -76,8 +77,7 @@
(lambda (the-exn)
(output-response/method conn (responders-servlet-loading uri the-exn) (request-method req)))])
(define servlet-mutex (make-semaphore 0))
(define last-servlet (thread-cell-ref current-servlet))
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id))
(define response
(let/cc suspend
; Create the session frame
(with-frame
@ -104,18 +104,19 @@
(thread-cell-set! current-servlet the-servlet)
(parameterize ([current-namespace (servlet-namespace the-servlet)])
(define manager (servlet-manager the-servlet))
(define ctxt
(make-execution-context
conn req suspend))
(define data
(make-servlet-instance-data
servlet-mutex
(make-execution-context
conn req (lambda () (suspend #t)))))
servlet-mutex))
(define the-exit-handler
(lambda _
(kill-connection!
(execution-context-connection
(servlet-instance-data-context
data)))
(thread-cell-ref current-execution-context)))
(custodian-shutdown-all instance-custodian)))
(thread-cell-set! current-execution-context ctxt)
(parameterize ([exit-handler the-exit-handler])
(define instance-id ((manager-create-instance manager) data the-exit-handler))
(parameterize ([exit-handler (lambda x
@ -136,9 +137,11 @@
(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)
((manager-instance-unlock! manager) instance-id))))))))
(output-response conn response)
(thread-cell-set! current-execution-context #f)
(thread-cell-set! current-servlet #f)
(thread-cell-set! current-servlet-instance-id #f)
(semaphore-post servlet-mutex)))
;; default-server-instance-expiration-handler : (request -> response)
@ -160,18 +163,13 @@
;; requests won't be blocked.
;; * This fixes PR# 7066
(define ((make-servlet-exception-handler inst-data) the-exn)
(define context (servlet-instance-data-context inst-data))
(define context (thread-cell-ref current-execution-context))
(define request (execution-context-request context))
(define resp
(responders-servlet
(request-uri request)
the-exn))
;; Don't handle twice
(with-handlers ([exn:fail? (lambda (exn) (void))])
(output-response/method
(execution-context-connection context)
resp (request-method request)))
((execution-context-suspend context)))
((execution-context-suspend context) resp))
;; path -> path
;; The actual servlet's parent directory.
@ -191,8 +189,6 @@
(url-path->path
servlet-root
(url-path->string (url-path uri))))
(define last-servlet (thread-cell-ref current-servlet))
(define last-servlet-instance-id (thread-cell-ref current-servlet-instance-id))
(define the-servlet (cached-load servlet-path))
(define manager (servlet-manager the-servlet))
(thread-cell-set! current-servlet the-servlet)
@ -225,17 +221,18 @@
; always call a continuation. The exit-handler above ensures that
; the post is done.
(semaphore-wait (servlet-instance-data-mutex data))
(let ([response
(let/cc suspend
(define k ((manager-continuation-lookup manager) instance-id k-id salt))
(set-servlet-instance-data-context!
data
(thread-cell-set! current-execution-context
(make-execution-context
conn req (lambda () (suspend #t))))
(k req))
conn req suspend))
(k req))])
(output-response conn response))
(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))
(thread-cell-set! current-servlet-instance-id #f)
(thread-cell-set! current-servlet #f))
;; ************************************************************
;; ************************************************************
@ -281,11 +278,13 @@
(lambda (initial-request)
(invoke-unit/sig servlet servlet^)))
(define (v0.response->v1.lambda response-path response)
(letrec ([go (lambda ()
(begin
(set! go (lambda () (load/use-compiled a-path)))
response))])
(lambda (initial-request) (go))))
(define go
(box
(lambda ()
(set-box! go (lambda () (load/use-compiled a-path)))
response)))
(lambda (initial-request)
((unbox go))))
(define (v1.module->v1.lambda timeout start)
(lambda (initial-request)
(adjust-timeout! timeout)

8
collects/web-server/private/servlet.ss
View File

@ -7,11 +7,12 @@
(define-struct (exn:fail:servlet:instance exn:fail) ())
(define-struct servlet (custodian namespace manager handler))
(define-struct servlet-instance-data (mutex context))
(define-struct servlet-instance-data (mutex))
(define-struct execution-context (connection request suspend))
(define current-servlet (make-thread-cell #f))
(define current-servlet-instance-id (make-thread-cell #f))
(define current-execution-context (make-thread-cell #f))
(define (get-current-servlet-instance-id)
(define instance-id (thread-cell-ref current-servlet-instance-id))
@ -40,8 +41,7 @@
[manager manager?]
[handler (request? . -> . servlet-response?)])]
[struct servlet-instance-data
([mutex semaphore?]
[context execution-context?])]
([mutex semaphore?])]
[struct execution-context
([connection connection?]
[request request?]
@ -50,6 +50,8 @@
[current-servlet thread-cell?]
; XXX contract maybe
[current-servlet-instance-id thread-cell?]
; XXX contract maybe
[current-execution-context thread-cell?]
[get-current-servlet-instance-id (-> number?)]
[current-servlet-manager (-> manager?)]
[current-servlet-instance-data (-> servlet-instance-data?)]))

1
collects/web-server/servlet-env.ss
View File

@ -35,7 +35,6 @@
(lambda (initial-request)
(let ([v (servlet-expr initial-request)])
(set! final-value v)
;(set! final-conn (execution-context-connection (servlet-instance-context (current-servlet-instance))))
(semaphore-post sema)
(if (response? v)
v

14
collects/web-server/servlet.ss
View File

@ -2,8 +2,7 @@
(require (lib "contract.ss")
(lib "etc.ss")
(lib "xml.ss" "xml"))
(require "response.ss"
"managers/manager.ss"
(require "managers/manager.ss"
"private/servlet.ss"
"private/url.ss"
"servlet-helpers.ss"
@ -71,9 +70,8 @@
;; send/back: response -> void
;; send a response and don't clear the continuation table
(define (send/back resp)
(define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
(output-response (execution-context-connection ctxt) resp)
((execution-context-suspend ctxt)))
(define ctxt (thread-cell-ref current-execution-context))
((execution-context-suspend ctxt) resp))
;; send/finish: response -> void
;; send a response and clear the continuation table
@ -93,15 +91,13 @@
(with-frame-after
(let/cc k
(define instance-id (get-current-servlet-instance-id))
(define ctxt (servlet-instance-data-context (current-servlet-instance-data)))
(define ctxt (thread-cell-ref current-execution-context))
(define k-embedding ((manager-continuation-store! (current-servlet-manager)) instance-id k expiration-handler))
(define k-url ((current-url-transform)
(embed-ids
(list* instance-id k-embedding)
(request-uri (execution-context-request ctxt)))))
(define response (response-generator k-url))
(output-response (execution-context-connection ctxt) response)
((execution-context-suspend ctxt))))))
(send/back (response-generator k-url))))))
;; send/forward: (url -> response) [(request -> response)] -> request
;; clear the continuation table, then behave like send/suspend

26
collects/web-server/tools/backend.ss
View File

@ -14,13 +14,14 @@
;; start-servlet: connection request hash-table number (number->void request -> response) -> void
;; start a new instance of a servlet
(define (start-servlet conn req instance-table instance-timeout svt)
(let ([sema (make-semaphore 0)])
(define sema (make-semaphore 0))
(define response
(let/cc suspend
(let* ([servlet-custodian (make-servlet-custodian)]
[inst (create-new-instance!
instance-table servlet-custodian
(make-execution-context
conn req (lambda () (suspend #t)))
conn req suspend)
sema)]
[servlet-exit-handler (make-servlet-exit-handler inst instance-table)]
[time-bomb (start-timer instance-timeout
@ -34,8 +35,9 @@
(reset-timer! time-bomb secs))
req)])
(when (response? r)
(send/back r)))))))
(semaphore-post sema)))
(send/back r))))))))
(output-respose conn response)
(semaphore-post sema))
;; make-servlet-exit-handler: servlet-instance -> alpha -> void
;; exit handler for a servlet
@ -65,23 +67,25 @@
;; resume-servlet: connection request continuation-reference hash-table -> void
;; pull the continuation out of the table and apply it
(define (resume-servlet conn req k-ref instance-table)
(let* ([inst (hash-table-get instance-table (car k-ref)
(define inst (hash-table-get instance-table (car k-ref)
(lambda ()
(raise
(make-exn:servlet:instance
"" (current-continuation-marks)))))]
[k-table
(servlet-instance-k-table inst)])
"" (current-continuation-marks))))))
(define k-table
(servlet-instance-k-table inst))
(define response
(let/cc suspend
(set-servlet-instance-context!
inst
(make-execution-context
conn req (lambda () (suspend #t))))
conn req suspend))
(semaphore-wait (servlet-instance-mutex inst))
((hash-table-get k-table (cadr k-ref)
(lambda ()
(raise
(make-exn:servlet:continuation
"" (current-continuation-marks)))))
req))
(semaphore-post (servlet-instance-mutex inst)))))
req)))
(output-response conn response)
(semaphore-post (servlet-instance-mutex inst))))