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

[ksprotte at common-lisp.net]

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