Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv19106/src/contrib/eslick Modified Files: snapshot-db.lisp Log Message: Final hacks for snapshot-set --- /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 02:45:08 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/snapshot-db.lisp 2007/04/12 17:09:56 1.2 @@ -38,24 +38,18 @@ (in-package :elephant) -(defparameter *use-proxy-objects* t - "Indicates that the snapshot set should register - and write any standard-objects found in slots registered - of standard objects during snapshots") - (defpclass snapshot-set () ((index :accessor snapshot-set-index :initform (make-btree)) (next-id :accessor snapshot-set-next-id :initform 0) - (cache :accessor snapshot-set-cache :initform (make-hash-table) :transient t) - (root :accessor snapshot-set-root :initform nil)) + (root :accessor snapshot-set-root :initform nil) + (cache :accessor snapshot-set-cache :initform (make-hash-table) :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 this set")) -(defmethod initialize-instance :after ((set snapshot-set) &rest rest) - (declare (ignore rest)) - (restore set)) +(defmethod initialize-instance :after ((set snapshot-set) &key lazy-load &allow-other-keys) + (unless lazy-load (restore set))) ;; ================= ;; User methods @@ -63,28 +57,21 @@ (defmethod register-object ((object standard-object) (set snapshot-set)) "Register a standard object. Not recorded until snapshot is called on db" - (if (lookup-cached-id object set) nil - (let ((id (incf (snapshot-set-next-id set)))) - (cache-snapshot-object id object set) - object))) + (aif (lookup-cached-id object set) + (values object it) + (let ((id (incf (snapshot-set-next-id set)))) + (cache-snapshot-object id object set) + (values object id)))) (defmethod register-object ((hash hash-table) (set snapshot-set)) "Adds a hash table to the snapshot set and registers any standard objects stored as values that are not already part of the snapshot. Must call snapshot to save." - (if (lookup-cached-id hash set) nil - (let ((id (incf (snapshot-set-next-id set)))) - (cache-snapshot-object id hash set) - hash))) - -(defmethod set-root ((set snapshot-set)) - (if (snapshot-set-root set) - (lookup-cached-object (snapshot-set-root set) set) - nil)) - -(defmethod (setf set-root) (value (set snapshot-set)) - (setf (snapshot-set-root set) - (ensure-registered value))) + (aif (lookup-cached-id hash set) + (values hash it) + (let ((id (incf (snapshot-set-next-id set)))) + (cache-snapshot-object id hash set) + (values hash id)))) (defmethod unregister-object (object (set snapshot-set)) "Drops the object from the cache and backing store" @@ -94,36 +81,47 @@ (drop-cached-object object set) (delete-snapshot-object id set))) -(defmethod snapshot ((set snapshot-set)) - (maphash (lambda (obj id) - (write-object id obj set)) - (snapshot-set-cache set))) - -(defmethod restore ((set snapshot-set)) - "Restores a snapshot by setting the snapshot-set state to the last snapshot. - If this is used during runtime, the user needs to drop all references - to objects and retrieve again from the snapshot set" - (clear-cache set) - (let ((proxyrecs nil)) - (map-btree (lambda (k v) - (cond ((hash-table-p v) - (push (list k v) proxyrecs)) - ((subtypep (type-of v) 'standard-object) - (cache-snapshot-object k v set)) - (t (error "Invalid type in snapshot-set type ~A for ~A" (type-of v) v)))) - (snapshot-set-index set)) - ;; All objects should be loaded so object references in hashes are valid - (dolist (proxyrec proxyrecs) - (destructuring-bind (id proxy) proxyrec - (cache-snapshot-object id (restore-proxy-hash proxy set) set))))) +(defmethod snapshot-root ((set snapshot-set)) + "Get the snapshot root object" + (when (snapshot-set-root set) + (lookup-cached-object (snapshot-set-root set) set))) + +(defmethod (setf snapshot-root) (value (set snapshot-set)) + "Specify a root object for the set. There is only 1 + so it should be a hash or the root node of a graph" + (setf (snapshot-set-root set) + (multiple-value-bind (obj id) + (register-object value set) + id)) + value) (defun map-set (fn set) - "Iterates through all values in the set" + "Iterates through all values in the active set, not the + saved snapshot" (maphash (lambda (k v) (declare (ignore v)) (funcall fn k)) (snapshot-set-cache set))) +(defmethod snapshot ((set snapshot-set)) + "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)))) + +(defmethod restore ((set snapshot-set)) + "Restores a snapshot by setting the snapshot-set state to the last snapshot. + If this is used during runtime, the user needs to drop all references + to objects and retrieve again from the snapshot set. Also used to initialize + the set state when a set is created, for example pulled from the root of a + store-controller, unless :lazy-load is specified" + (clear-cache set) + (map-btree (lambda (id object) + (load-snapshot-object id object set)) + (snapshot-set-index set))) + ;; =============== ;; Shorthand ;; =============== @@ -133,6 +131,9 @@ (defun clear-cache (set) (clrhash (snapshot-set-cache set))) +(defun cache-snapshot-object (id obj set) + (setf (gethash obj (snapshot-set-cache set)) id)) + (defun lookup-cached-id (obj set) (gethash obj (snapshot-set-cache set))) @@ -145,77 +146,140 @@ (return-from find-hash-key-by-value k))) hash)) -(defun cache-snapshot-object (id obj set) - (setf (gethash obj (snapshot-set-cache set)) id)) - (defun drop-cached-object (obj set) (remhash obj (snapshot-set-cache set))) -;; Save and restore objects - -(defun read-snapshot-object (id set) - (get-value id (snapshot-set-index set))) +;; Save objects -(defun write-object (id obj set) - (setf (get-value id (snapshot-set-index set)) - (cond ((subtypep (type-of obj) 'standard-object) - (make-proxy-object obj set)) - ((eq (type-of obj) 'hash-table) - (make-proxy-hash obj set)) - (t (error "Cannot only snapshot standard-objects and hash-tables"))))) - -(defun ensure-registered (obj set) - "Return object id by cache lookup or register and write object" - (let ((id (lookup-cached-id obj set))) - (if id id - (progn - (register-object obj set) - (let ((id (lookup-cached-id obj set))) - (write-object id obj set) - id))))) - -(defun delete-snapshot-object (id set) - (remove-kv id (snapshot-set-index set))) +(defclass setref () + ((id :accessor snapshot-set-reference-id :initarg :id))) -;; Snapshot ops +(defun setrefp (obj) + (eq (type-of obj) 'setref)) -(defun reified-class-p (obj) - (or (subtypep (type-of obj) 'standard-object) - (eq (type-of obj) 'hash-table))) +(defun standard-object-subclass-p (obj) + (subtypep (type-of obj) 'standard-object)) -(defclass setref () - ((id :accessor snapshot-set-reference-id :initarg :id))) +(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")))) + id) + +(defun save-proxy-object (obj set) + (let ((svs (subsets 2 (slots-and-values obj)))) + (if (some #'reified-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) + value))) + proxy) + obj))) -(defun make-proxy-object (obj set) - (if (not *use-proxy-objects*) - obj - (let ((proxy (make-instance (type-of obj)))) - (loop for (slotname value) in (subsets 2 (slots-and-values obj)) do - (setf (slot-value proxy slotname) - (if (reified-class-p value) - (make-instance 'setref :id (ensure-registered value set)) - value)))))) -(defun make-proxy-hash (hash set) +(defun save-proxy-hash (hash set) (let ((proxy (make-hash-table))) (maphash (lambda (key value) (setf (gethash key proxy) - (if (or (subtypep (type-of value) 'standard-object) - (subtypep (type-of value) 'hash-table)) - (make-instance 'setref :id (ensure-registered value set)) + (if (reify-class-p value) + (reify-object value set) value))) hash) proxy)) -(defun restore-proxy-hash (proxy set) - "Convert a proxy object to a standard hash, resolving references" - (let ((hash (make-hash-table))) - (maphash (lambda (k v) - (setf (gethash k hash) - (if (eq (type-of v) 'setref) - (lookup-cached-object (snapshot-set-reference-id v) set) - v))) - proxy) - hash)) +(defun reify-class-p (obj) + (or (standard-object-subclass-p obj) + (hash-table-p obj))) + +(defun reify-object (obj set) + (multiple-value-bind (obj id) + (register-object obj set) + (make-instance 'setref :id (save-snapshot-object id obj set)))) + +;; Load objects + +(defun load-snapshot-object (id object set) + (let ((object (ifret object (get-value id (snapshot-set-index set))))) + (cond ((standard-object-subclass-p object) + (load-proxy-object id object set)) + ((hash-table-p object) + (load-proxy-hash id object set)) + (t (error "Unrecognized type ~A for id ~A in set ~A" (type-of object) id set))))) + +;; Need to create placeholder, then populate slots + +(defun load-proxy-object (id obj set) + (ifret (lookup-cached-object id set) + (progn + (cache-snapshot-object id obj set) + (let ((svs (subsets 2 (slots-and-values obj)))) + (loop for (slotname value) in svs do + (when (setrefp value) + (setf (slot-value obj slotname) + (load-snapshot-object (snapshot-set-reference-id value) nil set))))) + obj))) + +(defun load-proxy-hash (id hash set) + (ifret (lookup-cached-object id set) + (progn + (cache-snapshot-object id hash set) + (maphash (lambda (key value) + (when (setrefp value) + (setf (gethash key hash) + (load-snapshot-object (snapshot-set-reference-id value) nil set)))) + hash) + hash))) + + +;; Delete from snapshot + +(defun delete-snapshot-object (id set) + (remove-kv id (snapshot-set-index set))) - \ No newline at end of file +;; ============================== +;; Tests +;; ============================== + +(defclass snapshot-test () + ((slot1 :accessor slot1 :initarg :slot1) + (slot2 :accessor slot2 :initarg :slot2))) + +(defun make-stest (slot1 slot2) + (make-instance 'snapshot-test :slot1 slot1 :slot2 slot2)) + +(defun test-snapshot () + "Requires open store" + (let* ((set (make-instance 'snapshot-set)) + (hash (make-hash-table)) + (test1 (make-stest 1 2)) + (test2 (make-stest 10 20)) + (test3 (make-stest (make-stest 'one 'two) (make-stest 'three 'four))) + (test4 (make-stest (slot1 test3) (slot2 test3)))) + (loop for num from 1 + for obj in (list test1 test2 test3 test4) do + (setf (gethash num hash) obj)) + (setf (snapshot-root set) hash) + (add-to-root 'set set) + (snapshot set) + ;; Clear + (setf set nil) + (setf hash nil) + (elephant::flush-instance-cache *store-controller*) + (cl-user::gc) + ;; Reload + (setf set (get-from-root 'set)) + (setf hash (snapshot-root set)) + (let ((t1 (gethash 1 hash)) + (t2 (gethash 2 hash)) + (t3 (gethash 3 hash)) + (t4 (gethash 4 hash))) + (values + (eq 1 (slot1 t1)) + (eq 20 (slot2 t2)) + (eq (slot2 t3) + (slot2 t4))))))