-

private/lru-cache.rkt

@@ -1,6 +1,7 @@
 #lang racket/base
 
-(require racket/contract)
+(require racket/contract
+         )
 
 (provide make-lru
          lru?
@@ -25,6 +26,7 @@
    compare
    [max-count #:mutable]
    [expire-in-seconds #:mutable]
+   sem
    )
   )
 
@@ -100,72 +102,96 @@
     (set-box! (lru*-cache lru) (cons (list el (current-seconds)) ncache)))
   lru)
 
+(define-syntax with-lock
+  (syntax-rules ()
+    ((_ lru code ...)
+     (dynamic-wind
+      (λ () (semaphore-wait (lru*-sem lru)))
+      (λ () (begin code ...))
+      (λ () (semaphore-post (lru*-sem lru)))
+      )
+     )
+    )
+  )
+
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;; Supporting functions
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
 (define/contract (make-lru max-count #:cmp [compare equal?] #:expire [expire-in-seconds #f])
   (->* (max-count?) (#:cmp cmp-procedure? #:expire expire?) lru*?)
-  (make-lru* (box '()) compare max-count expire-in-seconds))
+  (let ((sem (make-semaphore 1)))
+    (make-lru* (box '()) compare max-count expire-in-seconds sem)))
 
 (define/contract (lru-has? lru el)
   (-> lru*? any/c boolean?)
-  (cleanup-expired lru)
-  (find (unbox (lru*-cache lru)) (lru*-compare lru) el)
+  (with-lock lru
+    (cleanup-expired lru)
+    (find (unbox (lru*-cache lru)) (lru*-compare lru) el)
+    )
   )
 
 (define/contract (lru-add! lru el)
   (-> lru*? any/c lru*?)
-  (find-and/or-add lru el)
-  lru)
+  (with-lock lru
+    (find-and/or-add lru el)
+    lru))
 
 (define/contract (lru-clear lru)
   (-> lru*? lru*?)
-  (set-box! (lru*-cache lru) '())
-  lru)
+  (with-lock lru
+    (set-box! (lru*-cache lru) '())
+    lru))
 
 (define/contract (lru->list lru #:with-expire [we #f])
   (->* (lru*?) (#:with-expire boolean?) list?)
-  (cleanup-expired lru)
-  (let ((c (current-seconds)))
-    (map (λ (e)
-           (if we
-               (list (car e) (- c (cadr e)))
-               (car e))) (unbox (lru*-cache lru))))
+  (with-lock lru
+    (cleanup-expired lru)
+    (let ((c (current-seconds)))
+      (map (λ (e)
+             (if we
+                 (list (car e) (- c (cadr e)))
+                 (car e))) (unbox (lru*-cache lru))))
+    )
   )
 
 (define/contract (lru-count lru)
   (-> lru*? larger-equal0?)
-  (cleanup-expired lru)
-  (length (unbox (lru*-cache lru))))
+  (with-lock lru
+    (cleanup-expired lru)
+    (length (unbox (lru*-cache lru))))
+  )
 
 (define (lru? l)
   (lru*? l))
 
 (define/contract (lru-max-count l)
   (-> lru*? max-count?)
-  (lru*-max-count l))
+  (with-lock l (lru*-max-count l)))
 
 (define/contract (lru-expire l)
   (-> lru*? expire?)
-  (lru*-expire-in-seconds l))
+  (with-lock l (lru*-expire-in-seconds l)))
 
 (define/contract (set-lru-max-count! l c)
   (-> lru*? max-count? lru*?)
-  (set-lru*-max-count! l c)
-  l)
+  (with-lock l
+        (set-lru*-max-count! l c)
+        l))
 
 (define/contract (set-lru-expire! l e)
   (-> lru*? expire? lru*?)
-  (set-lru*-expire-in-seconds! l e)
-  l)
+  (with-lock l
+    (set-lru*-expire-in-seconds! l e)
+    l))
 
 (define/contract (lru-expires? l)
   (-> lru*? boolean?)
-  (let ((e (lru*-expire-in-seconds l)))
-    (if e
-        (and (integer? e) (> e 0))
-        #f)))
+  (with-lock l
+    (let ((e (lru*-expire-in-seconds l)))
+      (if e
+          (and (integer? e) (> e 0))
+          #f))))