[bknr-cvs] ksprotte changed trunk/projects/bos/m2/allocation.lisp - bknr-cvs@common-lisp.net - mailman3.common-lisp.net

25 Jul 2008

Revision: 3639
Author: ksprotte
URL: http://bknr.net/trac/changeset/3639
allocate-m2s-for-sale uses again the allocate-cache with exact matches
U   trunk/projects/bos/m2/allocation.lisp
Modified: trunk/projects/bos/m2/allocation.lisp
===================================================================

--- trunk/projects/bos/m2/allocation.lisp	2008-07-25 12:59:11 UTC (rev 3638)
+++ trunk/projects/bos/m2/allocation.lisp	2008-07-25 13:13:02 UTC (rev 3639)
@@ -195,13 +195,13 @@
 (deftransaction activate-allocation-area (area)
   (warn "activating ~S" area)
   (setf (slot-value area 'active-p) t)
-  (bos.m2.allocation-cache::rebuild-cache)
+  (bos.m2.allocation-cache::rebuild-allocation-cache)
   area)
(deftransaction deactivate-allocation-area (area)
   (warn "deactivating ~S" area)
   (setf (slot-value area 'active-p) nil)
-  (bos.m2.allocation-cache::rebuild-cache)
+  (bos.m2.allocation-cache::rebuild-allocation-cache)
   area)
;;; FIXME can be optimized
@@ -358,17 +358,18 @@
   "The main entry point to the allocation machinery. Will return a
    list of N m2 instances or NIL if the requested amount cannot be
    allocated."
-  (dolist (area (active-allocation-areas))
-    (when (<= n (allocation-area-free-m2s area))
-      (let ((m2s (allocate-in-area area n)))
-        (when m2s
-          (return-from allocate-m2s-for-sale m2s)))))
-  (dolist (area (inactive-nonempty-allocation-areas))
-    (when (<= n (allocation-area-free-m2s area))
-      (let ((m2s (allocate-in-area area n)))
-        (when m2s
-          (activate-allocation-area area)
-          (return-from allocate-m2s-for-sale m2s))))))
+  (or (bos.m2.allocation-cache:find-exact-match n :remove t)
+      (dolist (area (active-allocation-areas))
+        (when (<= n (allocation-area-free-m2s area))
+          (let ((m2s (allocate-in-area area n)))
+            (when m2s
+              (return m2s)))))
+      (dolist (area (inactive-nonempty-allocation-areas))
+        (when (<= n (allocation-area-free-m2s area))
+          (let ((m2s (allocate-in-area area n)))
+            (when m2s
+              (activate-allocation-area area)
+              (return m2s)))))))
(defgeneric return-contract-m2s (m2s)
   (:documentation "Mark the given square meters as free, so that

    