From 2bf8937e7b9de101c16ab4d21adae0b755c1e3d6 Mon Sep 17 00:00:00 2001
From: Jay McCarthy <jay@racket-lang.org>
Date: Mon, 26 Jun 2006 21:17:00 +0000
Subject: [PATCH] lru manager

svn: r3483
---
 collects/web-server/managers/lru.ss | 147 ++++++++++++++++++++++++++++
 1 file changed, 147 insertions(+)
 create mode 100644 collects/web-server/managers/lru.ss

diff --git a/collects/web-server/managers/lru.ss b/collects/web-server/managers/lru.ss
new file mode 100644
index 0000000000..dc15e8d1fd
--- /dev/null
+++ b/collects/web-server/managers/lru.ss
@@ -0,0 +1,147 @@
+(module lru mzscheme
+  (require (lib "plt-match.ss"))
+  (require "manager.ss")
+  (provide create-LRU-manager)
+  
+  ;; Utility
+  (define (make-counter)
+    (define i 0)
+    (lambda ()
+      (set! i (add1 i))
+      i))
+  
+  (define-struct (LRU-manager manager) (instance-expiration-handler
+                                        ; Private
+                                        instances
+                                        next-instance-id))
+  (define (create-LRU-manager
+           instance-expiration-handler
+           collect?)
+    ;; Instances
+    (define instances (make-hash-table))
+    (define next-instance-id (make-counter))    
+    
+    (define-struct instance (data k-table))  
+    (define (create-instance data expire-fn)
+      (define instance-id (next-instance-id))
+      (hash-table-put! instances
+                       instance-id
+                       (make-instance data (create-k-table)))
+      instance-id)
+    (define (adjust-timeout! instance-id secs)
+      (void))
+    
+    (define (instance-lookup instance-id)
+      (define instance
+        (hash-table-get instances instance-id
+                        (lambda ()
+                          (raise (make-exn:fail:servlet-manager:no-instance
+                                  (string->immutable-string
+                                   (format "No instance for id: ~a" instance-id))
+                                  (current-continuation-marks)
+                                  instance-expiration-handler)))))
+      instance)
+    
+    ;; Continuation table
+    (define-struct k-table (next-id-fn htable))
+    (define (create-k-table)
+      (make-k-table (make-counter) (make-hash-table)))
+    
+    ;; Interface
+    (define (instance-lookup-data instance-id)
+      (instance-data (instance-lookup instance-id)))
+    
+    (define (clear-continuations! instance-id)
+      (match (instance-lookup instance-id)
+        [(struct instance (data (and k-table (struct k-table (next-id-fn htable)))))
+         (hash-table-for-each
+          htable
+          (match-lambda*
+            [(list k-id (list salt k expiration-handler count))
+             (hash-table-put! htable k-id
+                              (list salt #f expiration-handler count))]))]))
+    
+    (define (continuation-store! instance-id k expiration-handler)
+      (match (instance-lookup instance-id)
+        [(struct instance (data (struct k-table (next-id-fn htable))))
+         (define k-id (next-id-fn))
+         (define salt (random 100000000))
+         (hash-table-put! htable
+                          k-id
+                          (list salt k expiration-handler 1))
+         (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))))
+         (match
+             (hash-table-get htable a-k-id
+                             (lambda ()
+                               (raise (make-exn:fail:servlet-manager:no-continuation
+                                       (string->immutable-string 
+                                        (format "No continuation for id: ~a" a-k-id))
+                                       (current-continuation-marks)
+                                       instance-expiration-handler))))
+           [(list salt k expiration-handler count)
+            (hash-table-put! htable a-k-id
+                             (list salt k expiration-handler (add1 count)))
+            (if (or (not (eq? salt a-salt))
+                    (not k))
+                (raise (make-exn:fail:servlet-manager:no-continuation
+                        (string->immutable-string
+                         (format "No continuation for id: ~a" a-k-id))
+                        (current-continuation-marks)
+                        (if expiration-handler
+                            expiration-handler
+                            instance-expiration-handler)))
+                k)])]))
+    
+    (define the-manager
+      (make-LRU-manager create-instance 
+                        adjust-timeout!
+                        instance-lookup-data
+                        clear-continuations!
+                        continuation-store!
+                        continuation-lookup
+                        ; Specific
+                        instance-expiration-handler
+                        ; Private
+                        instances
+                        next-instance-id))
+    
+    ; Collector
+    (define (collect)
+      (define removed (box 0))
+      (when (collect?)
+        (hash-table-for-each
+         instances
+         (match-lambda*
+           [(list instance-id (struct instance (_ (struct k-table (next-id-fn htable)))))
+            (define empty? (box #t))
+            (hash-table-for-each
+             htable
+             (match-lambda*
+               [(list k-id (list s k eh count))
+                (if (zero? count)
+                    (begin (set-box! removed (add1 (unbox removed)))
+                           (hash-table-remove! htable k-id))
+                    (begin (set-box! empty? #f)
+                           (hash-table-put! htable k-id
+                                            (list s k eh (sub1 count)))))]))
+            (when (unbox empty?)
+              (set-box! removed (add1 (unbox removed)))
+              (hash-table-remove! instances instance-id))])))
+      (unless (zero? (unbox removed))
+        #;(printf "Collect: ~S ~S~n"
+                  (unbox removed)                 
+                  (round (/ (current-memory-use)
+                            (* 1024 1024))))
+        (collect-garbage)
+        (collect-garbage)))
+    (define manager-thread
+      (thread
+       (lambda ()
+         (let loop ()
+           (collect)
+           (loop)))))
+    
+    the-manager))
\ No newline at end of file