PageRenderTime 21ms CodeModel.GetById 17ms RepoModel.GetById 0ms app.codeStats 0ms

/cache.lisp

http://github.com/dmitryvk/cl-sqlite
Lisp | 59 lines | 50 code | 8 blank | 1 comment | 0 complexity | 2c8cf4645a4dc5cddb240cf59c672939 MD5 | raw file
  1. (defpackage :sqlite.cache
  2. (:use :cl :iter)
  3. (:export :mru-cache
  4. :get-from-cache
  5. :put-to-cache
  6. :purge-cache))
  7. (in-package :sqlite.cache)
  8. ;(declaim (optimize (speed 3) (safety 0) (debug 0)))
  9. (defclass mru-cache ()
  10. ((objects-table :accessor objects-table :initform (make-hash-table :test 'equal))
  11. (last-access-time-table :accessor last-access-time-table :initform (make-hash-table :test 'equal))
  12. (total-cached :type fixnum :accessor total-cached :initform 0)
  13. (cache-size :type fixnum :accessor cache-size :initarg :cache-size :initform 100)
  14. (destructor :accessor destructor :initarg :destructor :initform #'identity)))
  15. (defun get-from-cache (cache id)
  16. (let ((available-objects-stack (gethash id (objects-table cache))))
  17. (when (and available-objects-stack (> (length (the vector available-objects-stack)) 0))
  18. (decf (the fixnum (total-cached cache)))
  19. (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
  20. (vector-pop (the vector available-objects-stack)))))
  21. (defun remove-empty-objects-stacks (cache)
  22. (let ((table (objects-table cache)))
  23. (maphash (lambda (key value)
  24. (declare (type vector value))
  25. (when (zerop (length value))
  26. (remhash key table)
  27. (remhash key (last-access-time-table cache))))
  28. table)))
  29. (defun pop-from-cache (cache)
  30. (let ((id (iter (for (id time) in-hashtable (last-access-time-table cache))
  31. (when (not (zerop (length (the vector (gethash id (objects-table cache))))))
  32. (finding id minimizing (the fixnum time))))))
  33. (let ((object (vector-pop (gethash id (objects-table cache)))))
  34. (funcall (destructor cache) object)))
  35. (remove-empty-objects-stacks cache)
  36. (decf (the fixnum (total-cached cache))))
  37. (defun put-to-cache (cache id object)
  38. (when (>= (the fixnum (total-cached cache)) (the fixnum (cache-size cache)))
  39. (pop-from-cache cache))
  40. (let ((available-objects-stack (or (gethash id (objects-table cache))
  41. (setf (gethash id (objects-table cache)) (make-array 0 :adjustable t :fill-pointer t)))))
  42. (vector-push-extend object available-objects-stack)
  43. (setf (gethash id (last-access-time-table cache)) (get-internal-run-time))
  44. (incf (the fixnum (total-cached cache)))
  45. object))
  46. (defun purge-cache (cache)
  47. (iter (for (id items) in-hashtable (objects-table cache))
  48. (declare (ignorable id))
  49. (when items
  50. (iter (for item in-vector (the vector items))
  51. (funcall (destructor cache) item)))))