Revision: 3638 Author: ksprotte URL: http://bknr.net/trac/changeset/3638

removed allocation-cache-subsystem; rebuild-allocation-cache is now called via the initialization-subsystem invoke-transient-init-functions is more verbose

U trunk/projects/bos/m2/allocation-cache.lisp U trunk/projects/bos/m2/initialization-subsystem.lisp U trunk/projects/bos/m2/m2.lisp U trunk/projects/bos/web/contract-tree.lisp

Modified: trunk/projects/bos/m2/allocation-cache.lisp =================================================================== --- trunk/projects/bos/m2/allocation-cache.lisp 2008-07-25 12:53:57 UTC (rev 3637) +++ trunk/projects/bos/m2/allocation-cache.lisp 2008-07-25 12:59:11 UTC (rev 3638) @@ -231,9 +231,9 @@ (unless (zerop count) (format t "~5D~10T~5D~%" size count))))))

-(defun rebuild-cache () - (assert (in-transaction-p) nil - "rebuild-cache may only be called in a transaction context") +(defun rebuild-allocation-cache () + (assert (or (in-transaction-p) (eql :snapshot (store-state *store*))) nil + "rebuild-allocation-cache may only be called in a transaction context") (unless *allocation-cache* (setq *allocation-cache* (make-allocation-cache))) (clear-cache) @@ -241,6 +241,8 @@ (when (allocation-area-active-p allocation-area) (add-area allocation-area))))

+(register-transient-init-function 'rebuild-allocation-cache) + (defun suggest-free-region-size () (iter (for regions in-vector (allocation-cache-index *allocation-cache*)) @@ -255,14 +257,3 @@ (index-push (length m2s) (make-cache-entry :area allocation-area :region m2s)))))

-;;; subsystem -(defclass allocation-cache-subsystem () - ()) - -(defmethod bknr.datastore::restore-subsystem (store (subsystem allocation-cache-subsystem) - &key until) - (declare (ignore until)) - (rebuild-cache)) - -(defmethod bknr.datastore::snapshot-subsystem (store (subsystem allocation-cache-subsystem)) - ) \ No newline at end of file

Modified: trunk/projects/bos/m2/initialization-subsystem.lisp =================================================================== --- trunk/projects/bos/m2/initialization-subsystem.lisp 2008-07-25 12:53:57 UTC (rev 3637) +++ trunk/projects/bos/m2/initialization-subsystem.lisp 2008-07-25 12:59:11 UTC (rev 3638) @@ -52,9 +52,11 @@

(defun invoke-transient-init-functions () (dolist (function-name *transient-init-functions*) + (format t "~&initialization-subsystem is calling ~A..." function-name) (with-simple-restart (skip-init-function "Skip transient-init-function ~A" function-name) - (funcall function-name)))) + (funcall function-name)) + (format t "done~%")))

;;; initialization-subsystem (defclass initialization-subsystem ()

Modified: trunk/projects/bos/m2/m2.lisp =================================================================== --- trunk/projects/bos/m2/m2.lisp 2008-07-25 12:53:57 UTC (rev 3637) +++ trunk/projects/bos/m2/m2.lisp 2008-07-25 12:59:11 UTC (rev 3638) @@ -710,8 +710,7 @@ :directory directory :subsystems (list (make-instance 'store-object-subsystem) (make-instance 'blob-subsystem - :n-blobs-per-directory 1000) - (make-instance 'bos.m2.allocation-cache:allocation-cache-subsystem) + :n-blobs-per-directory 1000) (make-instance 'initialization-subsystem))) (format t "~&; Startup der Quadratmeterdatenbank done.~%") (force-output))

Modified: trunk/projects/bos/web/contract-tree.lisp =================================================================== --- trunk/projects/bos/web/contract-tree.lisp 2008-07-25 12:53:57 UTC (rev 3637) +++ trunk/projects/bos/web/contract-tree.lisp 2008-07-25 12:59:11 UTC (rev 3638) @@ -357,14 +357,12 @@ :name '*contract-tree*)) (dolist (contract (class-instances 'contract)) (when (contract-published-p contract) - (insert-contract *contract-tree* contract))) - (format t "~&rendering contract-tree images if needed...") (force-output) - (format t "done.~%") (force-output) + (insert-contract *contract-tree* contract))) (geometry:register-rect-subscriber geometry:*rect-publisher* *contract-tree* (list 0 0 +width+ +width+) #'contract-tree-changed))

(register-transient-init-function 'make-contract-tree-from-m2 - 'make-quad-tree - 'geometry:make-rect-publisher) + 'make-quad-tree + 'geometry:make-rect-publisher)