From 281f9a36b33467c7000400a5671de27852e73901 Mon Sep 17 00:00:00 2001 From: Jay McCarthy Date: Thu, 1 Sep 2005 12:35:54 +0000 Subject: [PATCH] Creating cache-table for performance! svn: r731 --- collects/web-server/cache-table.ss | 40 ++++++++++++++++++ collects/web-server/configuration.ss | 9 ++-- collects/web-server/dispatch-servlets.ss | 52 +++++++++--------------- collects/web-server/servlet-env.ss | 21 ++++++---- collects/web-server/sig.ss | 3 +- collects/web-server/web-server-unit.ss | 36 +++++++--------- 6 files changed, 91 insertions(+), 70 deletions(-) create mode 100644 collects/web-server/cache-table.ss diff --git a/collects/web-server/cache-table.ss b/collects/web-server/cache-table.ss new file mode 100644 index 0000000000..da6c2d7087 --- /dev/null +++ b/collects/web-server/cache-table.ss @@ -0,0 +1,40 @@ +(module cache-table mzscheme + (require (lib "contract.ss")) + + (define-struct cache-table (hash semaphore)) + + (define (new-cache-table) + ; Only eq? tables are not locked + (make-cache-table (make-hash-table) + (make-semaphore 1))) + + (define (cache-table-clear! ct) + (call-with-semaphore + (cache-table-semaphore ct) + (lambda () + (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))))))))) + + (provide/contract + [rename new-cache-table make-cache-table + (-> cache-table?)] + [cache-table-lookup! (cache-table? symbol? (-> any/c) . -> . any/c)] + [cache-table-clear! (cache-table? . -> . void?)]) + (provide cache-table?)) \ No newline at end of file diff --git a/collects/web-server/configuration.ss b/collects/web-server/configuration.ss index 85a6192495..6ca4e49d6e 100644 --- a/collects/web-server/configuration.ss +++ b/collects/web-server/configuration.ss @@ -5,9 +5,9 @@ "sig.ss" "util.ss" "parse-table.ss" - ;"servlet-helpers.ss" - "response.ss" - (lib "unitsig.ss") + "cache-table.ss" + "response.ss") + (require (lib "unitsig.ss") (lib "contract.ss") (lib "url.ss" "net") (lib "date.ss")) @@ -98,8 +98,7 @@ (define virtual-hosts the-virtual-hosts) (define access (make-hash-table)) (define instances (make-hash-table)) - (define scripts (box (make-hash-table 'equal))) - (define scripts-lock (make-semaphore 1)) + (define scripts (box (make-cache-table))) (define make-servlet-namespace the-make-servlet-namespace))) ; begin stolen from commander.ss, which was stolen from private/drscheme/eval.ss diff --git a/collects/web-server/dispatch-servlets.ss b/collects/web-server/dispatch-servlets.ss index a3decb7563..d15f8d3c55 100644 --- a/collects/web-server/dispatch-servlets.ss +++ b/collects/web-server/dispatch-servlets.ss @@ -12,12 +12,13 @@ "servlet.ss" "sig.ss" "timer.ss" - "util.ss") + "util.ss" + "cache-table.ss") (provide interface-version gen-dispatcher) (define interface-version 'v1) - (define (gen-dispatcher host-info config:instances config:scripts config:scripts-lock config:make-servlet-namespace) + (define (gen-dispatcher host-info config:instances config:scripts config:make-servlet-namespace) ;; ************************************************************ ;; ************************************************************ ;; SERVING SERVLETS @@ -254,25 +255,18 @@ (define cache-entry-servlet car) (define cache-entry-namespace cdr) - ;; cached-load : str -> script, namespace + ;; cached-load : path -> script, namespace ;; timestamps are no longer checked for performance. The cache must be explicitly ;; refreshed (see dispatch). - (define (cached-load name) - (let ([e - ; First try to get the cache entry - (hash-table-get - (unbox config:scripts) - name - (lambda () - ; Then try to update the cache entry - (call-with-semaphore - config:scripts-lock - (lambda () - (hash-table-get (unbox config:scripts) name - (lambda () - (reload-servlet-script name)))))))]) - (values (cache-entry-servlet e) - (cache-entry-namespace e)))) + (define (cached-load servlet-path) + (let* ([entry-id (string->symbol (path->string servlet-path))] + [entry (cache-table-lookup! + (unbox config:scripts) + entry-id + (lambda () + (reload-servlet-script servlet-path)))]) + (values (cache-entry-servlet entry) + (cache-entry-namespace entry)))) ;; exn:i/o:filesystem:servlet-not-found = ;; (make-exn:fail:filesystem:exists:servlet str continuation-marks str sym) @@ -285,10 +279,6 @@ (cond [(load-servlet/path servlet-filename) => (lambda (entry) - ; This is only called from cached-load, so config:scripts is locked - (hash-table-put! (unbox config:scripts) - servlet-filename - entry) entry)] [else (raise (make-exn:fail:filesystem:exists:servlet @@ -352,15 +342,13 @@ (lambda (conn req) (let-values ([(uri method path) (decompose-request req)]) (cond [(string=? "/conf/refresh-servlets" path) - ;; more here - this is broken - only out of date or specifically mentioned - ;; scripts should be flushed. This destroys persistent state! - (call-with-semaphore config:scripts-lock - (lambda () - (set-box! config:scripts (make-hash-table 'equal)))) - (output-response/method - conn - ((responders-servlets-refreshed (host-responders host-info))) - method)] + ;; more here - this is broken - only out of date or specifically mentioned + ;; scripts should be flushed. This destroys persistent state! + (cache-table-clear! (unbox config:scripts)) + (output-response/method + conn + ((responders-servlets-refreshed (host-responders host-info))) + method)] [(servlet-bin? path) (adjust-connection-timeout! conn diff --git a/collects/web-server/servlet-env.ss b/collects/web-server/servlet-env.ss index 411b9131b3..11bcdac361 100644 --- a/collects/web-server/servlet-env.ss +++ b/collects/web-server/servlet-env.ss @@ -6,7 +6,8 @@ "connection-manager.ss" "servlet-tables.ss" "util.ss" - "response.ss") + "response.ss" + "cache-table.ss") (require (lib "url.ss" "net") (lib "sendurl.ss" "net") (lib "unitsig.ss") @@ -33,7 +34,7 @@ [sema (make-semaphore 0)] [new-servlet - (unit/sig () (import servlet^) + (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)))) @@ -54,13 +55,16 @@ (define (build-standalone-servlet-configuration the-port the-path the-servlet) (let ([basic-configuration@ (load-developer-configuration default-configuration-table-path)] - [the-scripts (make-hash-table 'equal)]) + [the-scripts (make-cache-table)]) (define-values/invoke-unit/sig web-config^ basic-configuration@ i) - (hash-table-put! the-scripts - (build-path (directory-part default-configuration-table-path) - "default-web-root" "." - the-path) - (cons the-servlet (i:make-servlet-namespace))) + (cache-table-lookup! the-scripts + (string->symbol + (path->string + (build-path (directory-part default-configuration-table-path) + "default-web-root" "." + the-path))) + (lambda () + (cons the-servlet (i:make-servlet-namespace)))) (unit/sig web-config^ (import) (define port the-port) @@ -71,5 +75,4 @@ (define access i:access) (define instances i:instances) (define scripts (box the-scripts)) - (define scripts-lock i:scripts-lock) (define make-servlet-namespace i:make-servlet-namespace))))) \ No newline at end of file diff --git a/collects/web-server/sig.ss b/collects/web-server/sig.ss index 0ad1379ae5..926df5f83b 100644 --- a/collects/web-server/sig.ss +++ b/collects/web-server/sig.ss @@ -24,8 +24,7 @@ (max-waiting virtual-hosts access - scripts ;; : equal-hash-table - scripts-lock + scripts initial-connection-timeout)) ; more here - rename diff --git a/collects/web-server/web-server-unit.ss b/collects/web-server/web-server-unit.ss index 3a3473242b..cfefee91a6 100644 --- a/collects/web-server/web-server-unit.ss +++ b/collects/web-server/web-server-unit.ss @@ -4,6 +4,7 @@ "connection-manager.ss" "configuration-structures.ss" "servlet.ss" + "cache-table.ss" (rename "request-parsing.ss" the-read-request read-request)) (require (prefix sequencer: "dispatch-sequencer.ss") @@ -21,20 +22,16 @@ ;; stick this auxilliary outside the unit so ;; I can get at it with require/expose - ;; get-host : Url (listof (cons Symbol String)) -> String + ;; get-host : Url (listof (cons Symbol String)) -> Symbol ;; host names are case insesitive---Internet RFC 1034 - (define DEFAULT-HOST-NAME "") + (define DEFAULT-HOST-NAME ') (define (get-host uri headers) - (let ([lower! - (lambda (s) - (string-lowercase! s) - s)]) - (cond - [(url-host uri) => lower!] - [(assq 'host headers) - => - (lambda (h) (lower! (bytes->string/utf-8 (cdr h))))] - [else DEFAULT-HOST-NAME]))) + (cond + [(url-host uri) => string->symbol] + [(assq 'host headers) + => + (lambda (h) (string->symbol (bytes->string/utf-8 (cdr h))))] + [else DEFAULT-HOST-NAME])) ;; **************************************** @@ -151,18 +148,13 @@ ;; I will move the other dispatch logic out of the prototype ;; at a later time. (define dispatch - (let* ([cache (make-hash-table 'equal)] - [sema (make-semaphore 1)] + (let* ([cache (make-cache-table)] [lookup-dispatcher (lambda (host host-info) - (hash-table-get + (cache-table-lookup! cache host - (lambda () - (call-with-semaphore - sema (lambda () - (hash-table-get - cache host - (lambda () (host-info->dispatcher host-info))))))))]) + (lambda () + (host-info->dispatcher host-info))))]) (lambda (conn req) (let* ([host (get-host (request-uri req) (request-headers req))] [host-info (config:virtual-hosts host)]) @@ -179,7 +171,7 @@ (collect-garbage) ((responders-collect-garbage (host-responders host-info))))) (servlets:gen-dispatcher host-info - config:instances config:scripts config:scripts-lock config:make-servlet-namespace) + config:instances config:scripts config:make-servlet-namespace) (files:gen-dispatcher host-info))))) (define web-server@