r8073: add def-cached-vector

[kmrcl.git] / macros.lisp

diff --git a/macros.lisp b/macros.lisp
index 835c6d91bcac3cffabaf49d425fe1a623a02c1d6..5b7286590fa0e18647629f14171e3ffdb3c99a5c 100644 (file)
--- a/macros.lisp
+++ b/macros.lisp
@@ -187,3 +187,31 @@
       ,@(when docp
              `((setf (documentation ',var 'variable) ,doc)))
       (define-symbol-macro ,var ,backing-var))))
+
+(defmacro def-cached-vector (name element-type)
+  (let ((get-name (concat-symbol "get-" name "-vector"))
+       (release-name (concat-symbol "release-" name "-vector"))
+       (table-name (concat-symbol "*cached-" name "-table*"))
+       (lock-name (concat-symbol "*cached-" name "-lock*")))
+    `(eval-when (:compile-toplevel :load-toplevel :execute)
+       (defvar ,table-name (make-hash-table :test 'equal))
+       (defvar ,lock-name (kmrcl::make-lock ,name))
+        
+        (defun ,get-name (size)
+          (kmrcl::with-lock-held (,lock-name)
+            (let ((buffers (gethash (cons size ,element-type) ,table-name)))
+              (if buffers
+                  (let ((buffer (pop buffers)))
+                    (setf (gethash (cons size ,element-type) ,table-name) buffers)
+                    buffer)
+                (make-array size :element-type ,element-type)))))
+        
+        (defun ,release-name (buffer)
+          (kmrcl::with-lock-held (,lock-name)
+            (let ((buffers (gethash (cons (array-total-size buffer)
+                                          ,element-type)
+                                    ,table-name)))
+              (setf (gethash (cons (array-total-size buffer)
+                                   ,element-type) ,table-name)
+                (cons buffer buffers))))))))
+