[bknr-cvs] r2389 - branches/bos/projects/bos/m2

[ksprotte at common-lisp.net]

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))))