Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv15325/src
Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp indexing.lisp metaclasses.lisp sql-collections.lisp Log Message:
Significant rework of portions of the indexing. Still chasing an odd test interaction but all tests pass under (do-indexing-tests) but not under (do-all-tests). Very odd. This should constitute a first feature set release. I will add tests incrementally as I work with the system.
--- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/29 04:57:20 1.16.2.4 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/30 04:55:00 1.16.2.5 @@ -79,6 +79,21 @@ metaclass.") (:metaclass persistent-metaclass))
+(defmethod initialize-instance ((instance persistent-object) &rest initargs) + (declare (ignore initargs)) + (if (indexed (class-of instance)) + (progn + (inhibit-indexing (oid instance)) + (unwind-protect + (progn + (call-next-method) + (uninhibit-indexing (oid instance)) + (let ((class-index (find-class-index (class-of instance)))) + (with-transaction () + (setf (get-value (oid instance) class-index) instance)))) + (uninhibit-indexing (oid instance)))) + (call-next-method))) + (defmethod shared-initialize :around ((class persistent-metaclass) slot-names &rest args &key direct-superclasses) "Ensures we inherit from persistent-object." (let* ((persistent-metaclass (find-class 'persistent-metaclass)) @@ -139,14 +154,14 @@ (make-instances-obsolete instance))))
;; #+allegro -(defmethod finalize-inheritance :around ((class persistent-metaclass)) +(defmethod finalize-inheritance :around ((instance persistent-metaclass)) (prog1 (call-next-method) - (when (not (slot-boundp class '%persistent-slots)) - (setf (%persistent-slots class) - (cons (persistent-slot-names class) nil))) - (when (not (slot-boundp class '%indexed-slots)) - (update-indexed-record class (indexed-slot-names-from-defs class))))) + (when (not (slot-boundp instance '%persistent-slots)) + (setf (%persistent-slots instance) + (cons (persistent-slot-names instance) nil))) + (when (not (slot-boundp instance '%indexed-slots)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)))))
;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -156,8 +171,6 @@ ;; (setf (%persistent-slots instance) ;; (cons (persistent-slot-names instance) nil)))))
-;; ISE: Not necessary for allegro 7.0? Initial values are written twice when I traced (setf slot-value-using-class) -#-allegro (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) "Initializes the persistent slots via initargs or forms. This seems to be necessary because it is typical for --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/29 04:57:20 1.10.2.4 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/30 04:55:00 1.10.2.5 @@ -154,12 +154,12 @@ ;; This just encapsulates record keeping a bit (defclass indexing-record () ((slots :accessor indexing-record-slots :initarg :slots :initform nil) - (derived-count :accessor indexing-record-derived-count :initarg :derived-count :initform 0))) + (derived-count :accessor indexing-record-derived :initarg :derived :initform 0)))
(defmethod print-object ((obj indexing-record) stream) (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>" (length (indexing-record-slots obj)) - (indexing-record-derived-count obj))) + (length (indexing-record-derived obj))))
(defmethod indexed-record ((class standard-class)) nil) @@ -176,7 +176,7 @@ (setf (%indexed-slots class) (cons (make-instance 'indexing-record :slots new-slot-list - :derived-count (if oldrec (indexing-record-derived-count oldrec) 0)) + :derived (when oldrec (indexing-record-derived oldrec))) (if oldrec oldrec nil)))))
(defun indexed-slot-names-from-defs (class) @@ -193,10 +193,10 @@ ;; update record (let ((record (indexed-record class))) (unless (member slot (car (%persistent-slots class))) - (error "Tried to index slot ~A which isn't a persistent slot" slot)) + (error "Tried to register slot ~A as index which isn't a persistent slot" slot)) (unless (member slot (indexing-record-slots record)) ;; This is a normal startup case, but during other cases we'd like -;; the duplicate wraning +;; the duplicate warning ;; (warn "Tried to index slot ~A which is already indexed" slot)) (push slot (indexing-record-slots record)))) ;; change effective slot def @@ -223,24 +223,35 @@ (defmethod register-derived-index (class name) "Tell the class that it has derived indices defined against it and keep a reference count" - (declare (ignore name)) (let ((record (indexed-record class))) - (incf (indexing-record-derived-count record)))) + (push name (indexing-record-derived record))))
(defmethod unregister-derived-index (class name) - (declare (ignore name)) (let ((record (indexed-record class))) - (decf (indexing-record-derived-count record)) - (assert (>= (indexing-record-derived-count record) 0)))) + (setf (indexing-record-derived record) (remove name (indexing-record-derived record)))))
(defmethod indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots ) (or (indexing-record-slots (indexed-record class)) - (not (= (indexing-record-derived-count (indexed-record class)) 0))))) + (indexing-record-derived (indexed-record class)))))
(defmethod indexed ((slot standard-slot-definition)) nil) (defmethod indexed ((class standard-class)) nil)
+(defvar *inhibit-indexing-list* nil + "Use this to avoid updating an index inside + low-level functions that update groups of + slots at once. We may need to rethink this + if we go to a cheaper form of update that + doesn't batch update all indices") + +(defun inhibit-indexing (uid) + (pushnew uid *inhibit-indexing-list*)) + +(defun uninhibit-indexing (uid) + (setf *inhibit-indexing-list* + (delete uid *inhibit-indexing-list*))) + ;; ;; Original support for persistent slot protocol ;; --- /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2005/11/23 17:51:37 1.2 +++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/01/30 04:55:00 1.2.2.1 @@ -47,7 +47,6 @@ (:metaclass persistent-metaclass) (:documentation "A SQL-based BTree supports secondary indices."))
- (defmethod get-value (key (bt sql-btree-index)) "Get the value in the primary DB from a secondary key." (declare (optimize (speed 3)))