[bknr-cvs] ksprotte changed trunk/projects/bos/m2/
BKNR Commits
bknr at bknr.net
Fri Sep 12 14:05:52 UTC 2008
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
More information about the Bknr-cvs
mailing list