Author: ksprotte Date: Mon Jan 21 10:39:51 2008 New Revision: 2378

Modified: branches/bos/projects/bos/m2/allocation-cache.lisp branches/bos/projects/bos/m2/allocation-test.lisp branches/bos/projects/bos/m2/allocation.lisp branches/bos/projects/bos/m2/packages.lisp Log: allocation-cache now updated for RETURN-M2S

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 Mon Jan 21 10:39:51 2008 @@ -219,6 +219,15 @@ (unless (zerop region-count) (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)))) + ;;; subsystem (defclass allocation-cache-subsystem () ())

Modified: branches/bos/projects/bos/m2/allocation-test.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation-test.lisp (original) +++ branches/bos/projects/bos/m2/allocation-test.lisp Mon Jan 21 10:39:51 2008 @@ -55,3 +55,39 @@ (is (= (- 64 10) (allocation-area-free-m2s area))) (signals (error) (make-contract sponsor 64)))))

+(store-test allocation-area.return-m2s + (let* ((area (make-allocation-rectangle 0 0 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (contract (make-contract sponsor 64))) + (with-store-reopenings (area sponsor contract) + (is (zerop (allocation-area-free-m2s area))) + (signals (error) (make-contract sponsor 64)) + (with-transaction () + (destroy-object contract)) + (is-true (bos.m2.allocation-cache:find-exact-match 64)) + (finishes (make-contract sponsor 10)) + (is (= (- (* 8 8) 10) (allocation-area-free-m2s area)))))) + +(test allocation-area.two-areas + (with-fixture empty-store () + (let ((snapshot nil) (bypass t)) + (declare (ignorable snapshot bypass)) + (let* ((area1 (make-allocation-rectangle 0 0 8 8)) + (area2 (make-allocation-rectangle 10 10 8 8)) + (sponsor (make-sponsor :login "test-sponsor")) + (total-free (+ 64 64))) + (progn + (iter (while (> total-free 20)) + (bos.m2.allocation-cache:rebuild-cache) + (for size = (1+ (random 3))) + (is (= total-free (+ (allocation-area-free-m2s area1) + (allocation-area-free-m2s area2)))) + (with-transaction () + (iter + (while (> size total-free)) + (for contract = (first (class-instances 'contract))) + (incf total-free (length (contract-m2s contract))) + (destroy-object contract))) + (finishes (make-contract sponsor size)) + (decf total-free size))))))) +

Modified: branches/bos/projects/bos/m2/allocation.lisp ============================================================================== --- branches/bos/projects/bos/m2/allocation.lisp (original) +++ branches/bos/projects/bos/m2/allocation.lisp Mon Jan 21 10:39:51 2008 @@ -641,7 +641,7 @@ (warn "all allocation areas exhausted") nil))

-(defun return-m2s (m2s) +(defmethod return-m2s (m2s) "Mark the given square meters as free, so that they can be re-allocated." (when m2s (loop for m2 in m2s

Modified: branches/bos/projects/bos/m2/packages.lisp ============================================================================== --- branches/bos/projects/bos/m2/packages.lisp (original) +++ branches/bos/projects/bos/m2/packages.lisp Mon Jan 21 10:39:51 2008 @@ -87,6 +87,7 @@ #:m2-utm-x #:m2-utm-y #:escape-nl + #:return-m2s

#:sponsor #:make-sponsor