Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv1023/src
Modified Files: Tag: ELEPHANT-0-4-1-rc1-IAN bdb-enable.lisp classes.lisp collections.lisp controller.lisp metaclasses.lisp sleepycat.lisp Added Files: Tag: ELEPHANT-0-4-1-rc1-IAN IAN-TODO indexing.lisp Log Message: First pass implementation of main class indexing system after branching from 0.4.1-rc1
--- /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/25 22:18:03 1.4 +++ /project/elephant/cvsroot/elephant/src/bdb-enable.lisp 2006/01/26 04:03:44 1.4.2.1 @@ -66,15 +66,15 @@ (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") (error "Couldn't load libpthread!"))
- (unless - (uffi:load-foreign-library - (if (find-package 'asdf) + (unless + (uffi:load-foreign-library + (if (find-package 'asdf) (merge-pathnames - #p"libmemutil.so" + (make-pathname :name "libmemutil" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - "/usr/local/share/common-lisp/elephant-0.3/libmemutil.so") - :module "libmemutil") - (error "Couldn't load libmemutil.so!")) + (format nil "/usr/local/share/common-lisp/elephant-0.3/libmemutil.~A" *c-library-extension*)) + :module "libmemutil") + (error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; This code has now been moved to the small, asdf-loadable system @@ -87,9 +87,9 @@ ;; "/db/ben/lisp/db43/lib/libdb.so" "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" ;; this works on FreeBSD - #+(and (or bsd freebsd) (not darwin)) + #+(and (or bsd freebsd) (not darwin macosx)) "/usr/local/lib/db43/libdb.so" - #+darwin + #+(or darwin macosx) ;; for Fink (OS X) -- but I will assume Linux more common... ;; "/sw/lib/libdb-4.3.dylib" ;; a possible manual install @@ -102,10 +102,10 @@ (uffi:load-foreign-library (if (find-package 'asdf) (merge-pathnames - #p"libsleepycat.so" + (make-pathname :name "libsleepycat" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.so") + (format nil "/usr/local/share/common-lisp/elephant-0.3/libsleepycat.~A" *c-library-extension*)) :module "libsleepycat") - (error "Couldn't load libsleepycat!")) + (error "Couldn't load libsleepycat.~A!" *c-library-extension*))
) --- /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/25 14:09:46 1.16 +++ /project/elephant/cvsroot/elephant/src/classes.lisp 2006/01/26 04:03:44 1.16.2.1 @@ -138,7 +138,10 @@ (call-next-method) (if (not (slot-boundp instance '%persistent-slots)) (setf (%persistent-slots instance) - (cons (persistent-slot-names instance) nil))))) + (cons (persistent-slot-names instance) nil))) + (if (not (slot-boundp instance '%indexed-slots)) + (setf (%indexed-slots instance) + (cons (indexed-slot-names instance) nil)))))
;; #+(or cmu sbcl) ;; (defmethod finalize-inheritance :around ((instance persistent-metaclass)) @@ -247,6 +250,8 @@ (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) +;; (when (%indexed-p class) +;; (update-class-index class instance))))
(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." --- /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/24 15:42:30 1.13 +++ /project/elephant/cvsroot/elephant/src/collections.lisp 2006/01/26 04:03:44 1.13.2.1 @@ -144,11 +144,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.")) @@ -378,7 +376,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/01/24 15:42:30 1.14 +++ /project/elephant/cvsroot/elephant/src/controller.lisp 2006/01/26 04:03:44 1.14.2.1 @@ -74,6 +74,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) @@ -98,7 +99,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) @@ -338,11 +339,16 @@
(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 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)) --- /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/24 15:42:30 1.10 +++ /project/elephant/cvsroot/elephant/src/metaclasses.lisp 2006/01/26 04:03:44 1.10.2.1 @@ -87,11 +87,14 @@ 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) + (%instance-index :accessor %instance-index)) (: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"))
(defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) @@ -113,6 +116,26 @@ nil) )))
+(defmethod %indexed-p ((class persistent-metaclass)) + (and (slot-boundp class '%indexed-slots) + (car (%indexed-slots class)))) + +(defmethod indexed-slots ((class persistent-metaclass)) + (car (%indexed-slots class))) + +(defmethod indexed-slots ((class standard-class)) + nil) + +(defmethod old-indexed-slots ((class persistent-metaclass)) + (cdr (%indexed-slots class))) + +(defmethod update-indexed-slots ((class persistent-metaclass) new-slot-list) + (setf (%indexed-slots class) (cons new-slot-list + (if (slot-boundp class '%indexed-slots) + (car (%indexed-slots class)) + nil)))) + + (defclass persistent-slot-definition (standard-slot-definition) ())
@@ -131,6 +154,16 @@ (defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ())
+ +(defclass indexed-slot-definition (persistent-slot-definition) + ((indexed :initform t :initarg :indexed :allocation :class))) + +(defclass indexed-direct-slot-definition (persistent-direct-slot-definition indexed-slot-definition) + ()) + +(defclass indexed-effective-slot-definition (persistent-effective-slot-definition indexed-slot-definition) + ()) + (defgeneric transient (slot))
(defmethod transient ((slot standard-direct-slot-definition)) @@ -139,6 +172,14 @@ (defmethod transient ((slot persistent-direct-slot-definition)) nil)
+(defgeneric indexed (slot)) + +(defmethod indexed ((slot standard-direct-slot-definition)) + nil) + +(defmethod indexed ((slot indexed-direct-slot-definition)) + t) + #+allegro (defmethod excl::valid-slot-allocation-list ((class persistent-metaclass)) '(:instance :class :database)) @@ -150,12 +191,18 @@ "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")) + (indexed-p + (find-class 'indexed-direct-slot-definition)) (transient-p (find-class 'transient-direct-slot-definition)) (t @@ -183,9 +230,15 @@ (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")) + (indexed-p + (find-class 'indexed-effective-slot-definition)) + (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition))))) @@ -235,11 +288,11 @@ (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)) + (if (some #'indexed slot-definitions) + (append initargs '(:indexed t)) + initargs)))
(defmacro persistent-slot-reader (instance name) `(if (not (bdb-store-spec-p (:dbcn-spc-pst ,instance))) @@ -323,7 +376,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) @@ -331,3 +384,8 @@ (loop for slot-definition in slot-definitions unless (persistent-p slot-definition) collect (slot-definition-name slot-definition)))) + +(defun indexed-slot-names (class) + (loop for slot-definition in (class-slots class) + when (subtypep (type-of slot-definition) 'indexed-effective-slot-definition) + collect (slot-definition-name slot-definition))) --- /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2005/12/05 15:27:54 1.16 +++ /project/elephant/cvsroot/elephant/src/sleepycat.lisp 2006/01/26 04:03:44 1.16.2.1 @@ -124,6 +124,10 @@ (eval-when (:compile-toplevel) (proclaim '(optimize (ext:inhibit-warnings 3))))
+(eval-when (:compile-toplevel :load-toplevel) + (defparameter *c-library-extension* + #+macosx "dylib" + #-macosx "so" ))
(eval-when (:compile-toplevel :load-toplevel)
@@ -131,11 +135,11 @@ (uffi:load-foreign-library (if (find-package 'asdf) (merge-pathnames - #p"libmemutil.so" + (make-pathname :name "libmemutil" :type *c-library-extension*) (asdf:component-pathname (asdf:find-system 'elephant))) - (format nil "~A/~A" *elephant-lib-path* "libmemutil.so")) + (format nil "~A/~A.~A" *elephant-lib-path* "libmemutil" *c-library-extension*)) :module "libmemutil") - (error "Couldn't load libmemutil.so!")) + (error "Couldn't load libmemutil.~A!" *c-library-extension*))
;; fini on user editable part
@@ -509,7 +513,8 @@ "Return the number of bytes of the internal representation of a string." #+(and allegro ics) - `(let ((l (length ,s))) (+ l l)) + ;; old: `(let ((l (length ,s))) (+ l l)) + `(excl:native-string-sizeof ,s :external-format :unicode) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s (base-string (length ,s)) @@ -521,7 +526,7 @@ ;; memcpy is faster than looping! For Lispworks this causes ;; a string to array conversion, but I don't know how to do ;; any better (fli:replace-foreign-array is promising?) -#-(or cmu sbcl scl openmcl) +#-(or cmu sbcl scl openmcl allegro) (def-function ("copy_buf" copy-str-to-buf) ((dest array-or-pointer-char) (dest-offset :int) @@ -566,6 +571,18 @@ (ccl::%copy-ivector-to-ptr ivector (+ disp src-offset) dest dest-offset length)))
+#+allegro +(defun copy-str-to-buf (dest dest-offset src src-offset length) + "Use build-in unicode handling and copying facilities. + NOTE: We need to validate the speed of this vs. default." + (declare (optimize (speed 3) (safety 0)) + (type string src) + (type array-or-pointer-char dest) + (type fixnum length src-offset dest-offset) + (dynamic-extent src dest length)) + (excl:string-to-native (subseq src src-offset) :address (offset-char-pointer dest dest-offset) + :external-format :unicode)) + ;; Lisp version, for kicks. this assumes 8-bit chars! #+(not (or cmu sbcl scl allegro openmcl lispworks)) (defun copy-str-to-buf (dest dest-offset src src-offset length) @@ -752,7 +769,10 @@ (resize-buffer-stream bs needed)) ;; I wonder if the basic problem here is that we are using this ;; routine instead of something like "copy-ub8-from-system-area"? + #-allegro (copy-str-to-buf buf size s 0 str-bytes) + #+allegro + (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) (setf size needed) nil)))
@@ -880,7 +900,7 @@ ;; wide!!! #+(and allegro ics) (excl:native-to-string - (offset-char-pointer (buffer-stream-buffer bs) position) + (offset-char-pointer (buffer-stream-buffer bs) position) :length byte-length :external-format :unicode) #+lispworks