Author: ksprotte Date: Fri Jan 18 13:25:24 2008 New Revision: 2361
Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/packages.lisp branches/bos/projects/bos/test/allocation-area.lisp Log: all tests pass!!
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 Fri Jan 18 13:25:24 2008 @@ -104,6 +104,8 @@ (in top (collect region)))))))
;;; allocation-cache +(defvar *allocation-cache*) + (defconstant +threshold+ 200 "Free regions of size N where (<= 1 N +threshold+) are indexed.")
@@ -114,22 +116,23 @@ (defun make-allocation-cache () (make-instance 'allocation-cache))
-(defvar *allocation-cache*) +(defstruct cache-entry + area region)
(declaim (inline index-lookup index-pop index-push size-indexed-p)) (defun index-lookup (n) - "Will return the first index region of size N or + "Will return the first index cache-entry of size N or nil if it does not exist." (first (aref (allocation-cache-index *allocation-cache*) (1- n))))
(defun index-pop (n) - "As INDEX-LOOKUP, but will remove the region + "As INDEX-LOOKUP, but will remove the cache-entry from the index." (pop (aref (allocation-cache-index *allocation-cache*) (1- n))))
-(defun index-push (n region) - "Add region (which has to be of size N) to index." - (push region (aref (allocation-cache-index *allocation-cache*) (1- n)))) +(defun index-push (n cache-entry) + "Add cache-entry (which has to be of size N) to index." + (push cache-entry (aref (allocation-cache-index *allocation-cache*) (1- n))))
(defun size-indexed-p (n) "Are regions of size N indexed?" @@ -141,18 +144,27 @@ matching N can be found, simply returns NIL.
If REMOVE is T then the returned region is removed from -the cache." +the cache and FREE-M2S of the affected allocation-area +is decremented." (cond ((not (size-indexed-p n)) nil) - (remove (index-pop n)) - (t (index-lookup n)))) + (remove (let ((cache-entry (index-pop n))) + (when cache-entry + (with-slots (area region) + cache-entry + (decf (allocation-area-free-m2s area) n) + region)))) + (t (let ((cache-entry (index-lookup n))) + (when cache-entry + (cache-entry-region cache-entry))))))
(defun add-area (allocation-area) (dolist (region (free-regions allocation-area) allocation-area) (let ((size (length region))) (if (size-indexed-p size) - (index-push size region) + (index-push size (make-cache-entry :area allocation-area + :region region)) (incf (ignored-size *allocation-cache*) size)))))
(defun free-regions-count ()
Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Fri Jan 18 13:25:24 2008 @@ -227,7 +227,8 @@ :bknr.rss :bos.m2 :bos.m2.config - :iterate) + :iterate + :arnesi) (:import-from :bos.m2 bos.m2::point-in-polygon-p) (:export #:find-exact-match #:add-area
Modified: branches/bos/projects/bos/test/allocation-area.lisp ============================================================================== --- branches/bos/projects/bos/test/allocation-area.lisp (original) +++ branches/bos/projects/bos/test/allocation-area.lisp Fri Jan 18 13:25:24 2008 @@ -18,11 +18,15 @@ (finishes (make-contract sponsor m2-count)) (is (= (- (* 100 100) m2-count) (allocation-area-free-m2s area))))))
-(test allocation-area.one-contract.with-cache +(test allocation-area.one-contract.with-cache.1 (with-fixture empty-store () (let ((area (make-allocation-rectangle 0 0 2 5)) (sponsor (make-sponsor :login "test-sponsor")) (m2-count 10)) + (with-transaction () + (bos.m2::activate-allocation-area area)) + (is (= 1 (bos.m2.allocation-cache:free-regions-count))) + (is-true (bos.m2.allocation-cache:find-exact-match 10)) (finishes (make-contract sponsor m2-count)) (is (zerop (allocation-area-free-m2s area))))))