Author: ksprotte Date: Tue Jan 22 08:02:50 2008 New Revision: 2389

Modified: branches/bos/projects/bos/m2/allocation-cache.lisp Log: added hit-count / miss-count to allocation-cache

Modified: branches/bos/projects/bos/m2/allocation-cache.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-cache.lisp (original) +++ branches/bos/projects/bos/m2/allocation-cache.lisp Tue Jan 22 08:02:50 2008 @@ -104,18 +104,29 @@ (in top (collect region)))))))

;;; allocation-cache -(defvar *allocation-cache*) +(defparameter *allocation-cache* nil)

(defconstant +threshold+ 200 "Free regions of size N where (<= 1 N +threshold+) are indexed.")

(defclass allocation-cache () ((index :reader allocation-cache-index :initform (make-array 200 :initial-element nil)) - (ignored-size :accessor ignored-size :initform 0))) + (ignored-size :accessor ignored-size :initform 0) + (hit-count :accessor hit-count :initform 0) + (miss-count :accessor miss-count :initform 0)))

(defun make-allocation-cache () (make-instance 'allocation-cache))

+(defun clear-cache () + (macrolet ((index () + '(allocation-cache-index *allocation-cache*))) + (iter + (for i index-of-vector (index)) + (setf (aref (index) i) nil)) + (setf (ignored-size *allocation-cache*) 0) + *allocation-cache*)) + (defstruct cache-entry area region)

@@ -173,14 +184,18 @@ If REMOVE is T then the returned region is removed from the cache and FREE-M2S of the affected allocation-area is decremented." - (cond - ((not (size-indexed-p n)) nil) - (remove (awhen (index-pop n) - (with-slots (area region) it - (decf (allocation-area-free-m2s area) n) - region))) - (t (awhen (index-lookup n) - (cache-entry-region it))))) + (let ((region (cond + ((not (size-indexed-p n)) nil) + (remove (awhen (index-pop n) + (with-slots (area region) it + (decf (allocation-area-free-m2s area) n) + region))) + (t (awhen (index-lookup n) + (cache-entry-region it)))))) + (if region + (incf (hit-count *allocation-cache*)) + (incf (miss-count *allocation-cache*))) + region))

(defun add-area (allocation-area) (dolist (region (free-regions allocation-area) @@ -197,18 +212,29 @@ (summing (length regions))))

(defun pprint-cache () - (format t "~5A~10T~A~%" "size" "count") - (format t "~5A~10T~A~%" "-----" "-----") - (iter - (for cache-entries in-vector (allocation-cache-index *allocation-cache*)) - (for size upfrom 1) - (for count = (length cache-entries)) - (unless (zerop count) - (format t "~5D~10T~5D~%" size count))) - (format t "~%number of m2 not in cache: ~A~%" (ignored-size *allocation-cache*))) + (with-accessors ((hits hit-count) + (misses miss-count)) + *allocation-cache* + (let* ((total (+ (float (+ hits misses)) 0.001)) ; avoid getting 0 here + (hits-perc (round (* 100.0 (/ (float hits) total)))) + (misses-perc (round (* 100.0 (/ (float misses) total))))) + (format t "cache hits:~15T~5D~25T~3D%~%" hits hits-perc) + (format t "cache misses:~15T~5D~25T~3D%~3%" misses misses-perc) + (format t "CACHE ENTRIES~2%") + (format t "number of m2 not in cache: ~A~2%" (ignored-size *allocation-cache*)) + (format t "~5A~10T~A~%" "size" "count") + (format t "~5A~10T~A~%" "-----" "-----") + (iter + (for cache-entries in-vector (allocation-cache-index *allocation-cache*)) + (for size upfrom 1) + (for count = (length cache-entries)) + (unless (zerop count) + (format t "~5D~10T~5D~%" size count))))))

(defun rebuild-cache () - (setq *allocation-cache* (make-allocation-cache)) + (unless *allocation-cache* + (setq *allocation-cache* (make-allocation-cache))) + (clear-cache) (dolist (allocation-area (class-instances 'allocation-area)) (when (allocation-area-active-p allocation-area) (add-area allocation-area)))) @@ -222,10 +248,6 @@ (leave size))))

(defmethod return-m2s :after (m2s) - ;; bos.m2::m2-allocation-area is quite - ;; expensive... - ;; (assert (every #'(lambda (m2) (eq (bos.m2::m2-allocation-area (first m2s)) (bos.m2::m2-allocation-area m2))) - ;; (rest m2s))) (let ((allocation-area (bos.m2::m2-allocation-area (first m2s)))) (index-push (length m2s) (make-cache-entry :area allocation-area :region m2s))))