elephant-cvs February 2006

elephant-cvs@common-lisp.net

2 participants
108 discussions

[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
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/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/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/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
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 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/tests
by rread 07 Feb '06

07 Feb '06

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp:/tmp/cvs-serv9614/tests Modified Files: elephant-tests.lisp testcollections.lisp Added Files: RunIndexingTutorial.lisp testindexing.lisp Log Message: Merger from Ian's branch into the main trunk. --- /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/05 23:44:26 1.1 +++ /project/elephant/cvsroot/elephant/tests/RunIndexingTutorial.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,39 @@ +(asdf:operate 'asdf:load-op :elephant) +(asdf:operate 'asdf:load-op :ele-bdb) +(asdf:operate 'asdf:load-op :elephant-tests) + +(compile-file "indexing.lisp") +(load "index-tutorial.lisp") + +(in-package "ELEPHANT-TUTORIAL") +(defconstant KILO 1000) +(defun test-generate-and-report-big (num name store-spec) + (open-store store-spec) + (generate-events name num 0.0 ) + (report-events name) + (close-store)) + +(defun find-mid-event (name) + (let ((midpoint (floor (/ (+ *start-timestamp* + *end-timestamp*) 2)))) + (report-events-by-time-only name + midpoint + (+ midpoint)) + ) +) + +(defun report-events-by-time-only (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 (time (get-instances-by-range 'url-log 'timestamp start end))) + (entries2 nil)) + (mapc #'(lambda (x) (if (equal (plog-user x) user) (push x entries2))) entries1) + (format t "Event logs for ~A (~A range, ~A user):~%" user (length entries1) (length entries2)) +)) + + +(time (test-generate-and-report-big (* 10 KILO) "bud" ele-tests::*test-path-primary*)) +(open-store ele-tests::*test-path-primary*) +(time (find-mid-event "bud")) +(close-store) --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/04 22:25:10 1.9 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/02/07 23:23:51 1.10 @@ -92,17 +92,48 @@ (defvar *test-path-primary* *testdb-path* ) + (defvar *test-path-secondary* *testdb-path2* ) - (defun do-all-tests() (progn (do-all-tests-spec *testdb-path*) (do-all-tests-spec *testsqlite3-path*) )) +(defun do-all-tests-spec (spec) + (when spec + (with-open-store (spec) + (let ((*auto-commit* nil)) + (declare (special *auto-commit*)) + (do-tests))))) + +(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 () + (declare (special *old-store*)) + (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)) + (setq *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/02/05 23:13:08 1.10 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/02/07 23:23:51 1.11 @@ -215,6 +215,7 @@ (deftest remove-kv-from-slot1 (finishes (remove-kv 2 index1)) t) + (deftest no-key-nor-indices-slot1 (values (get-value (second keys) indexed) @@ -225,6 +226,7 @@ (deftest remove-kv-from-slot2 (finishes (remove-kv 300 index2)) t) + (deftest no-key-nor-indices-slot2 (values (get-value (third keys) indexed) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/01/29 04:57:21 1.1 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/02/07 23:23:51 1.2 @@ -0,0 +1,235 @@ + +(in-package :ele-tests) + +(defun setup-testing () + (setf rt::*debug* t) + (setf rt::*catch-errors* nil) +;; (trace elephant::indexed-slot-writer) + (trace ((method initialize-instance :before (persistent)))) + (trace ((method initialize-instance (persistent-object)))) +;; (trace ((method shared-initialize :around (persistent-object t)))) +;; (trace ((method shared-initialize :around (persistent-metaclass t)))) +;; (trace elephant::find-class-index) +;; (trace get-instances-by-class) +;; (trace get-instances-by-value) + (trace enable-class-indexing) + (trace get-instances-by-range) + (trace elephant::cache-instance) + (trace elephant::get-cached-instance) + (trace elephant::get-cache) + (trace elephant::db-transaction-commit) + ) + +;; put list of objects, retrieve on value, range and by class +(deftest indexing-basic + (progn +;; (format t "Global vars:~%") +;; (format t "~%basic store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) +;; (format t "auto-commit: ~A~%" *auto-commit*) + (disable-class-indexing 'idx-one :errorp nil) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (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*))) + +;; (format t "Starting gathering of instances~%") + (values (length (get-instances-by-class 'idx-one)) + (length (get-instances-by-value 'idx-one 'slot1 1)) + (length (get-instances-by-value 'idx-one 'slot1 3)) + (eq (first (get-instances-by-value 'idx-one 'slot1 3)) inst3) + (length (get-instances-by-range 'idx-one 'slot1 1 3))))) + 3 2 1 t 3) + +;; test inherited slots +(deftest indexing-inherit + (progn +;; (format t "inherit store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + (disable-class-indexing 'idx-one :sc *store-controller* :errorp nil) + (disable-class-indexing 'idx-two :sc *store-controller* :errorp nil) + (setf (find-class 'idx-one) nil) + (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) + (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)) + (:metaclass persistent-metaclass)) + + (progn + (with-transaction () + (setq inst1 (make-instance 'idx-two :sc *store-controller*))) + + (values (slot1 inst1) + (slot2 inst1) + (slot3 inst1) + (slot4 inst1) + (equal (elephant::indexing-record-slots (elephant::indexed-record (find-class 'idx-two))) + '(slot1 slot3 slot4))))) + 1 20 30 40 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) + (setf (find-class 'idx-one) nil) + + (defclass idx-one () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t)) + (:metaclass persistent-metaclass)) + + (defun make-idx-one (val) + (make-instance 'idx-one :slot1 val :sc *store-controller*)) + + (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) + +(deftest indexing-reconnect-db + (progn + (disable-class-indexing 'idx-two :errorp nil) + (setf (find-class 'idx-two) nil) +;; (format t "connect store: ~A ~A~%" *store-controller* (controller-path *store-controller*)) + + (defclass idx-two () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :indexed t) + (slot2 :initarg :slot2 :initform 2 :accessor slot2) + (slot3 :initarg :slot3 :initform 3 :accessor slot3 :indexed t)) + (:metaclass persistent-metaclass)) + + (let ((*old-default* *default-indexed-class-synch-policy*) + (*default-indexed-class-synch-policy* :db)) + + (with-transaction () + (make-instance 'idx-two)) + + ;; Wipe out the class so it's not a redefinition + (setf (find-class 'idx-two) nil) + + ;; 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)) + (:metaclass persistent-metaclass)) + + ;; Add an instance of the new class + (with-transaction () + (make-instance 'idx-two)) + + ;; DB should dominate (if set as default) + (values (length (get-instances-by-value 'idx-two 'slot3 3)) + (length (get-instances-by-value 'idx-two 'slot1 1)) + (signals-error (length (get-instances-by-value 'idx-two 'slot2 2)))))) + 2 2 t) + +(deftest indexing-change-class + nil + nil) + +(deftest indexing-redef-class + nil + nil) + +(deftest indexing-explicit-changes + nil + nil) + +;; 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)) + (: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)) + (:metaclass persistent-metaclass)) + +(defvar normal-index nil) + +(defun normal-stress-setup (count class-name &rest inst-args) + (setf normal-index (make-btree)) + (dotimes (i count) + (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) + +(defun indexed-stress-setup (count class-name &rest inst-args) + (dotimes (i count) + (apply #'make-instance class-name :stress1 i inst-args))) + +(defun normal-range-lookup (count size) + "Given stress1 slot has values between 1 and count, extract a range of size size that starts + at (/ count 2)" + (let* ((objects nil) + (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)) + +(defun indexed-range-lookup (class count size) + (let* ((start (/ count 2)) + (end (1- (+ start size)))) + (get-instances-by-range class 'stress1 start end))) + +(defparameter *stress-count* 500) +(defparameter *range-size* 40) + +(deftest indexing-timing + (progn + + (let ((insts (get-instances-by-class 'stress-index))) + (when insts + (drop-instances insts))) + + (format t "~%Stress test normal setup time (~A):~%" *stress-count*) + (with-transaction () + (time (normal-stress-setup *stress-count* 'stress-normal :stress2 10))) + + (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) + (with-transaction () + (time (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 indexed lookup time (~A):~%" *range-size*) + (time + (dotimes (i *range-size*) + (declare (ignore i)) + (indexed-range-lookup 'stress-index *stress-count* *range-size*))) + t) + t) + + + +

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

elephant-cvs February 2006