Revision: 3895 Author: ksprotte URL: http://bknr.net/trac/changeset/3895
bos big changes for allocation mechanics
- ensure-m2 now uses (make-object 'm2 ...) instead of make-instance - make-contract has been restructured: - allocate-m2s-for-sale is called first - outside a transactional context - free m2s are then passed to (make-object 'contract ...)
- allocation-area-free-m2s is now transient and computed lazily the first time when it is read
U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/m2/allocation.lisp U trunk/projects/bos/m2/m2.lisp
Modified: trunk/projects/bos/m2/allocation-cache.lisp =================================================================== --- trunk/projects/bos/m2/allocation-cache.lisp 2008-09-12 13:42:55 UTC (rev 3894) +++ trunk/projects/bos/m2/allocation-cache.lisp 2008-09-12 14:05:52 UTC (rev 3895) @@ -177,25 +177,27 @@ (<= 1 n +threshold+))
(defun find-exact-match (n &key remove) - "Will return a free contiguous region of size N -as a list of m2 instances. If no such region exactly -matching N can be found, simply returns NIL. + "Will return a free contiguous region of size N as a list of m2 +instances and as a second value the corresponding allocation-area. If +no such region exactly matching N can be found, simply returns NIL.
If REMOVE is T then the returned region is removed from -the cache and FREE-M2S of the affected allocation-area -is decremented." - (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)) +the cache." + (flet ((hit (cache-entry) + (incf (hit-count *allocation-cache*)) + (values (cache-entry-region cache-entry) + (cache-entry-area cache-entry))) + (miss () + (incf (miss-count *allocation-cache*)) + nil)) + (cond + ((not (size-indexed-p n)) (miss)) + (remove (aif (index-pop n) + (hit it) + (miss))) + (t (aif (index-lookup n) + (hit it) + (miss))))))
(defun add-area (allocation-area) (dolist (region (free-regions allocation-area)
Modified: trunk/projects/bos/m2/allocation.lisp =================================================================== --- trunk/projects/bos/m2/allocation.lisp 2008-09-12 13:42:55 UTC (rev 3894) +++ trunk/projects/bos/m2/allocation.lisp 2008-09-12 14:05:52 UTC (rev 3895) @@ -1,16 +1,15 @@ (in-package :bos.m2)
-(define-persistent-class allocation-area () - ((active-p :update) - (left :update) - (top :update) - (width :update) - (height :update) - (vertices :update) - (y :update) - (total-m2s :read) - (free-m2s :update) - (bounding-box :update :transient t)) +(defpersistent-class allocation-area () + ((active-p :accessor allocation-area-active-p :initarg :active-p) + (left :reader allocation-area-left :initarg :left) + (top :reader allocation-area-top :initarg :top) + (width :reader allocation-area-width :initarg :width) + (height :reader allocation-area-height :initarg :height) + (vertices :reader allocation-area-vertices :initarg :vertices) + (total-m2s :reader allocation-area-total-m2s) + (free-m2s :transient t :writer (setf allocation-area-free-m2s)) ;free-m2s reader defined below + (bounding-box :transient t :reader allocation-area-bounding-box)) (:documentation "A polygon in which to allocate meters. LEFT, TOP, WIDTH, and HEIGHT designate the bounding rectangle of the polygon. @@ -34,10 +33,17 @@ :unbound) (store-object-id allocation-area))))
+(defmethod allocation-area-free-m2s ((area allocation-area)) + (flet ((compute-free-m2s () + (with-slots (total-m2s free-m2s) area + (setf free-m2s (- total-m2s (calculate-allocated-m2-count area)))))) + (if (slot-boundp area 'free-m2s) + (slot-value area 'free-m2s) + (compute-free-m2s)))) + (defmethod initialize-persistent-instance :after ((allocation-area allocation-area) &key) - (with-slots (total-m2s free-m2s) allocation-area - (setf total-m2s (calculate-total-m2-count allocation-area)) - (setf free-m2s (- total-m2s (calculate-allocated-m2-count allocation-area)))) + (with-slots (total-m2s) allocation-area + (setf total-m2s (calculate-total-m2-count allocation-area))) ;; FIXME probably we dont need this and should rely on *rect-publisher* (dolist (tile (allocation-area-tiles allocation-area)) (image-tile-changed tile))) @@ -48,7 +54,7 @@ (defmethod destroy-object :before ((allocation-area allocation-area)) (notify-tiles allocation-area))
-(defmethod initialize-transient-instance :after ((allocation-area allocation-area)) +(defmethod initialize-transient-instance :after ((allocation-area allocation-area)) (notify-tiles allocation-area))
(defun compute-bounding-box (vertices) @@ -348,29 +354,33 @@ (result (search-adjacent n m2 #'allocatable-p))) (when result (assert (alexandria:setp result :test #'equal)) - (assert (= n (length result))) - (decf (allocation-area-free-m2s area) n) + (assert (= n (length result))) (return result)) (when (> (get-internal-real-time) deadline) (return nil)))))))
(defun allocate-m2s-for-sale (n) "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." - (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))))))) +list of N m2 instances or NIL if the requested amount cannot be +allocated. As a second value, returns the corresponding +allocation-area.
+The returned m2s are still free and (decf (allocation-area-free-m2s +area) n) has not yet happened." + (alexandria:nth-value-or 0 + (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 (values m2s area)))))) + (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 (values m2s area)))))))) + (defgeneric return-contract-m2s (m2s) (:documentation "Mark the given square meters as free, so that they can be re-allocated."))
Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-09-12 13:42:55 UTC (rev 3894) +++ trunk/projects/bos/m2/m2.lisp 2008-09-12 14:05:52 UTC (rev 3895) @@ -55,8 +55,8 @@
(defun ensure-m2 (&rest coords) (or (m2-at coords) - (destructuring-bind (x y) coords - (make-instance 'm2 :x x :y y)))) + (destructuring-bind (x y) coords + (make-object 'm2 :x x :y y))))
(defmethod get-m2-with-num ((num integer)) (multiple-value-bind (y x) (truncate num +width+) @@ -296,9 +296,9 @@ (when sponsor (setf (sponsor-contracts sponsor) (remove contract (sponsor-contracts sponsor))))) (publish-contract-change contract :type 'delete) + (return-contract-m2s (contract-m2s contract)) (dolist (m2 (contract-m2s contract)) - (setf (m2-contract m2) nil)) - (return-contract-m2s (contract-m2s contract))) + (setf (m2-contract m2) nil)))
(defun get-contract (id) (let ((contract (store-object-with-id id))) @@ -499,26 +499,14 @@ (warn "Old tx-make-contract transaction used, contract dates may be wrong") (tx-do-make-contract sponsor m2-count :date date :paidp paidp :expires expires))
-(deftransaction do-make-contract (sponsor m2-count &key date paidp expires download-only) - (let ((m2s (allocate-m2s-for-sale m2-count))) - (if m2s - (let ((contract (make-object 'contract - :sponsor sponsor - :date date - :m2s m2s - :expires expires - :download-only download-only))) - (when paidp - (contract-set-paidp contract paidp)) - contract) - (warn "can't create contract, ~A square meters for ~A could not be allocated" m2-count sponsor)))) - (define-condition allocation-areas-exhausted (simple-error) ((numsqm :initarg :numsqm :reader numsqm)) (:report (lambda (condition stream) (format stream "Could not satisfy your request for ~A sqms, please contact the BOS office" (numsqm condition)))))
+(defvar *make-contract-lock* (bt:make-lock "make-contract-lock")) + (defun make-contract (sponsor m2-count &key (date (get-universal-time)) paidp @@ -527,22 +515,30 @@ (unless (and (integerp m2-count) (plusp m2-count)) (error "number of square meters must be a positive integer")) - (let ((contract (do-make-contract sponsor m2-count - :date date - :paidp paidp - :expires expires - :download-only download-only))) - (unless contract - (send-system-mail :subject "Contact creation failed - Allocation areas exhaused" - :text (format nil "A contract for ~A square meters could not be created, presumably because no + (bt:with-lock-held (*make-contract-lock*) + (multiple-value-bind (m2s area) + (allocate-m2s-for-sale m2-count) + (unless m2s + (warn "can't create contract, ~A square meters for ~A could not be allocated" m2-count sponsor) + (send-system-mail :subject "Contact creation failed - Allocation areas exhaused" + :text (format nil "A contract for ~A square meters could not be created, presumably because no suitable allocation area was found. Please check the free allocation areas and add more space.
Sponsor-ID: ~A " - m2-count (store-object-id sponsor))) - (error 'allocation-areas-exhausted :numsqm m2-count)) - contract)) + m2-count (store-object-id sponsor))) + (error 'allocation-areas-exhausted :numsqm m2-count)) + ;; FREE-M2S might be lazily computed at his point, before it is + ;; decremented. If this happens, the m2s must still be free. + (decf (allocation-area-free-m2s area) m2-count) + (make-object 'contract + :sponsor sponsor + :date date + :m2s m2s + :expires expires + :download-only download-only + :paidp paidp))))
(deftransaction recolorize-contracts (&optional colors) "Assigns a new color to each contract choosing from COLORS, so