Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv25569/src/contrib/eslick
Modified Files: snapshot-db.lisp Log Message: final snapshot scenario and code changes
--- /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 17:16:59 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/19 22:25:52 1.4 @@ -35,6 +35,17 @@ ;; to slots are saved to a persistent list that gets reused after ;; snapshots (id slotname value). Slot reads are as usual. ;; +;; - Avoid stack use during recursions. Push new objects onto a stack +;; for later processing so stack depth is constant. +;; +;; - In place restores. A future version could traverse the existing +;; object cache, dropping new references and restoring old ones +;; according to the state of the snapshot-set on disk such that the +;; existing in-memory lisp pointers were still valid..as long as there +;; were not external pointers into objects that are dropped leading to +;; an inconsistency. +;; +
(in-package :elephant)
@@ -42,7 +53,10 @@ ((index :accessor snapshot-set-index :initform (make-btree)) (next-id :accessor snapshot-set-next-id :initform 0) (root :accessor snapshot-set-root :initform nil) - (cache :accessor snapshot-set-cache :initform (make-hash-table) :transient t)) + (cache :accessor snapshot-set-cache :initform (make-hash-table :weak-keys t) :transient t) + (touched :accessor snapshot-set-touched + :initform (make-array 20 :element-type 'fixnum :initial-element 0 :fill-pointer t :adjustable t) + :transient t)) (:documentation "Keeps track of a set of standard objects allowing a single snapshot call to update the store controller with the latest state of all objects registered with @@ -95,6 +109,7 @@ (setf (snapshot-set-root set) (multiple-value-bind (obj id) (register-object value set) + (declare (ignore obj)) id)) value)
@@ -110,9 +125,10 @@ "Saves all objects in the set (and any objects reachable from the current set of objects) to the persistent store" (with-transaction (:store-controller (get-con (snapshot-set-index set))) - (maphash (lambda (obj id) - (save-snapshot-object id obj set)) - (snapshot-set-cache set)))) + (loop for (obj . id) in (get-cache-entries (snapshot-set-cache set)) do + (save-snapshot-object id obj set)) + (collect-untouched set)) + (values set t))
(defmethod restore ((set snapshot-set)) "Restores a snapshot by setting the snapshot-set state to the last snapshot. @@ -123,7 +139,8 @@ (clear-cache set) (map-btree (lambda (id object) (load-snapshot-object id object set)) - (snapshot-set-index set))) + (snapshot-set-index set)) + (values set t))
;; =============== ;; Shorthand @@ -152,6 +169,13 @@ (defun drop-cached-object (obj set) (remhash obj (snapshot-set-cache set)))
+(defun get-cache-entries (hash) + (let ((result nil)) + (maphash (lambda (obj id) + (push (cons obj id) result)) + hash) + result)) + ;; Save objects
(defclass setref () @@ -163,34 +187,45 @@ (defun standard-object-subclass-p (obj) (subtypep (type-of obj) 'standard-object))
+(defun touch (id set) + (vector-push-extend id (snapshot-set-touched set) 50)) + +(defun touched (id set) + (find id (snapshot-set-touched set))) + +(defun clear-touched (set) + (loop for i fixnum from 0 upto (1- (length (snapshot-set-touched set))) do + (setf (aref (snapshot-set-touched set) i) 0))) + (defun save-snapshot-object (id obj set) - (setf (get-value id (snapshot-set-index set)) - (cond ((standard-object-subclass-p obj) - (save-proxy-object obj set)) - ((hash-table-p obj) - (save-proxy-hash obj set)) - (t (error "Cannot only snapshot standard-objects and hash-tables")))) + (unless (touched id set) + (setf (get-value id (snapshot-set-index set)) + (cond ((standard-object-subclass-p obj) + (save-proxy-object obj set)) + ((hash-table-p obj) + (save-proxy-hash obj set)) + (t (error "Cannot only snapshot standard-objects and hash-tables")))) + (touch id set)) id)
(defun save-proxy-object (obj set) (let ((svs (subsets 2 (slots-and-values obj)))) - (if (some #'reified-class-p (mapcar #'second svs)) + (if (some #'reify-class-p (mapcar #'second svs)) (let ((proxy (make-instance (type-of obj)))) (loop for (slotname value) in svs do (setf (slot-value proxy slotname) (if (reify-class-p value) - (reify-object value set) + (reify-value value set) value))) proxy) obj)))
- (defun save-proxy-hash (hash set) (let ((proxy (make-hash-table))) (maphash (lambda (key value) (setf (gethash key proxy) (if (reify-class-p value) - (reify-object value set) + (reify-value value set) value))) hash) proxy)) @@ -199,11 +234,19 @@ (or (standard-object-subclass-p obj) (hash-table-p obj)))
-(defun reify-object (obj set) +(defun reify-value (obj set) (multiple-value-bind (obj id) (register-object obj set) (make-instance 'setref :id (save-snapshot-object id obj set))))
+(defun collect-untouched (set) + (map-btree (lambda (k v) + (declare (ignore v)) + (unless (touched k set) + (remove-kv k (snapshot-set-index set)))) + (snapshot-set-index set)) + (clear-touched set)) + ;; Load objects
(defun load-snapshot-object (id object set) @@ -273,7 +316,8 @@ (setf set nil) (setf hash nil) (elephant::flush-instance-cache *store-controller*) - (cl-user::gc) + #+allegro (excl:gc) + #+sbcl (cl-user::gc) ;; Reload (setf set (get-from-root 'set)) (setf hash (snapshot-root set))