- elephant-cvs@lists.common-lisp.net - mailman3.common-lisp.net

[elephant-cvs] CVS elephant/tests
by ieslick 30 Jan '06

30 Jan '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv15325/tests Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.lisp testcollections.lisp testindexing.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/tests/elephant-tests.lisp 2006/01/29 04:57:21 1.7.2.2 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/30 04:55:00 1.7.2.3 @@ -133,13 +133,23 @@ (let ((*auto-commit* nil)) (do-tests))))) -(defun do-test-spec (testname &optional (spec *test-path-primary*)) +(defun do-test-spec (testname &optional (spec *testdb-path*)) "For easy interactive running of tests while debugging" (when spec (with-open-store (spec) (let ((*auto-commit* nil)) (do-test testname))))) +(defun do-indexing-tests () + (setf *old-store* *store-controller*) + (open-store *testdb-path*) + (print (do-test 'indexing-basic)) + (print (do-test 'indexing-inherit)) + (print (do-test 'indexing-range)) + (print (do-test 'indexing-reconnect-db)) + (close-store) + (setf *store-controller* *old-store*)) + (defun do-crazy-pg-tests() (open-store *testpg-path*) (do-test 'indexed-btree-make) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/01/25 15:36:32 1.7 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/01/30 04:55:00 1.7.2.1 @@ -204,6 +204,7 @@ (deftest remove-kv-from-slot1 (finishes (remove-kv 2 index1)) t) + (deftest no-key-nor-indices-slot1 (values (get-value (second keys) indexed) @@ -214,6 +215,7 @@ (deftest remove-kv-from-slot2 (finishes (remove-kv 300 index2)) t) + (deftest no-key-nor-indices-slot2 (values (get-value (third keys) indexed)

1 0

[elephant-cvs] CVS elephant/src
by ieslick 30 Jan '06

30 Jan '06

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

1 0

[elephant-cvs] CVS elephant
by ieslick 30 Jan '06

30 Jan '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv15325 Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.asd elephant.asd 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/elephant-tests.asd 2006/01/29 04:57:20 1.4.2.1 +++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/01/30 04:54:59 1.4.2.2 @@ -58,8 +58,8 @@ (:file "mop-tests") (:file "testcollections") (:file "testsleepycat") - (:file "testmigration") (:file "testindexing") + (:file "testmigration") ) :serial t))) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/01/26 04:03:44 1.9.2.1 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/01/30 04:54:59 1.9.2.2 @@ -63,6 +63,7 @@ (:file "controller") (:file "collections") (:file "serializer") + (:file "index-utils") (:file "indexing")) #+openmcl (:file "openmcl-mop-patches")

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv15072/tests Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.lisp Added Files: Tag: ELEPHANT-0-4-1-rc1-IAN testindexing.lisp Log Message: First pass complete indexing solution including basic tests. --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/27 00:03:49 1.7.2.1 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/29 04:57:21 1.7.2.2 @@ -116,17 +116,30 @@ (defvar *test-path-primary* *testdb-path* ) + (defvar *test-path-secondary* - *testpg-path* + *testsqlite3-path* ) - (defun do-all-tests() (progn (do-all-tests-spec *testdb-path*) - (do-all-tests-spec *testpg-path*) + (do-all-tests-spec *testsqlite3-path*) )) +(defun do-all-tests-spec(spec) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (do-tests))))) + +(defun do-test-spec (testname &optional (spec *test-path-primary*)) + "For easy interactive running of tests while debugging" + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (do-test testname))))) + (defun do-crazy-pg-tests() (open-store *testpg-path*) (do-test 'indexed-btree-make) @@ -149,13 +162,7 @@ t ) )) - -(defun do-all-tests-spec(spec) - (when spec - (with-open-store (spec) - (let ((*auto-commit* nil)) - (do-tests))))) - + (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) (eq (slot-definition-name slot-def) slot-name))

1 0

[elephant-cvs] CVS elephant/src
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv15072/src Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp collections.lisp controller.lisp elephant.lisp indexing.lisp metaclasses.lisp Log Message: First pass complete indexing solution including basic tests. --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 18:52:49 1.16.2.3 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/29 04:57:20 1.16.2.4 @@ -120,6 +120,7 @@ (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) @@ -133,6 +134,8 @@ (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) + (set-db-synch instance :class) (make-instances-obsolete instance)))) ;; #+allegro @@ -153,6 +156,8 @@ ;; (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 @@ -199,18 +204,16 @@ (apply #'call-next-method instance transient-slot-inits initargs)))))) (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; probably should delete discarded slots, but we'll worry about that later + ;; NOTE: probably should delete discarded slots, but we'll worry about that later (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) -;; (format t "persisent-slots ~A~%" (persistent-slots (class-of instance))) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) (let* ((class (class-of instance)) (new-persistent-slots (set-difference (persistent-slots class) (old-persistent-slots class)))) - + ;; Update new persistent slots, the others we get for free (same oid!) + ;; Isn't this done by the default call-next-method? (apply #'shared-initialize instance new-persistent-slots initargs)) -;; (format t "slot-boundp ~A~%" (slot-boundp instance '%persistent-slots)) ) ) @@ -231,7 +234,9 @@ when (not (persistent-slot-boundp previous slot-name)) collect slot-name)) (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) + ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) + ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class @@ -240,6 +245,9 @@ (slot-value-using-class old-class previous (find-slot-def-by-name old-class (slot-definition-name slot-def))))) + ;; Delete this instance from its old class index, if exists + (when (indexed old-class) + (remove-kv (oid previous) (find-class-index old-class))) (call-next-method))) (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) @@ -248,12 +256,21 @@ (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) +;; ORIGINAL METHOD +;; (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) +;; "Set the slot value in the database." +;; (declare (optimize (speed 3))) +;; (let ((name (slot-definition-name slot-def))) +;; (persistent-slot-writer new-value instance name))) + +;; SUPPORT FOR INVERTED INDEXES (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." (declare (optimize (speed 3))) - (let ((name (slot-definition-name slot-def))) - (persistent-slot-writer new-value instance name) - (update-index-on-write class instance slot-def))) + (if (indexed class) + (indexed-slot-writer class instance slot-def new-value) + (let ((name (slot-definition-name slot-def))) + (persistent-slot-writer new-value instance name)))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." @@ -275,6 +292,7 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." (declare (optimize (speed 3))) + ;; NOTE: call remove-indexed-slot here instead? (when (indexed slot-def) (unregister-indexed-slot class (slot-definition-name slot-def))) (if (sql-store-spec-p (:dbcn-spc-pst instance)) @@ -304,14 +322,3 @@ finally (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method)))) - -;; Index update interface (used in functions above) - -(defmethod update-index-on-write ((class persistent-metaclass) (instance persistent-object) (slot persistent-slot-definition)) - "Anything that side effects a persistent-object slot should call this to keep - the dependant indices in synch. Only classes with derived indices need to - update on writes to non-persistent slots. update-class-index is implemented - by the subsystem that maintains the index" - (when (or (slot-value slot 'indexed) - (> (indexing-record-derived-count (indexed-record class)) 0)) - (update-class-index class instance))) --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/26 04:03:44 1.13.2.1 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/29 04:57:20 1.13.2.2 @@ -297,6 +297,7 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? + ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) (serialize secondary-key secondary-buf) ;; should silently do nothing if the key/value already --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/26 04:03:44 1.14.2.1 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/29 04:57:20 1.14.2.2 @@ -130,6 +130,10 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) +(defgeneric reset-instance-cache (sc) + (:documentation + "Creates an empty object cache by replacing the existing cache.")) + (defgeneric build-btree (sc) (:documentation "Construct a btree of the appropriate type corresponding to this store-controller.")) @@ -345,6 +349,10 @@ sc))) +(defmethod reset-instance-cache ((sc store-controller)) + (setf (instance-cache sc) + (make-cache-table :test 'eql))) + (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) ;; no root --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/01/25 16:58:25 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/01/29 04:57:20 1.18.2.1 @@ -113,6 +113,24 @@ #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-flags #:db-env-get-flags #:run-elephant-thread + + ;; Class indexing management API + #:*default-indexed-class-synch-policy* + #:find-class-index #:find-inverted-index + #:enable-class-indexing #:disable-class-indexing + #:add-class-slot-index #:remove-class-slot-index + #:add-class-derived-index #:remove-class-derived-index + #:describe-db-class-index + + ;; Low level cursor API + #:make-inverted-cursor #:make-class-cursor + #:with-inverted-cursor #:with-class-cursor + + ;; Instance query API + #:get-instances-by-class + #:get-instances-by-value + #:get-instances-by-range + #:drop-instances ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 18:52:49 1.10.2.3 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/29 04:57:20 1.10.2.4 @@ -104,8 +104,7 @@ (defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) - nil) - (car (%persistent-slots class))) + nil)) (defmethod persistent-slots ((class standard-class)) nil) @@ -166,8 +165,10 @@ nil) (defmethod indexed-record ((class persistent-metaclass)) (car (%indexed-slots class))) + (defmethod old-indexed-record ((class persistent-metaclass)) (cdr (%indexed-slots class))) + (defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) (let ((oldrec (if (slot-boundp class '%indexed-slots) (indexed-record class)

1 0

[elephant-cvs] CVS elephant
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv15072 Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN elephant-tests.asd Log Message: First pass complete indexing solution including basic tests. --- /project/elephant/cvsroot/elephant/elephant-tests.asd 2005/11/23 17:51:31 1.4 +++ /project/elephant/cvsroot/elephant/elephant-tests.asd 2006/01/29 04:57:20 1.4.2.1 @@ -59,6 +59,7 @@ (:file "testcollections") (:file "testsleepycat") (:file "testmigration") + (:file "testindexing") ) :serial t)))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv30673/tests Modified Files: elephant-tests.lisp testserializer.lisp Log Message: Minor modifications to improve compilation on Mac OS X and test completion under Allegro --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/24 18:25:01 1.7 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/01/29 01:08:32 1.8 @@ -114,17 +114,17 @@ ) (defvar *test-path-primary* - *testpg-path* + *testdb-path* ) (defvar *test-path-secondary* - *testdb-path* + *testdb-path2* ) (defun do-all-tests() (progn (do-all-tests-spec *testdb-path*) - (do-all-tests-spec *testpg-path*) + (do-all-tests-spec *testsqlite3-path*) )) (defun do-crazy-pg-tests() @@ -151,9 +151,10 @@ )) (defun do-all-tests-spec(spec) - (with-open-store (spec) - (let ((*auto-commit* nil)) - (do-tests)))) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (do-tests))))) (defun find-slot-def (class-name slot-name) (find-if #'(lambda (slot-def) --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2005/11/23 17:51:59 1.7 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/01/29 01:08:32 1.8 @@ -196,12 +196,14 @@ (array-element-type (in-out-value (make-array '(3 4 5) :element-type - '(unsigned-byte 20))))) + '(unsigned-byte 20) + :initial-element 0)))) (type= (upgraded-array-element-type 'fixnum) (array-element-type (in-out-value (make-array '(3 4 5) :element-type - 'fixnum)))) + 'fixnum + :initial-element 0)))) ) t t t t)

1 0

[elephant-cvs] CVS elephant/src
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv30673/src Modified Files: bdb-enable.lisp sleepycat.lisp sql-controller.lisp Log Message: Minor modifications to improve compilation on Mac OS X and test completion under Allegro --- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/25 22:18:03 1.4 +++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/29 01:08:32 1.5 @@ -41,11 +41,12 @@ ;;; to the Free Software Foundation, Inc., 59 Temple Place, ;;; Suite 330, Boston, MA 02111-1307 USA ;;; -;; (defpackage ele-bdb -;; (:documentation -;; "ELE-BDB: This is just a marker-pacakge to show whether or not -;; the Berkeley-DB code is enabled.") -;; (:nicknames ele-bdb :ele-bdb)) + +(defpackage ele-bdb + (:documentation + "ELE-BDB: This is just a marker-pacakge to show whether or not +the Berkeley-DB code is enabled.") + (:nicknames ele-bdb :ele-bdb)) #+cmu (eval-when (:compile-toplevel) @@ -66,15 +67,15 @@ (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") (error "Couldn't load libpthread!")) - (unless - (uffi:load-foreign-library - (if (find-package 'asdf) + (unless + (uffi:load-foreign-library + (if (find-package 'asdf) (merge-pathnames - #p"libmemutil.so" + (make-pathname :name "libmemutil" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - "/usr/local/share/common-lisp/elephant-0.3/libmemutil.so") - :module "libmemutil") - (error "Couldn't load libmemutil.so!")) + (format nil "/usr/local/share/common-lisp/elephant-0.3/libmemutil.~A" *c-library-extension*)) + :module "libmemutil") + (error "Couldn't load libmemutil.~A!" *c-library-extension*)) ;; This code has now been moved to the small, asdf-loadable system @@ -87,9 +88,9 @@ ;; "/db/ben/lisp/db43/lib/libdb.so" "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" ;; this works on FreeBSD - #+(and (or bsd freebsd) (not darwin)) + #+(and (or bsd freebsd) (not darwin macosx)) "/usr/local/lib/db43/libdb.so" - #+darwin + #+(or darwin macosx) ;; for Fink (OS X) -- but I will assume Linux more common... ;; "/sw/lib/libdb-4.3.dylib" ;; a possible manual install @@ -102,10 +103,10 @@ (uffi:load-foreign-library (if (find-package 'asdf) (merge-pathnames - #p"libsleepycat.so" + (make-pathname :name "libsleepycat" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.so") + (format nil "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.~A" *c-library-extension*)) :module "libsleepycat") - (error "Couldn't load libsleepycat!")) + (error "Couldn't load libsleepycat.~A!" *c-library-extension*)) ) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2005/12/05 15:27:54 1.16 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/01/29 01:08:32 1.17 @@ -124,6 +124,10 @@ (eval-when (:compile-toplevel) (proclaim '(optimize (ext:inhibit-warnings 3)))) +(eval-when (:compile-toplevel :load-toplevel) + (defparameter *c-library-extension* + #+macosx "dylib" + #-macosx "so" )) (eval-when (:compile-toplevel :load-toplevel) @@ -131,11 +135,11 @@ (uffi:load-foreign-library (if (find-package 'asdf) (merge-pathnames - #p"libmemutil.so" + (make-pathname :name "libmemutil" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - (format nil "~A/~A" *elephant-lib-path* "libmemutil.so")) + (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*)) :module "libmemutil") - (error "Couldn't load libmemutil.so!")) + (error "Couldn't load libmemutil.~A!" *c-library-extension*)) ;; fini on user editable part @@ -509,7 +513,8 @@ "Return the number of bytes of the internal representation of a string." #+(and allegro ics) - `(let ((l (length ,s))) (+ l l)) + ;; old: `(let ((l (length ,s))) (+ l l)) + `(excl:native-string-sizeof ,s :external-format :unicode) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s (base-string (length ,s)) @@ -521,7 +526,7 @@ ;; memcpy is faster than looping! For Lispworks this causes ;; a string to array conversion, but I don't know how to do ;; any better (fli:replace-foreign-array is promising?) -#-(or cmu sbcl scl openmcl) +#-(or cmu sbcl scl openmcl allegro) (def-function ("copy_buf" copy-str-to-buf) ((dest array-or-pointer-char) (dest-offset :int) @@ -566,6 +571,18 @@ (ccl::%copy-ivector-to-ptr ivector (+ disp src-offset) dest dest-offset length))) +#+allegro +(defun copy-str-to-buf (dest dest-offset src src-offset length) + "Use build-in unicode handling and copying facilities. + NOTE: We need to validate the speed of this vs. default." + (declare (optimize (speed 3) (safety 0)) + (type string src) + (type array-or-pointer-char dest) + (type fixnum length src-offset dest-offset) + (dynamic-extent src dest length)) + (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset) + :external-format :unicode)) + ;; Lisp version, for kicks. this assumes 8-bit chars! #+(not (or cmu sbcl scl allegro openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) @@ -752,7 +769,10 @@ (resize-buffer-stream bs needed)) ;; I wonder if the basic problem here is that we are using this ;; routine instead of something like "copy-ub8-from-system-area"? + #-allegro (copy-str-to-buf buf size s 0 str-bytes) + #+allegro + (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) (setf size needed) nil))) @@ -880,7 +900,7 @@ ;; wide!!! #+(and allegro ics) (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) position) + (offset-char-pointer (buffer-stream-buffer bs) position) :length byte-length :external-format :unicode) #+lispworks --- /project/elephant/cvsroot/elephant/src/sql-controller.lisp 2006/01/24 15:42:30 1.3 +++ /project/elephant/cvsroot/elephant/src/sql-controller.lisp 2006/01/29 01:08:32 1.4 @@ -232,8 +232,6 @@ index) (error "Invalid index initargs!")))) - - (defmethod (setf get-value) (value key (bt sql-indexed-btree)) "Set a key / value pair, and update secondary indices." (let* ((sc (check-con (:dbcn-spc-pst bt)))

1 0

[elephant-cvs] CVS elephant
by ieslick 29 Jan '06

29 Jan '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv30673 Modified Files: Makefile Log Message: Minor modifications to improve compilation on Mac OS X and test completion under Allegro --- /project/elephant/cvsroot/elephant/Makefile 2005/11/23 17:51:31 1.7 +++ /project/elephant/cvsroot/elephant/Makefile 2006/01/29 01:08:31 1.8 @@ -24,16 +24,18 @@ ifeq (Darwin,$(UNAME)) SHARED=-bundle + EXT=dylib else SHARED=-shared + EXT=so endif -all: libsleepycat.so libmemutil.so +all: libsleepycat.$(EXT) libmemutil.$(EXT) -libmemutil.so: src/libmemutil.c +libmemutil.$(EXT): src/libmemutil.c gcc $(SHARED) -Wall -fPIC -O3 -o $@ $< -lm -libsleepycat.so: src/libsleepycat.c +libsleepycat.$(EXT): src/libsleepycat.c gcc $(SHARED) -Wall -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm

1 0

[elephant-cvs] CVS elephant/src
by ieslick 27 Jan '06

27 Jan '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv21689/src Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO classes.lisp indexing.lisp metaclasses.lisp Log Message: Latest stable point for everything except change-class and synching classes to pre-existing repositories. Significantly cleaned up indexed-slot handling in the metaclass to be less impactful on existing code. --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 00:03:49 1.16.2.2 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/27 18:52:49 1.16.2.3 @@ -114,10 +114,12 @@ #+allegro (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) + (update-indexed-record instance (indexed-slot-names-from-defs instance)) (loop with persistent-slots = (persistent-slots instance) for slot-def in (class-direct-slots instance) when (member (slot-definition-name slot-def) persistent-slots) @@ -126,6 +128,7 @@ #+(or cmu sbcl openmcl) (defmethod reinitialize-instance :around ((instance persistent-metaclass) &rest initargs &key &allow-other-keys) + (declare (ignore initargs)) (prog1 (call-next-method) (when (class-finalized-p instance) @@ -140,11 +143,7 @@ (setf (%persistent-slots class) (cons (persistent-slot-names class) nil))) (when (not (slot-boundp class '%indexed-slots)) - (setf (%indexed-slots class) - (cons (indexed-slot-names class) nil))) - (when (not (slot-boundp class '%derived-index-count)) - (setf (%derived-index-count class) 0)))) - + (update-indexed-record class (indexed-slot-names-from-defs class))))) ;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -201,6 +200,7 @@ (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) ;; probably should delete discarded slots, but we'll worry about that later + (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) ;; (format t "persisent-slots ~A~%" (persistent-slots (class-of instance))) @@ -253,8 +253,7 @@ (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name) - (when (%indexed-p class) - (update-class-index class instance)))) + (update-index-on-write class instance slot-def))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." @@ -275,19 +274,20 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3)) - (ignore class)) - (if (sql-store-spec-p (:dbcn-spc-pst instance)) - (progn + (declare (optimize (speed 3))) + (when (indexed slot-def) + (unregister-indexed-slot class (slot-definition-name slot-def))) + (if (sql-store-spec-p (:dbcn-spc-pst instance)) + (progn (let* ((sc (check-con (:dbcn-spc-pst instance))) (con (controller-db sc))) - (sql-remove-from-root - (form-slot-key (oid instance) (slot-definition-name slot-def)) - sc - con - ) - )) - (with-buffer-streams (key-buf) + (sql-remove-from-root + (form-slot-key (oid instance) (slot-definition-name slot-def)) + sc + con + ) + )) + (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize (slot-definition-name slot-def) key-buf) (db-delete-buffered @@ -304,3 +304,14 @@ finally (if (typep slot 'persistent-slot-definition) (slot-makunbound-using-class class instance slot) (call-next-method)))) + +;; Index update interface (used in functions above) + +(defmethod update-index-on-write ((class persistent-metaclass) (instance persistent-object) (slot persistent-slot-definition)) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-persistent slots. update-class-index is implemented + by the subsystem that maintains the index" + (when (or (slot-value slot 'indexed) + (> (indexing-record-derived-count (indexed-record class)) 0)) + (update-class-index class instance))) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 00:03:49 1.10.2.2 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/27 18:52:49 1.10.2.3 @@ -46,6 +46,7 @@ (make-hash-table :test 'equal)) (defun connection-is-indeed-open (con) + (declare (ignore con)) t ;; I don't yet know how to implement this ) @@ -89,13 +90,16 @@ (defclass persistent-metaclass (standard-class) ((%persistent-slots :accessor %persistent-slots) (%indexed-slots :accessor %indexed-slots) - (%derived-index-count :accessor %derived-index-count) - (%instance-index :accessor %instance-index)) + (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise. Slots can also -be indexed for by-value retrieval")) +be indexed for by-value retrieval.")) + +;; +;; Persistent slot maintenance +;; (defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) @@ -117,30 +121,9 @@ nil) ))) -(defmethod %indexed-p ((class persistent-metaclass)) - (or (and (slot-boundp class '%indexed-slots) - (car (%indexed-slots class))) - (and (slot-boundp class '%derived-index-count) - (> (%derived-index-count class) 0)))) - -(defmethod indexed-slots ((class persistent-metaclass)) - (car (%indexed-slots class))) - -(defmethod indexed-slots ((class standard-class)) - nil) - -(defmethod old-indexed-slots ((class persistent-metaclass)) - (cdr (%indexed-slots class))) - -(defmethod update-indexed-slots ((class persistent-metaclass) new-slot-list) - (setf (%indexed-slots class) (cons new-slot-list - (if (slot-boundp class '%indexed-slots) - (car (%indexed-slots class)) - nil)))) - (defclass persistent-slot-definition (standard-slot-definition) - ()) + ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance))) (defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -157,16 +140,6 @@ (defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ()) - -(defclass indexed-slot-definition (persistent-slot-definition) - ((indexed :initform t :initarg :indexed :allocation :class))) - -(defclass indexed-direct-slot-definition (persistent-direct-slot-definition indexed-slot-definition) - ()) - -(defclass indexed-effective-slot-definition (persistent-effective-slot-definition indexed-slot-definition) - ()) - (defgeneric transient (slot)) (defmethod transient ((slot standard-direct-slot-definition)) @@ -175,13 +148,101 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil) -(defgeneric indexed (slot)) +;; +;; Indexed slots maintenance +;; + +;; 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))) + +(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))) -(defmethod indexed ((slot standard-direct-slot-definition)) +(defmethod indexed-record ((class standard-class)) nil) +(defmethod indexed-record ((class persistent-metaclass)) + (car (%indexed-slots class))) +(defmethod old-indexed-record ((class persistent-metaclass)) + (cdr (%indexed-slots class))) +(defmethod update-indexed-record ((class persistent-metaclass) new-slot-list) + (let ((oldrec (if (slot-boundp class '%indexed-slots) + (indexed-record class) + nil))) + (setf (%indexed-slots class) + (cons (make-instance 'indexing-record + :slots new-slot-list + :derived-count (if oldrec (indexing-record-derived-count oldrec) 0)) + (if oldrec oldrec nil))))) -(defmethod indexed ((slot indexed-direct-slot-definition)) - t) +(defun indexed-slot-names-from-defs (class) + (let ((slot-definitions (class-slots class))) + (loop for slot-definition in slot-definitions + when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) + (indexed slot-definition)) + collect (slot-definition-name slot-definition)))) + +(defmethod register-indexed-slot ((class persistent-metaclass) slot) + "This method allows for post-definition update of indexed status of + class slots. It changes the effective method so we can rely on + generic function dispatch for differentated behavior" + ;; 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)) + (unless (member slot (indexing-record-slots record)) +;; This is a normal startup case, but during other cases we'd like +;; the duplicate wraning +;; (warn "Tried to index slot ~A which is already indexed" slot)) + (push slot (indexing-record-slots record)))) + ;; change effective slot def + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) t))) + +(defmethod unregister-indexed-slot (class slot) + "Revert an indexed slot to it's original state" + ;; update record + (let ((record (indexed-record class))) + (unless (member slot (indexing-record-slots record)) + (error "Tried to unregister slot ~A which is not indexed" slot)) + (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) + ;; change effective slot def status + (let ((slot-def (find-slot-def-by-name class slot))) + (unless slot-def + (error "Slot definition for slot ~A not found, inconsistent state in + class ~A" slot (class-name class))) + (setf (slot-value slot-def 'indexed) nil))) + +(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)))) + +(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)))) + +(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))))) + +(defmethod indexed ((slot standard-slot-definition)) nil) +(defmethod indexed ((class standard-class)) nil) + +;; +;; Original support for persistent slot protocol +;; #+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) @@ -204,8 +265,6 @@ (error "Persistent class slots are not supported, try :transient t.")) ((and indexed-p transient-p) (error "Cannot declare slots to be both transient and indexed")) - (indexed-p - (find-class 'indexed-direct-slot-definition)) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -239,8 +298,6 @@ (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) (error "Cannot declare a slot to be both indexed and transient")) - (indexed-p - (find-class 'indexed-effective-slot-definition)) (transient-p (find-class 'transient-effective-slot-definition)) (t @@ -293,7 +350,9 @@ (if (ensure-transient-chain slot-definitions initargs) (setf initargs (append initargs '(:transient t))) (setf (getf initargs :allocation) :database)) - (if (some #'indexed slot-definitions) + ;; Effective slots are indexed only if the most recent slot definition + ;; is indexed. NOTE: Need to think more about inherited indexed slots + (if (indexed (first slot-definitions)) (append initargs '(:indexed t)) initargs))) @@ -387,8 +446,3 @@ (loop for slot-definition in slot-definitions unless (persistent-p slot-definition) collect (slot-definition-name slot-definition)))) - -(defun indexed-slot-names (class) - (loop for slot-definition in (class-slots class) - when (subtypep (type-of slot-definition) 'indexed-effective-slot-definition) - collect (slot-definition-name slot-definition)))

1 0