Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16753/src/elephant
Modified Files: classindex.lisp collections.lisp controller.lisp package.lisp transactions.lisp Log Message: Cleaning up root directory files; map-index performance enhancement, index api cleanup, ensure transaction fix, alpha quality documentation draft
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/24 12:58:10 1.39 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/04/28 02:31:15 1.40 @@ -84,11 +84,23 @@ (let ((class (find-class class-name nil))) (when class (indexed class))))
+(define-condition persistent-class-not-indexed (error) + ((class-obj :initarg :class :initarg nil :reader unindexed-class-obj))) + +(defun signal-class-not-indexed (class) + (cerror "Ignore and continue?" + 'persistent-class-not-indexed + :format-control "Class ~A is not enabled for indexing" + :format-arguments (list (class-name class)) + :class class)) + +;; (define-condition + (defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) (ensure-finalized class) (if (not (indexed class)) (when errorp - (error "Class ~A is not an indexed class" class)) + (signal-class-not-indexed class)) (if (class-index-cached? class) (%index-cache class) ;; we've got a cached reference, just return it (multiple-value-bind (btree found) @@ -110,31 +122,26 @@ (synchronize-class-to-store class :sc sc :method method) btree))
-(define-condition persistent-class-not-indexed (error) - ((class-obj :initarg :class :initarg nil :reader unindexed-class-obj))) - (defun cache-new-class-index (class sc) "If not cached or persistent then this is a new class, make the new index" (if (indexed class) (enable-class-indexing class (indexing-record-slots (indexed-record class)) :sc sc) - (signal 'persistent-class-not-indexed - :class class - :format-control "Class ~A is not enabled for indexing" - :format-arguments (list (class-name class))))) + (signal-class-not-indexed class)))
(defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) (find-inverted-index (find-class class) slot :null-on-fail null-on-fail))
(defmethod find-inverted-index ((class persistent-metaclass) slot &key (null-on-fail nil)) - (let* ((cidx (find-class-index class)) + (let* ((cidx (find-class-index class :errorp (not null-on-fail))) (idx (or (get-index cidx slot) (get-index cidx (make-derived-name slot))))) (if idx idx (if null-on-fail nil - (error "Inverted index ~A not found for class ~A with - persistent slots: ~A" slot (class-name class) (car (%persistent-slots class))))))) + (cerror "Ignore and continue?" + "Inverted index ~A not found for class ~A with persistent slots: ~A" + slot (class-name class) (car (%persistent-slots class)))))))
(defmethod find-inverted-index-names ((class persistent-metaclass)) (let ((names nil)) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/04/27 13:32:17 1.27 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/04/28 02:31:15 1.28 @@ -312,6 +312,7 @@ primary key greater or equal to the pkey argument. Returns has-tuple / secondary key / value / primary key."))
+ (defgeneric cursor-next-dup (cursor) (:documentation "Move to the next duplicate element (with the same key.) @@ -322,11 +323,6 @@ "Move to the next non-duplicate element (with different key.) Returns has-pair key value."))
-(defgeneric cursor-prev-nodup (cursor) - (:documentation - "Move to the previous non-duplicate element (with -different key.) Returns has-pair key value.")) - (defgeneric cursor-pnext-dup (cursor) (:documentation "Move to the next duplicate element (with the same key.) @@ -338,12 +334,53 @@ key.) Returns has-tuple / secondary key / value / primary key."))
+ +(defgeneric cursor-prev-dup (cursor) + (:documentation + "Move to the previous duplicate element (with the same key.) +Returns has-pair key value.")) + +(defmethod cursor-prev-dup ((cur cursor)) + "Default implementation. Plan is to update both backends when BDB 4.6 comes out" + (when (cursor-initialized-p cur) + (multiple-value-bind (exists? skey-cur) + (cursor-current cur) + (declare (ignore exists?)) + (multiple-value-bind (exists? skey value) + (cursor-prev cur) + (if (lisp-compare-equal skey-cur skey) + (values exists? skey value) + (setf (cursor-initialized-p cur) nil)))))) + +(defgeneric cursor-prev-nodup (cursor) + (:documentation + "Move to the previous non-duplicate element (with +different key.) Returns has-pair key value.")) + +(defgeneric cursor-pprev-dup (cursor) + (:documentation + "Move to the previous duplicate element (with the same key.) +Returns has-tuple / secondary key / value / primary key.")) + +(defmethod cursor-pprev-dup ((cur cursor)) + "Default implementation. Plan is to update both backends when BDB 4.6 comes out" + (when (cursor-initialized-p cur) + (multiple-value-bind (exists? skey-cur) + (cursor-current cur) + (declare (ignore exists?)) + (multiple-value-bind (exists? skey value pkey) + (cursor-pprev cur) + (if (lisp-compare-equal skey-cur skey) + (values exists? skey value pkey) + (setf (cursor-initialized-p cur) nil)))))) + (defgeneric cursor-pprev-nodup (cursor) (:documentation "Move to the previous non-duplicate element (with different key.) Returns has-tuple / secondary key / value / primary key."))
+ (defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." @@ -439,6 +476,7 @@ start end)) (let ((sc (get-con index)) (end (or value end)) + (from-end (and from-end (not value-set-p))) (results nil)) (flet ((collector (k v pk) (push (funcall fn k v pk) results))) @@ -454,11 +492,12 @@ (lisp-compare-equal key start)) (lisp-compare<= key end)))) (value-increment () - ;; Step to the next key value + ;; Step to the next key value; + ;; from-end duplicate cursor is already there (if from-end - (pprev-hack cur) + (cursor-current cur) (cursor-pnext-nodup cur))) - (next-value () + (map-values () ;; Handle the next key value (multiple-value-bind (exists? skey val pkey) (value-increment) @@ -468,18 +507,23 @@ (map-duplicates skey)) (return-from map-index (nreverse results))))) + (next-duplicate (key) + (if from-end + (pprev-dup-hack cur key) + (cursor-pnext-dup cur))) (map-duplicates (key) ;; Map all duplicates for key value (multiple-value-bind (exists? skey val pkey) - (cursor-pnext-dup cur) + (next-duplicate key) (if exists? (progn (funcall fn skey val pkey) (map-duplicates key)) (progn - (cursor-pset-range cur key) - (next-value)))))) - (declare (dynamic-extent (function next-value) (function next-value-increment) + (unless from-end + (cursor-pset cur key)) + (map-values)))))) + (declare (dynamic-extent (function map-values) (function next-duplicate) (function continue-p) (function map-duplicates))) (multiple-value-bind (exists? skey val pkey) (cond (value-set-p @@ -487,9 +531,9 @@ ((and (not from-end) (null start)) (cursor-pfirst cur)) ((and from-end (null end)) - (cursor-last-range-hack cur)) + (cursor-plast cur)) (t (if from-end - (cursor-pset-range cur end) + (pset-range-for-descending cur end) (cursor-pset-range cur start)))) (if (and exists? (continue-p skey)) (progn @@ -497,23 +541,24 @@ (map-duplicates skey)) nil)))))))))
-(defun pprev-hack (cur) - "Get the first duplicate instance of the prior value off the current cursor" - (let ((e? (cursor-pprev-nodup cur))) - (when e? - (let ((e? (cursor-pprev-nodup cur))) - (if e? - (cursor-pnext cur) - (cursor-pfirst cur)))))) - -(defun cursor-last-range-hack (cur) - "Get the first duplicate instance of the last value of the cursor's index" - (let ((e? (cursor-plast cur))) - (when e? - (let ((e? (cursor-pprev-nodup cur))) - (if e? - (cursor-pnext cur) - (cursor-pfirst cur)))))) +(defun pset-range-for-descending (cur end) + (if (cursor-pset cur end) + (progn + (cursor-next-nodup cur) + (cursor-pprev cur)) + (progn + (cursor-pset-range cur end) + (cursor-pprev cur)))) + +(defun pprev-dup-hack (cur key) + "Go back one step in a duplicate set, returns nil + if previous element is a different key. More efficient than + the current default implementation of cursor-pprev-dup" + (multiple-value-bind (exists? skey value pkey) + (cursor-pprev cur) + (when (lisp-compare-equal key skey) + (values exists? key value pkey)))) +
;; =============================== ;; Some generic utility functions --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/04/25 02:28:01 1.50 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/04/28 02:31:15 1.51 @@ -136,7 +136,7 @@ (defun initialize-user-parameters () (loop for (keyword variable) in *user-configurable-parameters* do (awhen (get-user-configuration-parameter keyword) - (setf variable it)))) + (setq variable it))))
;; ;; COMMON STORE CONTROLLER FUNCTIONALITY @@ -165,7 +165,7 @@ "This is an instance cache and part of the metaclass protocol. Data stores should not override the default behavior.") - (instance-cache-lock :accessor instance-cache-lock :initform (ele-make-lock) + (instance-cache-lock :accessor instance-cache-lock :initform (ele-make-fast-lock) :documentation "Protection for updates to the cache from multiple threads. Do not override.") @@ -202,14 +202,16 @@ (defun cache-instance (sc obj) "Cache a persistent object with the controller." (declare (type store-controller sc)) - (ele-with-lock ((instance-cache-lock sc)) + (ele-with-fast-lock ((instance-cache-lock sc)) (setf (get-cache (oid obj) (instance-cache sc)) obj)))
(defun get-cached-instance (sc oid class-name) "Get a cached instance, or instantiate!" (declare (type store-controller sc) (type fixnum oid)) - (let ((obj (get-cache oid (instance-cache sc)))) + (let ((obj + (ele-with-fast-lock ((instance-cache-lock sc)) + (get-cache oid (instance-cache sc))))) (if obj obj ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid :sc sc)))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/04/27 13:32:17 1.34 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/04/28 02:31:16 1.35 @@ -222,12 +222,12 @@ #:cursor #:secondary-cursor #:make-cursor #:make-simple-cursor #:cursor-close #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup - #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup + #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup #:cursor-prev-dup #:cursor-set #:cursor-set-range #:cursor-get-both #:cursor-get-both-range #:cursor-delete #:cursor-put #:cursor-pcurrent #:cursor-pfirst #:cursor-plast #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup - #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset + #:cursor-pprev #:cursor-pprev-dup #:cursor-pprev-nodup #:cursor-pset #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range #:cursor-initialized-p
@@ -267,6 +267,7 @@ ;; Various error conditions #:cross-reference-error #:controller-lost-error + #:persistent-class-not-indexed
#:map-class-query #:get-query-instances --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/04/27 13:32:17 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/04/28 02:31:16 1.13 @@ -120,7 +120,7 @@ If nested, the backend must support nested transactions." (let ((sc (gensym))) `(let ((,sc ,store-controller)) - (funcall #'execute-transaction ,store-controller + (funcall #'execute-transaction ,sc (lambda () ,@body) :parent (if (owned-txn-p ,sc ,parent) (transaction-object ,parent) @@ -146,10 +146,9 @@ (,sc ,store-controller)) (if (owned-txn-p ,sc ,parent) (funcall ,txn-fn) - (funcall #'execute-transaction ,store-controller + (funcall #'execute-transaction ,sc ,txn-fn :parent nil - :transaction nil :retries ,retries ,@(remove-keywords '(:store-controller :parent :transaction :retries) keyargs))))))