[elephant-cvs] CVS elephant/src/contrib/eslick

[ieslick]

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))