February 2006 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src
by ieslick 14 Feb '06

14 Feb '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv1832/src Modified Files: indexing.lisp Log Message: Updated TODO list. Minor tweak in indexing. --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:25:10 1.4 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:31:09 1.5 @@ -399,12 +399,13 @@ nil))))) (defun drop-instances (instances &key (sc *store-controller*)) - (assert (consp instances)) - (with-transaction (:store-controller sc) - (let ((class-idx (find-class-index (class-of (first instances))))) - (mapc (lambda (instance) - (remove-kv (oid instance) class-idx)) - instances)))) + (when instances + (assert (consp instances)) + (with-transaction (:store-controller sc) + (let ((class-idx (find-class-index (class-of (first instances))))) + (mapc (lambda (instance) + (remove-kv (oid instance) class-idx)) + instances))))) ;; ============================= ;; CLASS / DB SYNCHRONIZATION

1 0

[elephant-cvs] CVS elephant
by rread 14 Feb '06

14 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv487 Modified Files: CREDITS Log Message: Adding some acknowledgements. --- /project/elephant/cvsroot/elephant/CREDITS 2005/11/23 17:51:31 1.6 +++ /project/elephant/cvsroot/elephant/CREDITS 2006/02/14 15:28:32 1.7 @@ -46,3 +46,10 @@ Dan Knapp fixed the fact that nil's were indistinguishable from unbound slots, and proved the system works with SQLite3. + +Tayssir John Gabbour has found two bugs on Feb. 14, 2006. + +Ian Eslick wrote src/indexing.lisp, which added major +convenience features for automatically indexing the a slot +in a class. +

1 0

[elephant-cvs] CVS elephant/src
by rread 14 Feb '06

14 Feb '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv373 Modified Files: bdb-enable.lisp indexing.lisp serializer.lisp Log Message: Thanks to Tayssir John Gabour for these bug fixes. --- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/02/04 22:25:09 1.6 +++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/02/14 15:25:10 1.7 @@ -65,7 +65,7 @@ ;; "/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 macosx)) + #+(and (or bsd freebsd) (not darwin) (not macosx)) "/usr/local/lib/db43/libdb.so" #+(or darwin macosx) ;; for Fink (OS X) -- but I will assume Linux more common... --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/14 15:25:10 1.4 @@ -450,8 +450,8 @@ ;; ;; DEFINE THE SYNCHRONIZATION RULES +(eval-when (:compile-toplevel :load-toplevel) -(eval-when (:compile-toplevel) (defclass synch-rule () ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) (rhs :accessor synch-rule-rhs :initarg :rhs :initform nil))) --- /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/04 22:25:09 1.13 +++ /project/elephant/cvsroot/elephant/src/serializer.lisp 2006/02/14 15:25:10 1.14 @@ -466,7 +466,7 @@ (eval-when (:compile-toplevel :load-toplevel) (asdf:operate 'asdf:load-op :cl-base64) ) -(defun ser-deser-equal (x1 &keys sc) +(defun ser-deser-equal (x1 &key sc) (let* ( (x1s (serialize-to-base64-string x1)) (x1prime (deserialize-from-base64-string x1s :sc sc))) @@ -482,7 +482,7 @@ ) -(defun deserialize-from-base64-string (x &keys sc) +(defun deserialize-from-base64-string (x &key sc) (with-buffer-streams (other) (deserialize (sleepycat::buffer-write-byte-vector

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 10 Feb '06

10 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv5850/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/10 01:39:13 1.11 @@ -122,16 +122,19 @@ (setq *old-store* *store-controller*) (unwind-protect (progn - (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)) - (print (do-test 'indexing-change-class)) - (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-explicit-changes)) - (print (do-test 'indexing-timing)) - (close-store)) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) + (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)) + (print (do-test 'indexing-change-class)) + (print (do-test 'indexing-redef-class)) + (print (do-test 'indexing-explicit-changes)) + (print (do-test 'indexing-timing)) + (close-store))) (setq *store-controller* *old-store*))) (defun do-crazy-pg-tests() @@ -161,6 +164,8 @@ (when spec (with-open-store (spec) (let ((*auto-commit* nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) (do-tests))))) (defun find-slot-def (class-name slot-name) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/08 03:23:12 1.3 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/10 01:39:13 1.4 @@ -30,11 +30,11 @@ (setf (find-class 'idx-one) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) (progn - (with-transaction () + (with-transaction (:store-controller *store-controller*) (setq inst1 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) (setq inst2 (make-instance 'idx-one :slot1 1 :sc *store-controller*)) (setq inst3 (make-instance 'idx-one :slot1 3 :sc *store-controller*))) @@ -57,51 +57,64 @@ (setf (find-class 'idx-two) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) - (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) (slot3 :initarg :slot3 :initform 3 :accessor slot3) (slot4 :initarg :slot4 :initform 4 :accessor slot4 :transient t)) (:metaclass persistent-metaclass)) (defclass idx-two (idx-one) ((slot2 :initarg :slot2 :initform 20 :accessor slot2) - (slot3 :initarg :slot3 :initform 30 :accessor slot3 :indexed t) - (slot4 :initarg :slot4 :initform 40 :accessor slot4 :indexed t)) + (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) + (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) (:metaclass persistent-metaclass)) (progn (with-transaction () - (setq inst1 (make-instance 'idx-two :sc *store-controller*))) + (setq inst1 (make-instance 'idx-one :sc *store-controller*)) + (setq inst2 (make-instance 'idx-two :sc *store-controller*))) (values (slot1 inst1) (slot2 inst1) (slot3 inst1) (slot4 inst1) + (slot1 inst2) + (slot2 inst2) + (slot3 inst2) + (slot4 inst2) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-one))) + '(slot1 slot2)) (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) '(slot1 slot3 slot4))))) - 1 20 30 40 t) + 1 2 3 4 1 20 30 40 t t) (deftest indexing-range (progn ;; (format t "range store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) - (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) + (disable-class-indexing 'idx-two :errorp nil) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-two) nil) (setf (find-class 'idx-one) nil) (defclass idx-one () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) (:metaclass persistent-metaclass)) (defun make-idx-one (val) - (make-instance 'idx-one :slot1 val :sc *store-controller*)) + (make-instance 'idx-one :slot1 val)) (with-transaction () (mapc #'make-idx-one '(1 1 1 2 2 4 5 5 5 6 10))) ;; Range should get multiple & single keys inclusive of ;; start and end - (let ((list (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)))) - (equal list '(2 2 4 5 5 5 6)))) - t) + (values (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 2 6)) + '(2 2 4 5 5 5 6)) ;; interior range + (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 0 2)) + '(1 1 1 2 2)) + (equal (mapcar #'slot1 (get-instances-by-range 'idx-one 'slot1 6 15)) + '(6 10)))) + t t t) (deftest indexing-reconnect-db (progn @@ -110,9 +123,9 @@ ;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) (defclass idx-two () - ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) (slot2 :initarg :slot2 :initform 2 :accessor slot2) - (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) (:metaclass persistent-metaclass)) (let ((*old-default* *default-indexed-class-synch-policy*) @@ -127,8 +140,8 @@ ;; Assume our db is out of synch with our class def (defclass idx-two () ((slot1 :initarg :slot1 :initform 1 :accessor slot1) - (slot2 :initarg :slot2 :initform 2 :accessor slot2 :indexed t) - (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :index t)) (:metaclass persistent-metaclass)) ;; Add an instance of the new class @@ -142,8 +155,52 @@ 2 2 t) (deftest indexing-change-class - nil - nil) + (progn + (disable-class-indexing 'idx-one :errorp nil) + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-one) nil) + (setf (find-class 'idx-two) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2 :index t)) + (:metaclass persistent-metaclass)) + + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 10 :accessor slot1 :index nil) + (slot3 :initarg :slot3 :initform 30 :accessor slot3 :index t) + (slot4 :initarg :slot4 :initform 40 :accessor slot4 :index t)) + (:metaclass persistent-metaclass)) + + (defmethod update-instance-for-different-class :before ((old idx-one) + (new idx-two) + &key) + (setf (slot3 new) (slot2 old))) + + (let ((*auto-commit* t) + (foo nil)) + (declare (special *auto-commit*) + (dynamic-extent *auto-commit*)) + (setf foo (make-instance 'idx-one)) + (change-class foo 'idx-two) + + (values + ;; shared data from original slot + (slot1 foo) + ;; verify old instance access fails + (signals-error (slot2 foo)) + ;; verify new instance is there + (slot3 foo) + (slot4 foo) + ;; verify proper indexing changes (none should lookup a value) + (get-instances-by-class 'idx-one) + (get-instances-by-value 'idx-one 'slot1 1) + (get-instances-by-value 'idx-one 'slot2 2) + ;; new indexes + (length (get-instances-by-class 'idx-two)) + (length (get-instances-by-value 'idx-two 'slot3 2)) + ))) + 1 t 2 40 nil nil nil 1 1) (deftest indexing-redef-class nil @@ -156,14 +213,14 @@ ;; create 10k objects, write each object's slots (defclass stress-normal () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil) - (stress2 :accessor stress2 :initarg :stress2 :initform nil :indexed nil)) + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) + (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil)) (:metaclass persistent-metaclass)) (defclass stress-index () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed t) - (stress2 :accessor stress2 :initarg :stress2 :initform 2 :indexed t) - (stress3 :accessor stress3 :initarg :stress3 :initform 3 :indexed nil)) + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t) + (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t) + (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) (:metaclass persistent-metaclass)) (defvar normal-index nil) @@ -207,32 +264,43 @@ (deftest indexing-timing (progn - - (let ((insts (get-instances-by-class 'stress-index))) + (let ((insts (get-instances-by-class 'stress-index)) + (start nil) + (end nil) + (normal-time 0) + (index-time 0)) (when insts (drop-instances insts))) - (format t "~%Stress test normal setup time (~A):~%" *stress-count*) +;; (format t "~%Stress test normal setup time (~A):~%" *stress-count*) (with-transaction () - (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10))) + (normal-stress-setup *stress-count* 'stress-normal :stress2 10) + ) - (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) +;; (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) (with-transaction () - (time (indexed-stress-setup *stress-count* 'stress-index :stress2 10))) + (indexed-stress-setup *stress-count* 'stress-index :stress2 10) + ) - (format t "~%Stress test normal lookup time (~A):~%" *range-size*) - (time - (dotimes (i *range-size*) - (declare (ignore i)) - (normal-range-lookup *stress-count* *range-size*))) +;; (format t "~%Stress test normal lookup time (~A):~%" *range-size*) + (setf start (get-internal-run-time)) + (dotimes (i *range-size*) + (declare (ignore i)) + (normal-range-lookup *stress-count* *range-size*)) + (setf end (get-internal-run-time)) + (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) - (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) - (prof:with-profiling (:type :time) - (time +;; (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*)))) - t) + (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + (setf end (get-internal-run-time)) + (setf index-time (/ (- end start 0.0) internal-time-units-per-second)) + + (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%" + *range-size* *stress-count* normal-time index-time) + (> normal-time index-time)) t)

1 0

[elephant-cvs] CVS elephant/src
by ieslick 10 Feb '06

10 Feb '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv5850/src Modified Files: classes.lisp controller.lisp elephant.lisp index-tutorial.lisp metaclasses.lisp Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/07 23:23:50 1.19 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/10 01:39:13 1.20 @@ -98,9 +98,13 @@ #+allegro (defun make-persistent-writer (name slot-definition class class-name) - (eval `(defmethod (setf ,name) ((instance ,class-name) value) - (setf (slot-value-using-class ,class instance ,slot-definition) - value)))) + (let ((name (if (and (consp name) + (eq (car name) 'setf)) + name + `(setf ,name)))) + (eval `(defmethod ,name ((instance ,class-name) value) + (setf (slot-value-using-class ,class instance ,slot-definition) + value))))) #+allegro (defmethod initialize-accessors ((slot-definition persistent-slot-definition) class) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/07 23:23:50 1.17 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/10 01:39:13 1.18 @@ -268,7 +268,7 @@ :auto-commit t :txn-nosync t)) ;; Open/close -(defmethod open-controller ((sc bdb-store-controller) &key (recover nil) +(defmethod open-controller ((sc bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t)) (let ((env (db-env-create))) ;; thread stuff? --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/07 23:23:50 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/10 01:39:13 1.21 @@ -55,6 +55,7 @@ #:persistent #:persistent-object #:persistent-metaclass + #:defpclass #:persistent-collection #:btree #:bdb-btree #:sql-btree --- /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/07 23:23:50 1.2 +++ /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/10 01:39:13 1.3 @@ -5,10 +5,10 @@ (in-package :elephant-tutorial) (defclass simple-plog () - ((timestamp :accessor plog-timestamp :initarg :timestamp :indexed t) - (type :accessor plog-type :initarg :type :indexed t) + ((timestamp :accessor plog-timestamp :initarg :timestamp :index t) + (type :accessor plog-type :initarg :type :index t) (data :accessor plog-data :initarg :data) - (user :accessor plog-user :initarg :user :indexed t)) + (user :accessor plog-user :initarg :user :index t)) (:metaclass persistent-metaclass) (:documentation "Simple persistent log")) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/07 23:23:51 1.13 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/10 01:39:13 1.14 @@ -76,6 +76,20 @@ be indexed for by-value retrieval.")) ;; +;; Top level defclass form - hide metaclass option +;; + +(defmacro defpclass (cname parents slot-defs &optional class-opts) + `(defclass ,cname ,parents + ,slot-defs + ,(add-persistent-metaclass class-opts))) + +(defun add-persistent-metaclass (class-opts) + (when (assoc :metaclass class-opts) + (error "User metaclass specification not allowed in defpclass")) + (append (list :metaclass 'persistent-metaclass) class-opts)) + +;; ;; Persistent slot maintenance ;; @@ -98,9 +112,8 @@ nil) ))) - (defclass persistent-slot-definition (standard-slot-definition) - ((indexed :accessor indexed :initarg :indexed :initform nil :allocation :instance))) + ((indexed :accessor indexed :initarg :index :initform nil :allocation :instance))) (defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) @@ -246,7 +259,7 @@ and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient)) - (indexed-p (getf initargs :indexed))) + (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) @@ -283,7 +296,7 @@ "Chooses the persistent or transient effective slot definition class depending on the keyword." (let ((transient-p (getf initargs :transient)) - (indexed-p (getf initargs :indexed))) + (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) @@ -343,7 +356,7 @@ ;; 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)) + (append initargs '(:index t)) initargs))) (defmacro persistent-slot-reader (instance name)

1 0

[elephant-cvs] CVS elephant
by ieslick 10 Feb '06

10 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv5850 Modified Files: TODO Log Message: Added :index vs. :indexed slot option Improved tests and added some more Some minor cleanup --- /project/elephant/cvsroot/elephant/TODO 2006/02/08 03:23:12 1.10 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/10 01:39:12 1.11 @@ -7,20 +7,22 @@ 0.6.0 - Adding default class/slot indexing - Finish indexing tests (Ian) - Documentation update (Robert) -- Tutorial example rethink: update the blog tutorial using indexed - objects to create different views as well as integrating something - like logging for admin or version control purposes. (Both?) +- Add a class-indexing class option to the metaclass so we can maintain class instances + index without any secondary indices or indexed slots (Ian) +- Add :inverse-reader to slot options to create a named method that indexes into objects + based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? 0.6.1 - performance, safety and portability Stability: - Add clsql like support for building .so/.dylib from asdf loader on most systems - Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) -- Cleanup multi-repository operation (a simple registry of open stores, - clear object-repository associations) (Both) +- Cleanup multi-repository operation (ensure that conflicts between an object's + registry and *store-controller* does not leed to lockup, especially with BDB (Both) - Think through default vs. explicit store referencing all over the APIs (Both) -- Cleaner failure modes if operations are performed without repository (Both) -- Add asserts if *auto-index* is false and we're not in a transaction +- Cleaner failure modes if operations are performed without repository or without + transaction or auto-commit (Both) + Add asserts if *auto-index* is false and we're not in a transaction to help users avoid lockups in bdb? Should be able to turn off for performance but it will help catch missing with-transaction statemetns in user code. (Both) @@ -34,36 +36,57 @@ - Metering and understanding locking issues. Large transactions seem to use a lot of locks. In general understanding how to use Sleepycat efficiently seems like a good thing. (Both) -- Add dependency information into secondary index callback functions so that - we can more easily compute which indices need to be updated to avoid the - global remove/add in order to maintain consistency (Ian) - Reclaim table storage on index drop (Ian) - Higher performance fix for allegro unicode serialization workaround than my current one (Ian) Indexing features: -- Add a class-indexing class option to the metaclass so we can maintain class instances - index without any secondary indices or indexed slots (Ian) -- on class change, new slots should have their initform values pushed +- On class change, new slots should have their initform values pushed into the slot value as if the slot was being created the first time (currently this doesn't happen) (Ian) Bugs: - anything else reported against 0.5.0/0.6.0 -0.6.2 - New operating modes +0.6.3 - Query & indexing expansion - simple object query language (Ian - orthogonal, on main branch) - - integrate support for your in-memory database (on a separate branch) - - repository browser (Ian - orthogonal, on main branch) + - Add dependency information into secondary index callback functions so that + we can more easily compute which indices need to be updated to avoid the + global remove/add in order to maintain consistency (Ian) + - Add needed support (if any) for persistent graph structures & queries (Ian on a branch) + +0.6.4 - Compliance & Documentation + - Update to support BDB 4.4 + - Tutorial example rethink: update the blog tutorial using indexed + objects to create different views as well as integrating something + like logging for admin or version control purposes. + - Finish serious update and review of users manual (building on 0.6.0 update) + - A guide to dealing with transactions + - A guide to dealing with multiple open stores + - A guide to performance + - An overview of licensing issues... + - Repository browser (Ian - orthogonal, on main branch) (a simple REPL tool to see what classes are in a repository and what state they're in...useful for long-lived repositories) -0.6.3 - Query expansion - - Add needed support (if any) for persistent graph structures & -queries (Ian on a branch) +0.6.4 - Additional datastructures? + - Support for cheap persistent sets (ala ACache) +Some placeholders & dreams features below... :) +0.7+: Major features + - A backend controller for AllegroCache (Ian) + - Prevalence-like in-memory database system (Robert?) + - Richer controller modes: + - Single-user mode (cache values in instance slots for fast reads, write-through) + - Prevalence mode (read/write to normal slots except on object creation or synch) + (in-memory slot indexing, on disk class) + (works for any backend) + - Concurrent mode (for backends that allow multiple processes to connect, current default) + - Controller 'switches' + - NoSynch - allow transactions to be lost on failure but maintains consistency instead of performance +0.8 - Lisp Backend?

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 08 Feb '06

08 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv713/tests Modified Files: testindexing.lisp Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/07 23:23:51 1.2 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/08 03:23:12 1.3 @@ -153,8 +153,7 @@ nil nil) -;; create 10k objects, write each object's -;; slots +;; create 10k objects, write each object's slots (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :indexed nil) @@ -185,13 +184,18 @@ (start (/ count 2)) (end (1- (+ start size)))) (with-btree-cursor (cur normal-index) - (multiple-value-bind (value? key val) (cursor-next cur) - (declare (ignore key)) - (when (and value? - (>= (stress1 val) start) - (<= (stress1 val) end)) - (push val objects)))) - objects)) + (loop + (multiple-value-bind (value? key val) (cursor-next cur) + (declare (ignore key)) + (cond ((or (not value?) + (and value? + (>= (stress1 val) end))) + (return-from normal-range-lookup objects)) + ((and value? + (>= (stress1 val) start) + (<= (stress1 val) end)) + (push val objects))))) + objects))) (defun indexed-range-lookup (class count size) (let* ((start (/ count 2)) @@ -223,10 +227,11 @@ (normal-range-lookup *stress-count* *range-size*))) (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (prof:with-profiling (:type :time) (time (dotimes (i *range-size*) (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*))) + (indexed-range-lookup 'stress-index *stress-count* *range-size*)))) t) t)

1 0

[elephant-cvs] CVS elephant/src
by ieslick 08 Feb '06

08 Feb '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv713/src Modified Files: indexing.lisp Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; slot-index.lisp -- use btree collections to track objects by slot values -;;; via metaclass options or accessor :after methods +;;; indexing.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods ;;; ;;; Initial version 1/24/2006 Ian Eslick ;;; eslick at alum mit edu @@ -100,6 +100,7 @@ (defun no-indexing-needed? (class instance slot-def oid) + (declare (ignore instance)) (or (and (not (indexed slot-def)) ;; not indexed (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes (member oid *inhibit-indexing-list*))) ;; currently inhibited @@ -199,7 +200,7 @@ (when class (disable-class-indexing class :sc sc)))) -(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*)) (let ((class-idx (find-class-index class :sc sc))) (unless class-idx (return-from disable-class-indexing nil)) ;; Remove all instance key/value data from the class index (& secondary indices) @@ -354,6 +355,8 @@ (get-instances-by-value (find-class class) slot-name value)) (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) + (declare (optimize (speed 3) (safety 1) (space 1)) + (type (or string symbol) slot-name)) (let ((instances nil)) (with-btree-cursor (cur (find-inverted-index class slot-name)) (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) @@ -371,6 +374,9 @@ (get-instances-by-range (find-class class) slot-name start end)) (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) + (declare (optimize speed (safety 1) (space 1)) + (type fixnum start end) + (type string idx-name)) (with-inverted-cursor (cur class idx-name) (labels ((next-range (instances) (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) @@ -406,16 +412,21 @@ ;; TO READER: I got really tired of trying to figure out all ;; the messy conditionals and I figure default behaviors are something -;; others might want to modify, so here's what determines the -;; rule behavior. - -;; Rules match on the following state of the metaclass and -;; the current class-index in the database for a given slotname: +;; others might want to modify, so here's what determines the rule +;; behavior. +;; +;; Rules match on the following states of the metaclass and current +;; database class-index for each slotname currently in either of +;; those sources. Actions are taken, typically when a slot exists +;; in one but not the other or features like indexed/persistent +;; differ between the slots +;; ;; class state: ;; class-indexed - the slot is marked as indexed ;; class-persistent - the slot is marked as persistent (not indexed) ;; class-transient - the slot is marked transient ;; class-derived - the slot is in the derived list of the class +;; ;; database ;; db-slot - the database has a slot index ;; db-derived - the database has a derived index @@ -424,10 +435,12 @@ ;; (not indexed-slot) for example, to cover more than one feature ;; combination ;; -;; Each rule should apply uniquely to a given feature set -;; Actions taken include: -;; add-slot-index - add a new index to the db -;; remove-slot-index - remove a slot from the db +;; Each rule should apply uniquely to a given feature set. +;; +;; Actions taken when rules match can include: +;; +;; add-slot-index - add a new index with the slotname to the db +;; remove-slot-index - remove a slot with the slotname from the db ;; add-derived-index - xxx this makes no sense! xxx ;; remove-derived-index - remove a derived index from the db ;; unregister-indexed-slot - remove an indexed slot from the class metaobject @@ -436,6 +449,8 @@ ;; register-derived-index - register a derived index with the class metaobject ;; +;; DEFINE THE SYNCHRONIZATION RULES + (eval-when (:compile-toplevel) (defclass synch-rule () ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) @@ -461,10 +476,8 @@ (db-derived class-persistent => remove-derived-index warn)) ;; NOTE: What about cases where we need to remove things as below? (:db ;; db changes class - ((not db-slot) class-indexed => - unregister-indexed-slot) - ((not db-derived) class-derived => - unregister-derived-index) + ((not db-slot) class-indexed => unregister-indexed-slot) + ((not db-derived) class-derived => unregister-derived-index) (db-slot class-persistent => register-indexed-slot) (db-slot class-transient => remove-indexed-slot) (db-derived class-transient => remove-derived-index warn) @@ -474,22 +487,34 @@ (not class-persistent) (not class-transient) => register-derived-slot))))) ) - + +;; TOP LEVEL METHOD + +(defun synchronize-class-to-store (class &key (sc *store-controller*) + (method *default-indexed-class-synch-policy*)) + (let ((slot-records (compute-class-and-ele-status class sc)) + (rule-set (cdr (assoc method *synchronize-rules*)))) + (apply-synch-rules class slot-records rule-set))) + +;; COMPUTING RULE APPLICABILITY AND FIRING (defun synch-rule-applicable? (rule features) (simple-match-set (synch-rule-lhs rule) features)) (defun simple-match-set (a b) + (declare (optimize (speed 3) (safety 1))) (cond ((null a) t) ((and (not (null a)) (null b)) nil) ((member (first a) b :test #'equal) (simple-match-set (cdr a) (remove (first a) b :test #'equal))) (t nil))) +(defparameter *print-synch-messages* nil) + (defun apply-synch-rule (rule class name) - (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" - (synch-rule-lhs rule) (synch-rule-rhs rule) name) -;; (return-from apply-synch-rule nil) + (when *print-synch-messages* + (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" + (synch-rule-lhs rule) (synch-rule-rhs rule) name)) (loop for action in (synch-rule-rhs rule) do (case action (add-slot-index (add-class-slot-index class name :update-class nil)) @@ -502,9 +527,20 @@ (register-derived-index (register-derived-index class name)) (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) -(defun synchronize-class-to-store (class &key (sc *store-controller*) - (method *default-indexed-class-synch-policy*)) - (let* ((*store-controller* sc) +(defun apply-synch-rules (class records rule-set) + (declare (optimize (speed 3) (safety 1))) + (labels ((slotname (rec) (car rec)) + (feature-set (rec) (cdr rec))) + (loop for record in records do + (loop for rule in rule-set + when (synch-rule-applicable? rule (feature-set record)) + do + (apply-synch-rule rule class (slotname record)))))) + +;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES + +(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*)) + (let* ((*store-controller* store-controller) ;; db info (db-indices (find-inverted-index-names class)) (db-derived (mapcar #'get-derived-name-root @@ -525,24 +561,16 @@ (class-transient . ,other-slots) (db-slot . ,db-slot) (db-derived . ,db-derived)))) - (labels ((compute-feature (name set label) - (if (member name set) - label - `(not ,label))) - (compute-features (slotname) + (labels ((compute-features (slotname) (let ((features nil)) (loop for set in all-sets do (push (compute-feature slotname (cdr set) (car set)) features)) (cons slotname features))) - (slotname (rec) (car rec)) - (feature-set (rec) (cdr rec))) - (let ((rule-set (cdr (assoc method *synchronize-rules*))) - (slot-records (mapcar #'compute-features all-names))) - (loop for record in slot-records do - (loop - for rule in rule-set - when (synch-rule-applicable? rule (feature-set record)) - do - (apply-synch-rule rule class (slotname record)))))))) + (compute-feature (name set label) + (if (member name set) + label + `(not ,label)))) + (mapcar #'compute-features all-names)))) +

1 0

[elephant-cvs] CVS elephant
by ieslick 08 Feb '06

08 Feb '06

Update of /project/elephant/cvsroot/elephant In directory common-lisp:/tmp/cvs-serv713 Modified Files: TODO Log Message: Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X. --- /project/elephant/cvsroot/elephant/TODO 2006/02/04 22:25:09 1.9 +++ /project/elephant/cvsroot/elephant/TODO 2006/02/08 03:23:12 1.10 @@ -1,3 +1,73 @@ +Feb 6, 2006 + +Release plan in-discussion with Robert and Ian + +Upcoming release ideas. + +0.6.0 - Adding default class/slot indexing +- Finish indexing tests (Ian) +- Documentation update (Robert) +- Tutorial example rethink: update the blog tutorial using indexed + objects to create different views as well as integrating something + like logging for admin or version control purposes. (Both?) + +0.6.1 - performance, safety and portability + +Stability: +- Add clsql like support for building .so/.dylib from asdf loader on most systems +- Port elephant to closer-to-MOP to make it easier to support additional lisps (Both) +- Cleanup multi-repository operation (a simple registry of open stores, + clear object-repository associations) (Both) +- Think through default vs. explicit store referencing all over the APIs (Both) +- Cleaner failure modes if operations are performed without repository (Both) +- Add asserts if *auto-index* is false and we're not in a transaction + to help users avoid lockups in bdb? Should be able to turn off for + performance but it will help catch missing with-transaction statemetns + in user code. (Both) +- BDB: determine how to detect deadlock conditions as an optional run-safe mode? (?) + Does BDB have timeouts enabled on select? (Ian) +- (From Ben's e-mail) We are storing persistent objects incorrectly. They should be + stored only as OIDs, and we should have a separate OID->class table. This way + change-class can be handled correctly (Ian) + +Performance: +- Metering and understanding locking issues. Large transactions seem + to use a lot of locks. In general understanding how to use Sleepycat + efficiently seems like a good thing. (Both) +- Add dependency information into secondary index callback functions so that + we can more easily compute which indices need to be updated to avoid the + global remove/add in order to maintain consistency (Ian) +- Reclaim table storage on index drop (Ian) +- Higher performance fix for allegro unicode serialization workaround than + my current one (Ian) + +Indexing features: +- Add a class-indexing class option to the metaclass so we can maintain class instances + index without any secondary indices or indexed slots (Ian) +- on class change, new slots should have their initform values pushed + into the slot value as if the slot was being created the first time + (currently this doesn't happen) (Ian) + +Bugs: +- anything else reported against 0.5.0/0.6.0 + +0.6.2 - New operating modes + - simple object query language (Ian - orthogonal, on main branch) + - integrate support for your in-memory database (on a separate branch) + - repository browser (Ian - orthogonal, on main branch) + (a simple REPL tool to see what classes are in a repository and + what state they're in...useful for long-lived repositories) + +0.6.3 - Query expansion + - Add needed support (if any) for persistent graph structures & +queries (Ian on a branch) + + + + + + + Feb. 4, 2006 As of 0.5.0, we have seem to have a stable suite on

1 0

[elephant-cvs] CVS elephant/src
by rread 07 Feb '06

07 Feb '06

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv9614/src Modified Files: classes.lisp collections.lisp controller.lisp elephant.lisp metaclasses.lisp sleepycat.lisp sql-collections.lisp Added Files: IAN-TODO index-tutorial.lisp index-utils.lisp indexing.lisp Log Message: Merger from Ian's branch into the main trunk. --- /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/IAN-TODO 2006/02/07 23:23:50 1.2 @@ -0,0 +1,102 @@ +TODO: +- Finish adding tests! +- Documentation (Robert) +- Tutorial example (Ian) + +CLEANUP: +- Verify locking behavior in transactions (should timeout with error!) +- validate native string serialization for allegro in sleepycat.lisp (6.2 trial?) + +FUTURE: +- Add compiled query language (0.5.2) +- Changing slots should push default value into new persistent slots (ie name change) + for existing slots in DB when :class is the synch type +- performance validation of allegro native string serialization (0.5.2) +- Fix multi-repository handling (Ian/Richard) (0.5.2) +- Closer to MOP conversion? (Check licensing) (0.5.3) +- Time/Space performance tuning on indexed slots (0.5.4) + - Reclaim storage on secondary index drop? + - Compute dependencies on derived slots to improve performance + - Optimize consistency updating of inverted indices (currently remove/add) + - Custom DB table instead of using primary/secondary? + - Do not store duplicates in inverted index, store a list of + objects instead that can be operated on cheaply? +- Help Robert integrate his in-memory alternative (non-concurrent mode) + (change use of bdb settings & class slot read/write behavior) (0.6.0) + +DOCUMENTATION: + +Defining Indexed Persistent Classes + +Elephant now contains the facility for default class instance indexing and inverted +indicies defined against slots or functions that compute derived parameters. + +Class indexing is enabled whenever an inverted index is specified. Later releases +may allow for class indexing without inverted indices. Indexing can be specified +interactively at runtime or by :indexed t/nil slot initargs in the class definition. +Only persistent slots can be indexed and derived index functions may only depend on +persistent slots (although no error checking is currently performed on derived slots) + +When a slot is declared indexed, each write to an indexed persistent slot results in +an update to a dedicated class indexed-btree. This btree is organized based on the +instance oid->instance. All class instances can be found by walking the primary +indexed btree. Inverted indices are managed through secondary indices which are +automatically updated by writes to the primary index. Each slot index and derived +index has a secondary (btree-index) btree dedicate to it. This functionality is +similar to that defined for the Symbolics Statice database. + +Writes to classes with an inverted index on the written slot are more expensive than +standard writes. They involves, at least, three additional reads to verify that the +primary index key-value and secondary index key-value are the same. To validate +the secondary key-value pair the persistent value is read again by the key-function +defined on the secondary index. This is very appropriate for read heavy, interactive +systems that will be using the indexes alot, but less so for write-dominated archives +such as log files. Log files that are infrequently read are better off stored without +indexing using a linked list with a market index that taps into the linked list at +various points according to date, sequence number, etc. Systems that care little about +throughput can be agnostic to the performance impact as read/writes are likely to be +a very small part of the total runtime. (Can I justify this statement empirically?) + +Interactive manipulation of indexing is allowed through an API defined in indexing.lisp. +Classes can have indexing enabled/disabled. Individual slots can be registered and +unregistered as indexed slots and derived slots can be added only via the interactive +functions. + +There are some touchy issues in reconnecting to an existing indexed slot database. +Elephant does not yet support persistent classes and so interactive changes to indexing +may clash with the initargs in the original defclass. If this is the case, the system +will adapt the defined class to the persistent state and warn the user that the text +is out of date with the persistent indexing state. It is a good idea to change slot +indexing behavior using change-class or by re-evaluating a changed class definition. +In the lisp tradition, we'll assume you know what you're doing when you interactively +change things so we'll maintain derived indices. If they have slot dependencies that +are lost under a change-class operation then there will be an error issued by the +derived function at runtime and you'll have to drop and restart that index. We may +add some more sophistication here at a later date (such as allowing specification of +the slots a derived index depends on so we can automatically drop and compute updates. + +Database Queries for Indexed Instances + +All the above functionality leaves us with a set of indexed instances. The indexing +functionality provides three APIs for leveraging this infrastructure in your programs. + +1) Simplified cursor interface. You can use the underlying btree cursors directly if +you want to do sophisticated operations over the indices. Be sure to wrap side effects +to the store in with-transaction statements and to close your indices when done. + +2) Instance set retrieval. You can retrieve sets of instances using simple interfaces +that retrieve instances by slot value, a range of slot values (range is determined +using the built-in elephant key order routine) or all class instances. This API also +allows mapping over ranges, sets of values or all class instances. + +3) Query language. This is relatively primitive for now, it allows you to do joins +over multiple slot or derived indices to pick a subset of classes that satisfy a given +relation. Later we hope to allow for more complex class instance inter-dependencies, +for example persistent graphs where subgraphs are deferentiated by class-type or slot +values. + +See the API reference for + + + + --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/05 23:13:07 1.18 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/02/07 23:23:50 1.19 @@ -54,6 +54,31 @@ metaclass.") (:metaclass persistent-metaclass)) +;;(defmethod print-object ((obj persistent) stream) + +(defmethod initialize-instance ((instance persistent-object) &rest initargs &key from-oid &allow-other-keys) + (declare (ignore initargs)) + (if (indexed (class-of instance)) + (progn + (let ((oid (oid instance))) + (declare (type fixnum oid)) + (inhibit-indexing oid) + (unwind-protect + (call-next-method) + (uninhibit-indexing oid)) + ;; Inhibit indexing if the object already was defined (ie being created from an oid) + ;; as it should be indexed already. This hack avoids a deadlock situation where we + ;; write the class or index page that we are currently reading via a cursor without + ;; going through the cursor abstraction. There has to be a better way to do this. + (when (not from-oid) + (let ((class-index (find-class-index (class-of instance)))) + (when class-index +;; (format t "Indexing initial instance: ~A :: ~A~%" oid instance) + (with-transaction () + (setf (get-value oid class-index) instance))))))) + ;; else + (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)) @@ -89,10 +114,13 @@ #+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)) + (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) @@ -101,19 +129,24 @@ #+(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) (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 (defmethod finalize-inheritance :around ((instance persistent-metaclass)) (prog1 (call-next-method) - (if (not (slot-boundp instance '%persistent-slots)) + (when (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) - (cons (persistent-slot-names instance) nil))))) + (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)) @@ -169,17 +202,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 "persistent-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)) ) ) @@ -200,7 +232,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 @@ -209,6 +243,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)) @@ -217,11 +254,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))) + (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." @@ -242,19 +289,21 @@ (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))) + ;; 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)) + (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 --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/04 22:25:09 1.14 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/02/07 23:23:50 1.15 @@ -121,11 +121,9 @@ (defclass bdb-indexed-btree (indexed-btree bdb-btree ) ( - (indices :accessor indices :initform (make-hash-table) - ) + (indices :accessor indices :initform (make-hash-table)) (indices-cache :accessor indices-cache :initform (make-hash-table) - :transient t -) + :transient t) ) (:metaclass persistent-metaclass) (:documentation "A BDB-based BTree supports secondary indices.")) @@ -276,6 +274,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 @@ -355,7 +354,7 @@ "Puts are not allowed on secondary indices. Try adding to the primary." (declare (ignore value key) - (ignorable bt)) + (ignorable bt)) (error "Puts are forbidden on secondary indices. Try adding to the primary.")) (defgeneric get-primary-key (key bt) --- /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/05 23:13:07 1.16 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/02/07 23:23:50 1.17 @@ -32,15 +32,17 @@ ) (defun get-controller (spec) - (let ((store-controllers nil)) - (dolist (s *strategies*) - (let ((sc (funcall s spec))) - (if sc - (push sc store-controllers)))) - (if (not (= (length store-controllers) 1)) - (error "Strategy resolution for this spec completely failed!") - (car store-controllers)) - )) + (let ((cached-sc (gethash spec *dbconnection-spec*))) + (if cached-sc cached-sc + (let ((store-controllers nil)) + (dolist (s *strategies*) + (let ((sc (funcall s spec))) + (if sc + (push sc store-controllers)))) + (if (not (= (length store-controllers) 1)) + (error "Strategy resolution for this spec completely failed!") + (car store-controllers)) + )))) (defclass store-controller () @@ -50,6 +52,7 @@ :accessor controller-path :initarg :path) (root :reader controller-root) + (class-root :reader controller-class-root) (db :type (or null pointer-void) :accessor controller-db :initform '()) (environment :type (or null pointer-void) :accessor controller-environment) @@ -74,7 +77,7 @@ creation, counters, locks, the root (for garbage collection,) et cetera.")) -;; Without somemore sophistication, these functions +;; Without some more sophistication, these functions ;; need to be defined here, so that they will be available for testing ;; even if you do not use the strategy in question... (defun bdb-store-spec-p (path) @@ -105,6 +108,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.")) @@ -313,14 +320,23 @@ (let ((root (make-instance 'bdb-btree :from-oid -1 :sc sc))) (setf (slot-value sc 'root) root)) + + (setf (slot-value sc 'class-root) + (make-instance 'bdb-btree :from-oid -2 :sc sc)) + 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 + (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) ;; clean instance cache - (setf (instance-cache sc) (make-cache-table :test 'eql)) + (reset-instance-cache sc) ;; close handles / environment (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) @@ -336,7 +352,10 @@ (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) (setf (controller-environment sc) nil) - nil)) + nil) + ;; Delete connection spec so object ops on cached db info fail + (remhash (controller-path *store-controller*) *dbconnection-spec*)) + ;; Do these things need to take &rest arguments? (defmethod build-btree ((sc bdb-store-controller)) @@ -387,15 +406,18 @@ the controller unconditionally on exit." `(unwind-protect (progn - (let (*store-controller* (open-controller ,sc)) + (let ((*store-controller* (open-controller ,sc))) (declare (special *store-controller*)) ,@body)) (close-controller ,sc))) (defun close-store () "Conveniently close the store controller." + (declare (special *store-controller*)) (if *store-controller* - (close-controller *store-controller*))) + (progn + (close-controller *store-controller*) + (setf *store-controller* nil)))) (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, --- /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/04 22:25:09 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant.lisp 2006/02/07 23:23:50 1.20 @@ -90,6 +90,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/index-tutorial.lisp 2006/02/03 04:19:44 1.1 +++ /project/elephant/cvsroot/elephant/src/index-tutorial.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,94 @@ + +(defpackage elephant-tutorial + (:use :cl :elephant)) + +(in-package :elephant-tutorial) + +(defclass simple-plog () + ((timestamp :accessor plog-timestamp :initarg :timestamp :indexed t) + (type :accessor plog-type :initarg :type :indexed t) + (data :accessor plog-data :initarg :data) + (user :accessor plog-user :initarg :user :indexed t)) + (:metaclass persistent-metaclass) + (:documentation "Simple persistent log")) + +(defclass url-record () + ((url :accessor url-record-url :initarg :url :initform "") + (fetched :accessor url-record-fetched :initarg :fetched :initform nil) + (analyzed :accessor url-record-analyzed :initarg :analyzed :initform nil)) + (:documentation "An application object, declared persistent but not indexed")) + +(defmethod print-object ((obj url-record) stream) + "Pretty print program objects so they're easy to inspect" + (format stream "<url: ~A ~A ~A>" (url-record-url obj) (url-record-fetched obj) (url-record-analyzed obj))) + +(defclass url-log (simple-plog) () + (:metaclass persistent-metaclass) + (:documentation "This class tracks events that transform our program object state")) + +(defmethod print-object ((obj url-log) stream) + "Structured printing of log entries so they're easy to inspect at the repl" + (format stream "#plog[~A :: ~A]" (plog-type obj) (plog-data obj))) + +(defun log-event (user type data) + "A helper function to generically log various events by user" + (make-instance 'url-log + :timestamp (get-universal-time) + :type type + :data data + :user user)) + +(defun report-events-by-time (user start end) + "A custom reporting function for our logs - pull out a time range. A real + implementation might do it by dates or by dates + times using one of the + lisp time libraries" + (let ((entries1 (get-instances-by-range 'url-log 'timestamp start end)) + (entries2 (get-instances-by-value 'url-log 'user user))) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) + (format t "~{~A~%~}" (nreverse (intersection entries1 entries2))))) + +;; +;; This code is the skeleton of a program +;; + +(defvar *start-timestamp* nil) +(defvar *end-timestamp* nil) + +(defun generate-events (user count &optional delay) + (setf *start-timestamp* (get-universal-time)) + (loop for i from 1 upto count do + (let ((url (get-a-url user i))) + (sleep delay) + (fetch-url url user) + (sleep delay) + (analyze-url url user) + (sleep delay))) + (setf *end-timestamp* (get-universal-time))) + +(defun get-a-url (user seq) + (let ((url (make-instance 'url-record :url (format nil "http://www.common-lisp.net/~A/" seq)))) + (log-event user :received-url url) + url)) + +(defun fetch-url (url user) + (setf (url-record-fetched url) t) + (log-event user :fetched-url url)) + +(defun analyze-url (url user) + (setf (url-record-analyzed url) t) + (log-event user :analyzed-url url)) + +;; Top Level Test Code + +(defun test-generate-and-report (name store-spec) + (open-store store-spec) + (generate-events name 10 0.2) + (report-events name) + (close-store)) + +(defun report-events (name) + (let ((first-third-start *start-timestamp*) + (first-third-end (+ *start-timestamp* + (/ (- *end-timestamp* *start-timestamp*) 3)))) + (report-events-by-time name first-third-start first-third-end))) + --- /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/01/30 05:09:12 1.1 +++ /project/elephant/cvsroot/elephant/src/index-utils.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,128 @@ + + +(in-package :elephant) + +;; +;; Simple utilities for managing synchronization between class +;; definitions and database state +;; + +(defmethod class-index-cached? ((class persistent-metaclass)) + (and (slot-boundp class '%index-cache) + (subtypep (type-of (%index-cache class)) 'btree))) + +(defmethod determine-synch-method ((class persistent-metaclass)) + "This method should be called on the class if the %index-cache slot is + not a subtype of class btree to determine what synch method to call + on the current database btree. If DB doesn't exist, then you can ignore this" + (cond ((not (slot-boundp class '%index-cache)) + *default-indexed-class-synch-policy*) + ((member (%index-cache class) '(:class :union :db)) + (%index-cache class)) + (t *default-indexed-class-synch-policy*))) + +(defmethod set-db-synch ((class persistent-metaclass) method) + "Tell the class the synch method to use to synchronize the class indices + and the current class definition" + (assert (member method '(:class :db :union))) + (setf (%index-cache class) method)) + +;; +;; Differentiate derived indices from slot-based ones +;; + +(defparameter *derived-index-marker* "%%derived%%-") + +(defun make-derived-name (name) + (intern (format nil "~A~A" *derived-index-marker* name))) + +(defun derived-name? (name) + (when (symbolp name) (setf name (symbol-name name))) + (string= (subseq name 0 (min (length name) + (length *derived-index-marker*))) + *derived-index-marker*)) + +(defun get-derived-name-root (dname) + (when (symbolp dname) (symbol-name dname)) + (intern (subseq dname (length *derived-index-marker*)))) + +;; +;; Interface fn for slot key forms +;; + +(defun make-slot-key-form (class name) + (assert (member name (car (%persistent-slots class)))) + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (read-slot-for-index ',(class-name class) ',name instance))) + +(defun read-slot-for-index (class-name slot-name instance) + (let ((class (find-class class-name))) + (multiple-value-bind (found? slot-def) (find-effective-slot-def class slot-name) + (when (and found? + (slot-boundp-using-class class instance slot-def)) + (values t (persistent-slot-reader instance slot-name)))))) + +(defun find-effective-slot-def (class slot-name) + (loop for slot in (class-slots class) do + (when (eq (slot-definition-name slot) slot-name) + (return (values t slot))))) + + +;; +;; Simplify the computations for derived parameters +;; + +(defun make-derived-key-form (dform) + "Change the index function interface for derived class slotsw + to better handle the various use cases. The provided function + accepts a single argument, the class instance to comput a + dervied parameter against. Dervied indices can + specify that the result should not be indexed by returning + two values (values nil t) the second of which is an ignore + specifier. Normal functions just return the value which is + an implicit index command. Accessors that compute against + unbound slots are silently ignored (ie initialization) and + errors of other types produce warnings and are ignored. This + handles both named functions and anonymous lambdas." + `(lambda (slot-index primary instance) + (declare (ignore slot-index primary)) + (compute-derived-key-result instance #',dform))) + +(defun compute-derived-key-result (instance fn) + (handler-case + (multiple-value-bind (val ignore) + (funcall fn instance) + (if ignore + (values nil nil) + (values t val))) + (unbound-slot () + (values nil nil)) + (error (e) + (warn "Error ~A computing derived index for on instance ~A" e instance) + (values nil nil)))) + +;; +;; This has turned out to be useful for debugging +;; + + +(defun describe-db-class-index (class-name &key (sc *store-controller*)) + (let ((class-idx (find-class-index class-name :sc sc))) + (if class-idx + (let ((names nil)) + (maphash (lambda (k v) + (declare (ignore v)) + (push k names)) + (indices-cache class-idx)) + (format t "Class Index: ~A~%" class-name) + (format t "~{~A~%~}" (nreverse names))) + (format t "No persistent index for class ~A.~%" class-name)))) + +(defun wipe-indexed-class (name) + (ignore-errors + (disable-class-indexing name) + (reset-instance-cache *store-controller*) + (setf (find-class name) nil))) + + --- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/01/26 04:03:44 1.1 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 @@ -0,0 +1,548 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; slot-index.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods +;;; +;;; Initial version 1/24/2006 Ian Eslick +;;; eslick at alum mit edu +;;; +;;; License: Lisp Limited General Public License +;;; http://www.franz.com/preamble.html +;;; + +(in-package "ELEPHANT") + +;; +;; User level class indexing control protocol +;; +;; Operates against the current *store-controller* +;; but many accept a :sc keyword to change the controller +;; The specific indices created can be specialized on the +;; controller type. See the internal implementor protocol +;; below. + +(defparameter *default-indexed-class-synch-policy* :class + "[:union | :db | :class] determines which reference defines + the indexing structure after a reconnect to a persistent + store. If the class is redefined, the default is that the + class dominates. Changing this parameter alters the + default behavior to :union (merge indexed slots from database + and class definition) or :db which changes the indexing of + the class to match the db. This can fail in several ways: + a) the class does not have a persistent slot defined for + a slot index (will be treated as derived & fail on write) + b) A slot has been added with the name of a derived index + this will be confusing + c) The key-slot function definitions (if not an anoymous + lambda) may have changed leading to unexpected indexing") + +(defgeneric find-class-index (persistent-metaclass &rest rest) + (:documentation "This method is the way to access the class index via + the class object. We can always fetch it or we can cache it in + the class itself. It returns an indexed-btree.")) + +(defgeneric find-inverted-index (persistent-metaclass index-name &key null-on-fail) + (:documentation "This method finds an inverted index defined on + the class described by persistent-metaclass.")) + +(defgeneric enable-class-indexing (persistent-metaclass slot-names &rest rest) + (:documentation "Enable a class instance index for this object. It's + an expensive thing to support on writes so know that you need it + before you do it.")) + +(defgeneric disable-class-indexing (persistent-metaclass &rest rest) + (:documentation "Delete and remove class instance indexing and any + secondary indices defined against it")) + +(defgeneric add-class-slot-index (persistent-metaclass slot-name &rest rest) + (:documentation "Add a per-slot class index option to the class + index based on the class accessor method")) + +(defgeneric remove-class-slot-index (persistent-metaclass slot-name &key sc) + (:documentation "Remove the per-slot index from the db")) + +(defgeneric add-class-derived-index (persistent-metaclass name derived-defun &rest rest) + (:documentation "Add a simple secondary index to this class based on + a function that computes a derived parameter. WARNING: derived + parameters are only valid on persistent slots. An arbitrary function + here will fail to provide consistency on transient slots or global + data that is not stored in the persistent store. Derived indexes are + deleted and rebuilt when a class is redefined")) + +(defgeneric remove-class-derived-index (persistent-metaclass name &rest rest) + (:documentation "Remove a derived index by providing the derived name + used to name the derived index")) + + +;; =========================== +;; INDEX UPDATE ROUTINE +;; =========================== + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "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-indexed slots." + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (with-transaction () + (persistent-slot-writer new-value instance slot-name)) + (let ((class-idx (find-class-index class)) + (*auto-commit* nil)) +;; (format t "Indexing object: ~A oid: ~A~%" instance oid) + (with-transaction () + ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + + +(defun no-indexing-needed? (class instance slot-def oid) + (or (and (not (indexed slot-def)) ;; not indexed + (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes + (member oid *inhibit-indexing-list*))) ;; currently inhibited + +;; =========================== +;; CLASS INDEX INTERFACE +;; =========================== + +(defmethod find-class-index ((class-name symbol) &key (sc *store-controller*)) + (find-class-index (find-class class-name) :sc sc)) + +(defmethod find-class-index ((class persistent-metaclass) &key (sc *store-controller*)) + (ensure-finalized class) + (if (class-index-cached? class) + ;; we've got a cached reference, just return it + (%index-cache class) + (multiple-value-bind (btree found) + (get-value (class-name class) (controller-class-root sc)) + (if found + (cache-existing-class-index class btree sc) + (cache-new-class-index class sc))))) + +(defun ensure-finalized (class) + (when (not (class-finalized-p class)) + (warn "Manually finalizing class ~A" (class-name class)) + (finalize-inheritance class))) + +(defun cache-existing-class-index (class btree sc) + "If we have a persistent index already, assign, synchronize & return it" + (let ((method (determine-synch-method class))) + (setf (%index-cache class) btree) + (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))))) + + +(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)) + (dslot (make-derived-name slot)) + (idx (or (get-index cidx slot) + (get-index cidx dslot)))) + (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))))))) + +(defmethod find-inverted-index-names ((class persistent-metaclass)) + (let ((names nil)) + (maphash (lambda (name idx) + (declare (ignore idx)) + (push name names)) + (indices (find-class-index class))) + names)) + +;; ============================= +;; INDEXING INTERFACE +;; ============================= + +(defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) + (let ((croot (controller-class-root sc))) + (multiple-value-bind (btree found) + (get-value (class-name class) croot) + (declare (ignore btree)) + (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) + ;; Put class instance index into the class root & cache it in the class object + (with-transaction (:store-controller sc) + (let ((class-idx (build-indexed-btree sc))) + (setf (get-value (class-name class) croot) class-idx) + (setf (%index-cache class) class-idx) + ;; Add all the indexes + (loop for slot in indexed-slot-names do + (add-class-slot-index class slot :populate nil :sc sc)) + ;; Sanity check + (let ((record (indexed-record class))) + (declare (ignorable record)) + (assert (indexed class))) + class-idx)))) + +(defmethod disable-class-indexing ((class-name symbol) &key (errorp t) (sc *store-controller*)) + (let ((class (find-class class-name errorp))) + (when class + (disable-class-indexing class :sc sc)))) + +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) + (let ((class-idx (find-class-index class :sc sc))) + (unless class-idx (return-from disable-class-indexing nil)) + ;; Remove all instance key/value data from the class index (& secondary indices) + (with-transaction (:store-controller sc) + (with-btree-cursor (cur class-idx) + (when (cursor-first cur) + (loop while (cursor-delete cur))))) + ;; Get the names of all indices & remove them + (let ((names nil)) + (maphash (lambda (name secondary-index) + (declare (ignore secondary-index)) + (push name names)) + (indices-cache class-idx)) + (dolist (name names) + (if (member name (class-slots class)) + (remove-class-slot-index class name) + (with-transaction (:store-controller sc) + (remove-index class-idx name))))) + ;; Drop the class instance index from the class root + (with-transaction (:store-controller sc) + (remove-kv (class-name class) (controller-class-root sc))) + (setf (%index-cache class) nil) + ;; Clear out the current class + (update-indexed-record class nil) + )) + +(defmethod add-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (add-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod add-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (populate t) (update-class t)) + (if (find-inverted-index class slot-name :null-on-fail t) + (warn "Duplicate slot index named ~A requested for class ~A. Ignoring." + slot-name (class-name class)) + (progn + (when update-class (register-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (add-index (find-class-index class :sc sc) + :index-name slot-name + :key-form (make-slot-key-form class slot-name) + :populate populate)) + t))) + +(defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) + (remove-class-slot-index (find-class class) slot-name :sc sc)) + +(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) + ;; NOTE: Write routines to recover BDB storage when you've wiped an index... + ;; NOTE: If the transaction aborts we should not update class slots? + (if (find-inverted-index class slot-name :null-on-fail t) + (progn + (when update-class (unregister-indexed-slot class slot-name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) slot-name)) + t) + (progn + (warn "Slot index ~A not found for class ~A" slot-name (class-name class)) + nil))) + +(defmethod add-class-derived-index ((class symbol) name derived-defun &key (sc *store-controller*) (populate t)) + (add-class-derived-index (find-class class) name derived-defun :sc sc :populate populate)) + +(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key (populate t) (sc *store-controller*) (update-class t)) + (let ((class-idx (find-class-index class :sc sc))) + (if (find-inverted-index class (make-derived-name name) :null-on-fail t) + (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) + (progn + (when update-class (register-derived-index class name)) + (with-transaction (:store-controller sc) + (add-index class-idx + :index-name name + :key-form (make-derived-key-form derived-defun) + :populate populate)))))) + +(defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) + (remove-class-derived-index (find-class class) name :sc sc)) + +(defmethod remove-class-derived-index ((class persistent-metaclass) name &key (sc *store-controller*) (update-class t)) + (if (find-inverted-index class name :null-on-fail t) + (progn + (when update-class (unregister-derived-index class name)) + (with-transaction (:store-controller sc) + (remove-index (find-class-index class :sc sc) name)) + t) + (progn + (warn "Derived index ~A does not exist in ~A" name (class-name class)) + nil))) + +;; ========================= +;; Low level cursor API +;; ========================= + +(defgeneric make-inverted-cursor (persistent-metaclass name) + (:documentation "Define a cursor on the inverted (slot or derived) index")) + +(defgeneric make-class-cursor (persistent-metaclass) + (:documentation "Define a cursor over all class instances")) + +;; TODO! +;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) +;; (:documentation "Make a join cursor using the slot-value pairs in +;; the specification assoc-list. Support for complex queries +;; requiring new access to db-functions and a new cursor type")) + +;; implementation +(defmethod make-inverted-cursor ((class persistent-metaclass) name) + (make-cursor (find-inverted-index class name))) + +(defmacro with-inverted-cursor ((var class name) &body body) + `(let ((,var (make-inverted-cursor ,class ,name))) + (unwind-protect (progn ,@body) + (cursor-close ,var)))) + +(defmethod make-class-cursor ((class persistent-metaclass)) + (make-cursor (find-class-index class))) + +(defmacro with-class-cursor ((var class) &body body) + `(let ((,var (make-class-cursor ,class))) + (unwind-protect (progn ,@body) + (cursor-close ,var)))) + + +;; ========================= +;; User-level lisp API +;; ========================= + +(defgeneric get-instances-by-class (persistent-metaclass)) +(defgeneric get-instances-by-value (persistent-metaclass slot-name value)) +(defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) + +;; map instances +;; iterate over instances + +(defmethod get-instances-by-class ((class symbol)) + (get-instances-by-class (find-class class))) + +(defmethod get-instances-by-class ((class persistent-metaclass)) + (let ((instances nil) + (cidx (find-class-index class))) + (with-btree-cursor (cur cidx) + (multiple-value-bind (exists? key val) (cursor-first cur) + (declare (ignore key)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? key val) (cursor-next cur) + (declare (ignore key)) + (if exists? + (push val instances) + (return-from get-instances-by-class instances))))))))) + +(defmethod get-instances-by-value ((class symbol) slot-name value) + (get-instances-by-value (find-class class) slot-name value)) + +(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) + (let ((instances nil)) + (with-btree-cursor (cur (find-inverted-index class slot-name)) + (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) + (declare (ignore skey pkey)) + (when exists? + (push val instances) + (loop + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignorable skey pkey)) + (if exists? + (push val instances) + (return-from get-instances-by-value instances))))))))) + +(defmethod get-instances-by-range ((class symbol) slot-name start end) + (get-instances-by-range (find-class class) slot-name start end)) + +(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) + (with-inverted-cursor (cur class idx-name) + (labels ((next-range (instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val instances)) + (nreverse instances)))) + (next-in-range (key instances) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (declare (ignore pkey skey)) + (if exists? + (next-in-range key (cons val instances)) + (progn + (cursor-pset-range cur key) + (next-range instances)))))) + (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start) + (declare (ignore pkey)) + (if (and exists? (<= skey end)) + (next-in-range skey (cons val nil)) + nil))))) + +(defun drop-instances (instances &key (sc *store-controller*)) + (assert (consp instances)) + (with-transaction (:store-controller sc) [151 lines skipped] --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/05 23:13:07 1.12 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/02/07 23:23:51 1.13 @@ -24,6 +24,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 ) @@ -65,17 +66,23 @@ to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) - ((%persistent-slots :accessor %persistent-slots)) + ((%persistent-slots :accessor %persistent-slots) + (%indexed-slots :accessor %indexed-slots) + (%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.")) +default; use the :transient flag otherwise. Slots can also +be indexed for by-value retrieval.")) + +;; +;; Persistent slot maintenance +;; (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) @@ -91,8 +98,9 @@ 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) ()) @@ -117,6 +125,115 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil) +;; +;; 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 :initarg :derived :initform 0))) + +(defmethod print-object ((obj indexing-record) stream) + (format stream "#INDEXING-RECORD<islt: ~A dslt: ~A>" + (length (indexing-record-slots obj)) + (length (indexing-record-derived obj)))) + +(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 (when oldrec (indexing-record-derived oldrec))) + (if oldrec oldrec nil))))) + +(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 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 warning +;; (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" + (let ((record (indexed-record class))) + (push name (indexing-record-derived record)))) + +(defmethod unregister-derived-index (class name) + (let ((record (indexed-record class))) + (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)) + (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 +;; + #+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) '(:instance :class :database)) @@ -128,12 +245,16 @@ "Checks for the transient tag (and the allocation type) and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) - (transient-p (getf initargs :transient))) + (transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) + (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) (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")) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -161,9 +282,13 @@ (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) "Chooses the persistent or transient effective slot definition class depending on the keyword." - (let ((transient-p (getf initargs :transient))) + (let ((transient-p (getf initargs :transient)) + (indexed-p (getf initargs :indexed))) (when (consp transient-p) (setq transient-p (car transient-p))) - (cond (transient-p + (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")) + (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition))))) @@ -213,11 +338,13 @@ (defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) - (append initargs '(:transient t)) - (progn - (setf (getf initargs :allocation) :database) - initargs)))) - + (setf initargs (append initargs '(:transient t))) + (setf (getf initargs :allocation) :database)) + ;; 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))) (defmacro persistent-slot-reader (instance name) `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) @@ -229,7 +356,7 @@ (let ((buf (db-get-key-buffered (controller-db (check-con (:dbcn-spc-pst ,instance))) key-buf value-buf))) - (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst instance))) + (if buf (deserialize buf :sc (check-con (:dbcn-spc-pst ,instance))) #+cmu (error 'unbound-slot :instance ,instance :slot ,name) #-cmu @@ -301,7 +428,7 @@ (defun persistent-slot-names (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions - when (equalp (class-of slot-definition) (find-class 'persistent-effective-slot-definition)) + when (subtypep (type-of slot-definition) 'persistent-effective-slot-definition) collect (slot-definition-name slot-definition)))) (defun transient-slot-names (class) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/04 22:25:09 1.18 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/02/07 23:23:51 1.19 @@ -102,8 +102,8 @@ (eval-when (:compile-toplevel :load-toplevel) (defparameter *c-library-extension* - #+macosx "dylib" - #-macosx "so" )) + #+(or darwin macosx) "dylib" + #-(or darwin macosx) "so" )) (eval-when (:compile-toplevel :load-toplevel) --- /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/04 22:25:09 1.3 +++ /project/elephant/cvsroot/elephant/src/sql-collections.lisp 2006/02/07 23:23:51 1.4 @@ -25,7 +25,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