- (let ((entry (gethash size *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (cond ((null entry)
- (setf (gethash size *free-cache-vectors*) (cons 0 nil))
- (get-cache-vector size))
- ((null (cdr entry))
- (incf (car entry))
- (flush-cache-vector-internal (allocate-cache-vector size)))
- (t
- (let ((cache (cdr entry)))
- (setf (cdr entry) (cache-vector-ref cache 0))
- (flush-cache-vector-internal cache)))))))
-
-(defun free-cache-vector (cache-vector)
- (let ((entry (gethash (cache-vector-size cache-vector) *free-cache-vectors*)))
- (sb-sys:without-interrupts
- (if (null entry)
- (error
- "attempt to free a cache-vector not allocated by GET-CACHE-VECTOR")
- (let ((thread (cdr entry)))
- (loop (unless thread (return))
- (when (eq thread cache-vector)
- (error "freeing a cache twice"))
- (setq thread (cache-vector-ref thread 0)))
- (flush-cache-vector-internal cache-vector) ; to help the GC
- (setf (cache-vector-ref cache-vector 0) (cdr entry))
- (setf (cdr entry) cache-vector)
- nil)))))
-
-;;; This is just for debugging and analysis. It shows the state of the
-;;; free cache resource.
-#+sb-show
-(defun show-free-cache-vectors ()
- (let ((elements ()))
- (maphash (lambda (s e) (push (list s e) elements)) *free-cache-vectors*)
- (setq elements (sort elements #'< :key #'car))
- (dolist (e elements)
- (let* ((size (car e))
- (entry (cadr e))
- (allocated (car entry))
- (head (cdr entry))
- (free 0))
- (loop (when (null head) (return t))
- (setq head (cache-vector-ref head 0))
- (incf free))
- (format t
- "~&There are ~4D caches of size ~4D. (~D free ~3D%)"
- allocated
- size
- free
- (floor (* 100 (/ free (float allocated)))))))))