Creating cache-table for performance!

svn: r731

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

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

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

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

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

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 "<none>")
+  (define DEFAULT-HOST-NAME '<none>)
   (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@