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

[elephant-cvs] CVS update: elephant/src/controller.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv25325/src Modified Files: controller.lisp Log Message: doc-strings table-layout for btrees better with-open-store macro Date: Thu Sep 16 06:15:32 2004 Author: blee Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.9 elephant/src/controller.lisp:1.10 --- elephant/src/controller.lisp:1.9 Sat Sep 4 10:28:44 2004 +++ elephant/src/controller.lisp Thu Sep 16 06:15:31 2004 @@ -49,12 +49,16 @@ (environment :type (or null pointer-void) :accessor controller-environment) (db :type (or null pointer-void) :accessor controller-db) + (btrees :type (or null pointer-void) :accessor controller-btrees) + (indices :type (or null pointer-void) :accessor controller-indices) + (indices-assoc :type (or null pointer-void) + :accessor controller-indices-assoc) (root :reader controller-root) (instance-cache :accessor instance-cache :initform (make-cache-table :test 'eql))) - (:documentation "Class of objects responsible for handling -the book-keeping of holding DB handles, the cache, table -creation, counters, locks, the root and garbage collection, + (:documentation "Class of objects responsible for the +book-keeping of holding DB handles, the cache, table +creation, counters, locks, the root (for garbage collection,) et cetera.")) (defgeneric cache-instance (sc obj)) @@ -65,26 +69,24 @@ (defun add-to-root (key value &key (store-controller *store-controller*)) "Add an arbitrary persistent thing to the root, so you can -retrieve it in a later session. Keys may be arbitrary -persistables as well (though note collection key semantics!) -N.B. this means it (and everything it points to) won't get -gc'd." +retrieve it in a later session. N.B. this means it (and +everything it points to) won't get gc'd." (setf (get-value key (controller-root store-controller)) value)) -(defmethod get-from-root (key &key (store-controller *store-controller*)) - "Get a persistent thing from the root." +(defun get-from-root (key &key (store-controller *store-controller*)) + "Get a something from the root." (get-value key (controller-root store-controller))) -(defmethod remove-from-root (key &key (store-controller *store-controller*)) - "Get a persistent thing from the root." +(defun remove-from-root (key &key (store-controller *store-controller*)) + "Remove something from the root." (remove-kv key (controller-root store-controller))) (defmethod cache-instance ((sc store-controller) obj) - "Register an instance of a user persistent-class with the -controller." + "Cache a persistent object with the controller." (setf (get-cache (oid obj) (instance-cache sc)) obj)) (defmethod get-cached-instance ((sc store-controller) oid class-name) + "Get a cached instance, or instantiate!" (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance @@ -111,6 +113,7 @@ (defvar %oid-lock-length 16) (defmethod next-oid ((sc store-controller)) + "Get the next OID." (sleepycat::next-counter (controller-environment sc) (controller-db sc) *current-transaction* @@ -128,19 +131,46 @@ (db-env-open env (controller-path sc) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread thread :recover recover :recover-fatal recover-fatal) - (let ((db (db-create env))) + (let ((db (db-create env)) + (btrees (db-create env)) + (indices (db-create env)) + (indices-assoc (db-create env))) (setf (controller-db sc) db) (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-btrees sc) btrees) + (sleepycat::db-set-lisp-compare btrees) + (db-open btrees :file "%ELEPHANT" :database "%ELEPHANTBTREES" + :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-indices sc) indices) + (sleepycat::db-set-lisp-compare indices) + (sleepycat::db-set-lisp-dup-compare indices) + (db-set-flags indices :dup-sort t) + (db-open indices :file "%ELEPHANT" :database "%ELEPHANTINDICES" + :auto-commit t :type DB-BTREE :create t :thread thread) + + (setf (controller-indices-assoc sc) indices-assoc) + (sleepycat::db-set-lisp-compare indices-assoc) + (sleepycat::db-set-lisp-dup-compare indices-assoc) + (db-set-flags indices-assoc :dup-sort t) + (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" + :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) + (sleepycat::db-fake-associate btrees indices-assoc :auto-commit t) + (let ((root (make-instance 'btree :from-oid -1))) (setf (slot-value sc 'root) root) - (let ((*auto-commit* t)) - (unless (db-get-key-buffered db %oid-entry %oid-entry-length) - (buffer-write-int 0 *out-buf*) - (db-put-buffered db %oid-entry %oid-entry-length - (buffer-stream-buffer *out-buf*) 4 - :auto-commit t) - (finish-buffer *out-buf*))) + (with-transaction () + (with-buffer-streams (key-buf value-buf) + (let ((key-b (buffer-stream-buffer key-buf))) + (setf (buffer-stream-buffer key-buf) %oid-entry) + (setf (sleepycat::buffer-stream-size key-buf) %oid-entry-length) + (unless (db-get-key-buffered db key-buf value-buf) + (reset-buffer-stream value-buf) + (buffer-write-int 0 value-buf) + (db-put-buffered db key-buf value-buf)) + (setf (buffer-stream-buffer key-buf) key-b)))) sc)))) (defmethod close-controller ((sc store-controller)) @@ -151,7 +181,13 @@ (setf (slot-value sc 'root) nil) ;; clean instance cache (setf (instance-cache sc) (make-cache-table :test 'eql)) - ;; close environment + ;; close handles / environment + (db-close (controller-indices-assoc sc)) + (setf (controller-indices-assoc sc) nil) + (db-close (controller-indices sc)) + (setf (controller-indices sc) nil) + (db-close (controller-btrees sc)) + (setf (controller-btrees sc) nil) (db-close (controller-db sc)) (setf (controller-db sc) nil) (db-env-close (controller-environment sc)) @@ -160,6 +196,8 @@ (defmacro with-open-controller ((&optional (sc '*store-controller*)) &body body) + "Executes body with the specified controller open, closing +the controller unconditionally on exit." `(unwind-protect (progn (let (*store-controller* (open-controller ,sc)) @@ -167,21 +205,24 @@ ,@body)) (close-controller ,sc))) -(defun open-store (path) +(defun open-store (path &key (recover nil) + (recover-fatal nil) (thread t)) + "Conveniently open a store controller." (setq *store-controller* (make-instance 'store-controller :path path)) - (open-controller *store-controller*)) + (open-controller *store-controller* :recover recover + :recover-fatal recover-fatal :thread thread)) (defun close-store () + "Conveniently close the store controller." (close-controller *store-controller*)) (defmacro with-open-store ((path) &body body) - (let ((sc (gensym))) - `(let ((,sc (make-instance 'store-controller :path ,path))) - (unwind-protect - (progn - (let ((*store-controller* ,sc)) - (declare (special *store-controller*)) - (open-controller *store-controller*) - ,@body)) - (close-controller ,sc))))) + "Executes the body with an open controller, +unconditionally closing the controller on exit." + `(let ((*store-controller* (make-instance 'store-controller :path ,path))) + (declare (special *store-controller*)) + (open-controller *store-controller*) + (unwind-protect + (progn ,@body) + (close-controller *store-controller*))))

1 0

[elephant-cvs] CVS update: elephant/src/collections.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv24865/src Modified Files: collections.lisp Log Message: doc-strings secondary indices cursors Date: Thu Sep 16 06:14:44 2004 Author: blee Index: elephant/src/collections.lisp diff -u elephant/src/collections.lisp:1.6 elephant/src/collections.lisp:1.7 --- elephant/src/collections.lisp:1.6 Sun Aug 29 22:36:48 2004 +++ elephant/src/collections.lisp Thu Sep 16 06:14:44 2004 @@ -44,47 +44,774 @@ ;;; collection types ;;; we're slot-less -(defclass persistent-collection (persistent) - ()) +(defclass persistent-collection (persistent) () + (:documentation "Abstract superclass of all collection types.")) ;;; btree access -(defclass btree (persistent-collection) ()) +(defclass btree (persistent-collection) () + (:documentation "A hash-table like interface to a BTree, +which stores things in a semi-ordered fashion.")) (defgeneric get-value (key ht)) (defgeneric (setf get-value) (value key ht)) -(defgeneric remove-kv (key ht &key transaction auto-commit)) +(defgeneric remove-kv (key ht)) (defmethod get-value (key (ht btree)) - (declare (optimize (speed 3) (safety 0) (space 3))) - (buffer-write-int (oid ht) *key-buf*) - (let* ((key-length (serialize key *key-buf*)) - (buf (db-get-key-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length))) - (declare (type fixnum key-length)) - (if buf (values (deserialize buf) T) - (values nil nil)))) + "Get a value from a Btree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-btrees *store-controller*) + key-buf value-buf))) + (if buf (values (deserialize buf) T) + (values nil nil))))) (defmethod (setf get-value) (value key (ht btree)) - (declare (optimize (speed 3) (safety 0))) - (buffer-write-int (oid ht) *key-buf*) - (let ((key-length (serialize key *key-buf*)) - (val-length (serialize value *out-buf*))) - (db-put-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - (buffer-stream-buffer *out-buf*) val-length - :transaction *current-transaction* + "Put a key / value pair into a BTree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (db-put-buffered (controller-btrees *store-controller*) + key-buf value-buf :auto-commit *auto-commit*) value)) -(defmethod remove-kv (key (ht btree) - &key (transaction *current-transaction*) - (auto-commit *auto-commit*)) - (declare (optimize (speed 3) (safety 0))) - (buffer-write-int (oid ht) *key-buf*) - (let ((key-length (serialize key *key-buf*))) - (db-delete-buffered (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) key-length - :transaction transaction - :auto-commit auto-commit))) +(defmethod remove-kv (key (ht btree)) + "Remove a key / value pair from a BTree." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (db-delete-buffered (controller-btrees *store-controller*) + key-buf :auto-commit *auto-commit*))) + + +;; Secondary indices + +(defclass indexed-btree (btree) + ((indices :accessor indices :initform (make-hash-table)) + (indices-cache :accessor indices-cache :initform (make-hash-table) + :transient t)) + (:metaclass persistent-metaclass) + (:documentation "A BTree which supports secondary indices.")) + +(defmethod shared-initialize :after ((instance indexed-btree) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (setf (indices-cache instance) (indices instance))) + +(defgeneric add-index (ht &key index-name key-form)) +(defgeneric get-index (ht index-name)) +(defgeneric remove-index (ht index-name)) + +(defmethod add-index ((ht indexed-btree) &key index-name key-form) + "Add a secondary index. The indices are stored in an eq +hash-table, so the index-name should be a symbol. key-form +should be a symbol naming a function, or a list which +defines a lambda -- actual functions aren't supported. The +function should take 3 arguments: the secondary DB, primary +key and value, and return two values: a boolean indicating +whether to index this key / value, and the secondary key if +so." + (if (and (not (null index-name)) + (symbolp index-name) (or (symbolp key-form) (listp key-form))) + (let ((indices (indices ht)) + (index (make-instance 'btree-index :primary ht + :key-form key-form))) + (setf (gethash index-name (indices-cache ht)) index) + (setf (gethash index-name indices) index) + (setf (indices ht) indices) + index) + (error "Invalid index initargs!"))) + +(defmethod get-index ((ht indexed-btree) index-name) + "Get a named index." + (gethash index-name (indices-cache ht))) + +(defmethod remove-index ((ht indexed-btree) index-name) + "Remove a named index." + (remhash index-name (indices-cache ht)) + (let ((indices (indices ht))) + (remhash index-name indices) + (setf (indices ht) indices))) + +(defmethod (setf get-value) (value key (ht indexed-btree)) + "Set a key / value pair, and update secondary indices." + (declare (optimize (speed 3))) + (let ((indices (indices-cache ht))) + (with-buffer-streams (key-buf value-buf secondary-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (with-transaction () + (db-put-buffered (controller-btrees *store-controller*) + key-buf value-buf) + (loop for index being the hash-value of indices + do + (multiple-value-bind (index? secondary-key) + (funcall (key-fn index) index key value) + (when index? + (buffer-write-int (oid index) secondary-buf) + (serialize secondary-key secondary-buf) + ;; should silently do nothing if the key/value already + ;; exists + (db-put-buffered (controller-indices *store-controller*) + secondary-buf key-buf) + (reset-buffer-stream secondary-buf)))) + value)))) + +(defmethod remove-kv (key (ht indexed-btree)) + "Remove a key / value pair, and update secondary indices." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf secondary-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (with-transaction () + (let ((value (get-value key ht))) + (when value + (let ((indices (indices-cache ht))) + (loop + for index being the hash-value of indices + do + (multiple-value-bind (index? secondary-key) + (funcall (key-fn index) index key value) + (when index? + (buffer-write-int (oid index) secondary-buf) + (serialize secondary-key secondary-buf) + ;; need to remove kv pairs with a cursor! -- + ;; this is a C performance hack + (sleepycat::db-delete-kv-buffered + (controller-indices *store-controller*) + secondary-buf key-buf) + (reset-buffer-stream secondary-buf)))) + (db-delete-buffered (controller-btrees *store-controller*) + key-buf))))))) + +(defclass btree-index (btree) + ((primary :type indexed-btree :reader primary :initarg :primary) + (key-form :reader key-form :initarg :key-form) + (key-fn :type function :accessor key-fn :transient t)) + (:metaclass persistent-metaclass) + (:documentation "Secondary index to an indexed-btree.")) + +(defmethod shared-initialize :after ((instance btree-index) slot-names + &rest rest) + (declare (ignore slot-names rest)) + (let ((key-form (key-form instance))) + (if (and (symbolp key-form) (fboundp key-form)) + (setf (key-fn instance) (fdefinition key-form)) + (setf (key-fn instance) (compile nil key-form))))) + +(defmethod get-value (key (ht btree-index)) + "Get the value in the primary DB from a secondary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-indices-assoc *store-controller*) + key-buf value-buf))) + (if buf (values (deserialize buf) T) + (values nil nil))))) + +(defmethod (setf get-value) (value key (ht btree-index)) + "Puts are not allowed on secondary indices. Try adding to +the primary." + (declare (ignore value key ht)) + (error "Puts are forbidden on secondary indices. Try adding to the primary.")) + +(defgeneric get-primary-key (key ht)) + +(defmethod get-primary-key (key (ht btree-index)) + "Get the primary key from a secondary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid ht) key-buf) + (serialize key key-buf) + (let ((buf (db-get-key-buffered + (controller-indices *store-controller*) + key-buf value-buf))) + (if buf + (let ((oid (buffer-read-fixnum buf))) + (values (deserialize buf) oid)) + (values nil nil))))) + +(defmethod remove-kv (key (ht btree-index)) + "Remove a key / value, updating ALL secondary indices." + (declare (optimize (speed 3))) + (remove-kv (get-primary-key key ht) (primary ht))) + + +;; Cursor operations + +(defclass cursor () + ((handle :accessor cursor-handle :initarg :handle) + (oid :accessor cursor-oid :type fixnum :initarg :oid) + (initialized-p :accessor cursor-initialized-p + :type boolean :initform nil :initarg :initialized-p) + (btree :accessor cursor-btree :initarg :btree)) + (:documentation "A cursor for traversing (primary) BTrees.")) + +(defgeneric make-cursor (ht)) +(defgeneric cursor-close (cursor)) +(defgeneric cursor-duplicate (cursor)) +(defgeneric cursor-current (cursor)) +(defgeneric cursor-first (cursor)) +(defgeneric cursor-last (cursor)) +(defgeneric cursor-next (cursor)) +(defgeneric cursor-prev (cursor)) +(defgeneric cursor-set (cursor key)) +(defgeneric cursor-set-range (cursor key)) +(defgeneric cursor-get-both (cursor key value)) +(defgeneric cursor-get-both-range (cursor key value)) +(defgeneric cursor-delete (cursor)) +(defgeneric cursor-put (cursor value &key key)) + +(defmethod make-cursor ((ht btree)) + "Construct a cursor for traversing primary BTrees." + (declare (optimize (speed 3))) + (make-instance 'cursor + :btree ht + :handle (db-cursor (controller-btrees *store-controller*)) + :oid (oid ht))) + +(defmacro with-btree-cursor ((var ht) &body body) + "Macro which opens a named cursor on a BTree (primary or +not), evaluates the forms, then closes the cursor." + `(let ((,var (make-cursor ,ht))) + (unwind-protect + (progn ,@body) + (cursor-close ,var)))) + +(defun map-btree (fn bt) + "Like maphash." + (with-btree-cursor (curs bt) + (loop + (multiple-value-bind (more k v) (cursor-next curs) + (unless more (return nil)) + (funcall fn k v))))) + +(defmethod cursor-close ((cursor cursor)) + "Close the cursor. Make sure to close cursors before the +enclosing transaction is closed!" + (declare (optimize (speed 3))) + (db-cursor-close (cursor-handle cursor)) + (setf (cursor-initialized-p cursor) nil)) + +(defmethod cursor-duplicate ((cursor cursor)) + "Duplicate a cursor." + (declare (optimize (speed 3))) + (make-instance (type-of cursor) + :initialized-p (cursor-initialized-p cursor) + :oid (cursor-oid cursor) + :handle (db-cursor-duplicate + (cursor-handle cursor) + :position (cursor-initialized-p cursor)))) + +(defmethod cursor-current ((cursor cursor)) + "Get the key / value at the cursor position. Returns +has-pair key value, where has-pair is a boolean indicating +there was a pair." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-first ((cursor cursor)) + "Move the cursor to the beginning of the BTree, returning +has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (multiple-value-bind (key val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +;;A bit of a hack..... +(defmethod cursor-last ((cursor cursor)) + "Move the cursor to the end of the BTree, returning +has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (if (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (progn (reset-buffer-stream key-buf) + (reset-buffer-stream value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf + value-buf :last t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-next ((cursor cursor)) + "Advance the cursor, returning has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-first cursor))) + +(defmethod cursor-prev ((cursor cursor)) + "Move the cursor back, returning has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-last cursor))) + +(defmethod cursor-set ((cursor cursor) key) + "Move the cursor to a particular key, returning has-pair +key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-set-range ((cursor cursor) key) + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k val) + (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (if (and k (= (buffer-read-int k) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize k) (deserialize val))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-get-both ((cursor cursor) key value) + "Moves the cursor to a particular key / value pair, +returning has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (multiple-value-bind (k v) + (db-cursor-get-both-buffered (cursor-handle cursor) + key-buf value-buf :get-both t) + (declare (ignore v)) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key value)) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-get-both-range ((cursor cursor) key value) + "Moves the cursor to the first key / value pair with key +equal to the key argument and value greater or equal to the +value argument. Not really useful for us since primaries +don't have duplicates. Returns has-pair key value." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (serialize value value-buf) + (multiple-value-bind (k v) + (db-cursor-get-both-buffered (cursor-handle cursor) + key-buf value-buf :get-both-range t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize v))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-delete ((cursor cursor)) + "Delete by cursor. The cursor is at an invalid position +after a successful delete." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (declare (ignore val)) + (when (and key (= (buffer-read-int key) (cursor-oid cursor))) + ;; in case of a secondary index this should delete everything + ;; as specified by the BDB docs. + (remove-kv (deserialize key) (cursor-btree cursor))) + (setf (cursor-initialized-p cursor) nil))) + (error "Can't delete with uninitialized cursor!"))) + +(defmethod cursor-put ((cursor cursor) value &key (key nil key-specified-p)) + "Put by cursor. Not particularly useful since primaries +don't support duplicates. Currently doesn't properly move +the cursor." + (declare (optimize (speed 3))) + (if key-specified-p + (setf (get-value key (cursor-btree cursor)) value) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (k v) + (db-cursor-move-buffered (cursor-handle cursor) key-buf + value-buf :current t) + (declare (ignore v)) + (if (and k (= (buffer-read-int k) (cursor-oid cursor))) + (setf (get-value (deserialize k) (cursor-btree cursor)) + value) + (setf (cursor-initialized-p cursor) nil)))) + (error "Can't put with uninitialized cursor!")))) + +;; Secondary cursors + +(defclass secondary-cursor (cursor) () + (:documentation "Cursor for traversing secondary indices.")) + +(defgeneric cursor-pcurrent (cursor)) +(defgeneric cursor-pfirst (cursor)) +(defgeneric cursor-plast (cursor)) +(defgeneric cursor-pnext (cursor)) +(defgeneric cursor-pprev (cursor)) +(defgeneric cursor-pset (cursor key)) +(defgeneric cursor-pset-range (cursor key)) +(defgeneric cursor-pget-both (cursor key value)) +(defgeneric cursor-pget-both-range (cursor key value)) +(defgeneric cursor-next-dup (cursor)) +(defgeneric cursor-next-nodup (cursor)) +(defgeneric cursor-prev-nodup (cursor)) +(defgeneric cursor-pnext-dup (cursor)) +(defgeneric cursor-pnext-nodup (cursor)) +(defgeneric cursor-pprev-nodup (cursor)) + +(defmethod make-cursor ((ht btree-index)) + "Make a secondary-cursor from a secondary index." + (declare (optimize (speed 3))) + (make-instance 'secondary-cursor + :btree ht + :handle (db-cursor + (controller-indices-assoc *store-controller*)) + :oid (oid ht))) + +(defmethod cursor-pcurrent ((cursor secondary-cursor)) + "Returns has-tuple / secondary key / value / primary key +at the current position." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pfirst ((cursor secondary-cursor)) + "Moves the key to the beginning of the secondary index. +Returns has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :set-range t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil))))) + +;;A bit of a hack..... +(defmethod cursor-plast ((cursor secondary-cursor)) + "Moves the key to the end of the secondary index. Returns +has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (if (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) + (progn (reset-buffer-stream key-buf) + (reset-buffer-stream value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) + (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :last t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pnext ((cursor secondary-cursor)) + "Advances the cursor. Returns has-tuple / secondary key / +value / primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :next t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-pfirst cursor))) + +(defmethod cursor-pprev ((cursor secondary-cursor)) + "Moves the cursor back. Returns has-tuple / secondary key +/ value / primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-plast cursor))) + +(defmethod cursor-pset ((cursor secondary-cursor) key) + "Moves the cursor to a particular key. Returns has-tuple +/ secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :set t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-pset-range ((cursor secondary-cursor) key) + "Move the cursor to the first key-value pair with key +greater or equal to the key argument, according to the lisp +sorter. Returns has-pair secondary key value primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (multiple-value-bind (k pkey val) + (db-cursor-pset-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :set-range t) + (if (and k (= (buffer-read-int k) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize k) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey)))) + (setf (cursor-initialized-p cursor) nil))))) + +(defmethod cursor-pget-both ((cursor secondary-cursor) key pkey) + "Moves the cursor to a particular secondary key / primary +key pair. Returns has-tuple / secondary key / value / +primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (let ((primary-oid (oid (primary (cursor-btree cursor))))) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (buffer-write-int primary-oid pkey-buf) + (serialize pkey pkey-buf) + (multiple-value-bind (k p val) + (db-cursor-pget-both-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :get-both t) + (declare (ignore p)) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val) pkey)) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pget-both-range ((cursor secondary-cursor) key pkey) + "Moves the cursor to a the first secondary key / primary +key pair, with secondary key equal to the key argument, and +primary key greater or equal to the pkey argument. Returns +has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (with-buffer-streams (key-buf pkey-buf value-buf) + (let ((primary-oid (oid (primary (cursor-btree cursor))))) + (buffer-write-int (cursor-oid cursor) key-buf) + (serialize key key-buf) + (buffer-write-int primary-oid pkey-buf) + (serialize pkey pkey-buf) + (multiple-value-bind (k p val) + (db-cursor-pget-both-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :get-both-range t) + (if k + (progn (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val) + (progn (buffer-read-int p) (deserialize p)))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-delete ((cursor secondary-cursor)) + "Delete by cursor: deletes ALL secondary indices." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf + value-buf :current t) + (declare (ignore val)) + (when (and key (= (buffer-read-int key) (cursor-oid cursor)) + (= (buffer-read-int pkey) (oid (primary + (cursor-btree cursor))))) + (remove-kv (deserialize pkey) (primary (cursor-btree cursor)))) + (setf (cursor-initialized-p cursor) nil))) + (error "Can't delete with uninitialized cursor!"))) + +(defmethod cursor-get-both ((cursor secondary-cursor) key value) + "cursor-get-both not implemented for secondary indices. +Use cursor-pget-both." + (declare (ignore cursor key value)) + (error "cursor-get-both not implemented on secondary +indices. Use cursor-pget-both.")) + +(defmethod cursor-get-both-range ((cursor secondary-cursor) key value) + "cursor-get-both-range not implemented for secondary indices. +Use cursor-pget-both-range." + (declare (ignore cursor key value)) + (error "cursor-get-both-range not implemented on secondary indices. Use cursor-pget-both-range.")) + +(defmethod cursor-put ((cursor secondary-cursor) value &rest rest) + "Puts are forbidden on secondary indices. Try adding to +the primary." + (declare (ignore rest value cursor)) + (error "Puts are forbidden on secondary indices. Try adding to the primary.")) + +(defmethod cursor-next-dup ((cursor secondary-cursor)) + "Move to the next duplicate element (with the same key.) +Returns has-pair key value." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next-dup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-next-nodup ((cursor secondary-cursor)) + "Move to the next non-duplicate element (with different +key.) Returns has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-first cursor))) + +(defmethod cursor-prev-nodup ((cursor secondary-cursor)) + "Move to the previous non-duplicate element (with +different key.) Returns has-pair key value." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val)) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-last cursor))) + +(defmethod cursor-pnext-dup ((cursor secondary-cursor)) + "Move to the next duplicate element (with the same key.) +Returns has-tuple / secondary key / value / primary key." + (declare (optimize (speed 3))) + (when (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) + key-buf pkey-buf value-buf :next-dup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))))) + +(defmethod cursor-pnext-nodup ((cursor secondary-cursor)) + "Move to the next non-duplicate element (with different +key.) Returns has-tuple / secondary key / value / primary +key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :next-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-pfirst cursor))) + +(defmethod cursor-pprev-nodup ((cursor secondary-cursor)) + "Move to the previous non-duplicate element (with +different key.) Returns has-tuple / secondary key / value / +primary key." + (declare (optimize (speed 3))) + (if (cursor-initialized-p cursor) + (with-buffer-streams (key-buf pkey-buf value-buf) + (multiple-value-bind (key pkey val) + (db-cursor-pmove-buffered (cursor-handle cursor) key-buf + pkey-buf value-buf :prev-nodup t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key) (deserialize val) + (progn (buffer-read-int pkey) (deserialize pkey))) + (setf (cursor-initialized-p cursor) nil)))) + (cursor-plast cursor))) +

1 0

[elephant-cvs] CVS update: elephant/src/classes.lisp
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv24835/src Modified Files: classes.lisp Log Message: doc-strings slot-makunbound-using-class init transients after persistents Date: Thu Sep 16 06:14:04 2004 Author: blee Index: elephant/src/classes.lisp diff -u elephant/src/classes.lisp:1.9 elephant/src/classes.lisp:1.10 --- elephant/src/classes.lisp:1.9 Sat Sep 4 10:16:11 2004 +++ elephant/src/classes.lisp Thu Sep 16 06:14:04 2004 @@ -46,8 +46,8 @@ (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid) - (declare (ignore initargs)) "Sets the OID." + (declare (ignore initargs)) (if (not from-oid) (setf (oid instance) (next-oid *store-controller*)) (setf (oid instance) from-oid)) @@ -56,27 +56,12 @@ (defclass persistent-object (persistent) ((%persistent-slots :transient t)) (:documentation "Superclass of all user-defined persistent -classes") +classes. To make some slots not persisted, use the +:transient flag.") (:metaclass persistent-metaclass)) -#| -(defmethod compute-class-precedence-list :around ((class persistent-metaclass)) - (let ((cpl (call-next-method)) - (persistent-object (find-class 'persistent-object))) - (if (member persistent-object cpl :test #'eq) - cpl - (let ((std-obj (find-class 'standard-object)) - (ccpl (copy-list cpl))) - (loop for c on ccpl - when (eq (cadr c) std-obj) - do - (setf (cdr c) (cons persistent-object - (cons (find-class 'persistent) (cdr c)))) - (return nil)) - ccpl)))) -|# - (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)) (persistent-object (find-class 'persistent-object)) (not-already-persistent (loop for superclass in direct-superclasses @@ -88,7 +73,11 @@ (call-next-method)))) (defmethod shared-initialize :around ((instance persistent-object) slot-names &rest initargs &key &allow-other-keys) - "This seems to be necessary because it is typical for implementations to optimize setting the slots via initforms and initargs in such a way that slot-value-using-class et al aren't used." + "Initializes the persistent slots via initargs or forms. +This seems to be necessary because it is typical for +implementations to optimize setting the slots via initforms +and initargs in such a way that slot-value-using-class et al +aren't used. Calls the next method for the transient slots." (let* ((class (class-of instance)) (persistent-slot-names (persistent-slot-names class))) (flet ((persistent-slot-p (item) @@ -100,8 +89,6 @@ (persistent-slot-inits (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) - ;; let the implementation initialize the transient slots - (apply #'call-next-method instance transient-slot-inits initargs) ;; initialize the persistent slots (flet ((initialize-from-initarg (slot-def) (loop for initarg in initargs @@ -119,31 +106,41 @@ (let ((initfun (slot-definition-initfunction slot-def))) (when initfun (setf (slot-value-using-class class instance slot-def) - (funcall initfun)))))))))) + (funcall initfun)))))) + ;; let the implementation initialize the transient slots + (apply #'call-next-method instance transient-slot-inits initargs))))) (defmethod slot-value-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Get the slot value from the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader instance name))) (defmethod (setf slot-value-using-class) :around (new-value class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Set the slot value in the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-writer new-value instance name))) (defmethod slot-boundp-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) + "Checks if the slot exists in the database." + (declare (optimize (speed 3)) + (ignore class)) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp instance name))) (defmethod slot-makunbound-using-class :around (class (instance persistent-object) (slot-def persistent-slot-definition)) - (declare (ignore class)) - (buffer-write-int (oid instance) *key-buf*) - (let ((key-length (serialize (slot-definition-name slot-def) *key-buf*))) + "Deletes the slot from the database." + (declare (optimize (speed 3)) + (ignore class)) + (with-buffer-streams (key-buf) + (buffer-write-int (oid instance) key-buf) + (serialize (slot-definition-name slot-def) key-buf) (db-delete-buffered - (controller-db *store-controller*) - (buffer-stream-buffer *key-buf*) - key-length + (controller-db *store-controller*) key-buf :transaction *current-transaction* - :auto-commit *auto-commit*))) + :auto-commit *auto-commit*)) + instance)

1 0

[elephant-cvs] CVS update: elephant/elephant.asd
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24808 Modified Files: elephant.asd Log Message: berkeley-db license description Date: Thu Sep 16 06:12:41 2004 Author: blee Index: elephant/elephant.asd diff -u elephant/elephant.asd:1.5 elephant/elephant.asd:1.6 --- elephant/elephant.asd:1.5 Sat Sep 4 10:13:14 2004 +++ elephant/elephant.asd Thu Sep 16 06:12:41 2004 @@ -45,14 +45,15 @@ :author "Ben Lee <blee(a)common-lisp.net>" :version "0.1" :maintainer "Ben Lee <blee(a)common-lisp.net>" - :licence "Lessor Lisp General Public License" + :licence "GPL" :description "Object database for Common Lisp" - :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, Lispworks, and Allegro." + :long-description "An object-oriented database based on Berkeley DB, for CMUCL/SBCL, OpenMCL, and Allegro." :components ((:module :src :components ((:file "sleepycat") + (:file "berkeley-db") (:file "elephant") (:file "utils") (:file "metaclasses")

1 0

[elephant-cvs] CVS update: elephant/elephant-tests.asd
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24776 Modified Files: elephant-tests.asd Log Message: testcollections Date: Thu Sep 16 06:11:42 2004 Author: blee Index: elephant/elephant-tests.asd diff -u elephant/elephant-tests.asd:1.1 elephant/elephant-tests.asd:1.2 --- elephant/elephant-tests.asd:1.1 Sat Sep 4 10:12:59 2004 +++ elephant/elephant-tests.asd Thu Sep 16 06:11:42 2004 @@ -56,6 +56,7 @@ ((:file "elephant-tests") (:file "testserializer") (:file "mop-tests") + (:file "testcollections") ;(:file "testsleepycat") ) :serial t)))

1 0

[elephant-cvs] CVS update: elephant/TODO
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24749 Modified Files: TODO Log Message: updates Date: Thu Sep 16 06:11:21 2004 Author: blee Index: elephant/TODO diff -u elephant/TODO:1.4 elephant/TODO:1.5 --- elephant/TODO:1.4 Sat Sep 4 10:12:18 2004 +++ elephant/TODO Thu Sep 16 06:11:21 2004 @@ -5,11 +5,26 @@ understand the profiler / timer, tweak performance of CLOS stuff -tweak performance of transactions! +tweak performance of transactions! dynamic-extent in CMUCL +/ SBCL. more documentation: reference! -secondary index generation, cursors +secondary index generation, cursors: + +- secondary indices on the "lisp" side : minor / nil +performance gains and DB handle badness for DB->associate + +- create 2 DBs per sorting function: primary and secondary, +without and with duplicates. + +- in addition to the usual lexicographic sorter, create a +"lisp" version -- sorts primitive types (numbers, strings, +symbols.) use http://oss.software.ibm.com/icu/ for 16-bit +unicode. + +- equality joins have to be done on the lisp side: +end-of-table is not the same as end-of-btree. GC (need cursors) @@ -19,9 +34,9 @@ that ldb is non-consing (i think it is), look at %ldb-fixnum-from-bignum) -serialize lambdas, closures, packages..... +serialize lambdas, closures, packages.....this is hard! -lispy pointer arithmetic +lispy pointer arithmetic (profile sap-alien, etc) performance hacks: class / slot to ID @@ -30,3 +45,12 @@ this is not particularly a bug but: if you redefine the persistent-object class, you will mess up any existing persistent classes you've made. + +CMUCL, SBCL, Allegro? (NOT OpenMCL) can directly pass memory +like foreign arrays. Use these instead of foreign arrays? + +byte-ordering? nah..... + +incorporate requirements from ICU license + +cursor-put : move the cursor after insert. \ No newline at end of file

1 0

[elephant-cvs] CVS update: elephant/Makefile
by blee＠common-lisp.net 16 Sep '04

16 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv24722 Modified Files: Makefile Log Message: libmath, bumped version Date: Thu Sep 16 06:11:01 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.3 elephant/Makefile:1.4 --- elephant/Makefile:1.3 Sat Sep 4 11:03:37 2004 +++ elephant/Makefile Thu Sep 16 06:11:00 2004 @@ -15,7 +15,7 @@ #DBLIBDIR=/usr/local/lib/db42 #DBINCDIR=/usr/local/include/db42 -INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/ +INSTALLDIR=/usr/local/share/common-lisp/elephant-0.2/ ifeq (Darwin,$(UNAME)) SHARED=-bundle @@ -24,7 +24,7 @@ endif libsleepycat.so: src/libsleepycat.c - gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb + gcc $(SHARED) -L$(DBLIBDIR) -I$(DBINCDIR) -fPIC -O3 -o $@ $< -ldb -lm install: libsleepycat.so install $< $(INSTALLDIR)

1 0

[elephant-cvs] CVS update: elephant/tests/elephant-tests.lisp elephant/tests/mop-tests.lisp elephant/tests/testserializer.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/tests In directory common-lisp.net:/tmp/cvs-serv27360/tests Modified Files: elephant-tests.lisp mop-tests.lisp testserializer.lisp Log Message: fixed imports Date: Sat Sep 4 11:16:11 2004 Author: blee Index: elephant/tests/elephant-tests.lisp diff -u elephant/tests/elephant-tests.lisp:1.1 elephant/tests/elephant-tests.lisp:1.2 --- elephant/tests/elephant-tests.lisp:1.1 Sat Sep 4 10:24:30 2004 +++ elephant/tests/elephant-tests.lisp Sat Sep 4 11:16:11 2004 @@ -43,24 +43,34 @@ (defpackage elephant-tests (:nicknames ele-tests :ele-tests) (:use common-lisp elephant rt) + (:import-from :ele + *out-buf* + serialize + deserialize + buffer-stream-buffer) #+cmu (:import-from :pcl + finalize-inheritance slot-definition-name class-slots) #+sbcl (:import-from :sb-mop + finalize-inheritance slot-definition-name class-slots) #+allegro (:import-from :clos + finalize-inheritance slot-definition-name class-slots) #+openmcl (:import-from :ccl + finalize-inheritance slot-definition-name class-slots) #+lispworks (:import-from :clos + finalize-inheritance slot-definition-name class-slots) ) Index: elephant/tests/mop-tests.lisp diff -u elephant/tests/mop-tests.lisp:1.3 elephant/tests/mop-tests.lisp:1.4 --- elephant/tests/mop-tests.lisp:1.3 Sat Sep 4 10:24:23 2004 +++ elephant/tests/mop-tests.lisp Sat Sep 4 11:16:11 2004 @@ -1,12 +1,4 @@ (in-package :ele-tests) -#+cmu -(import 'pcl::finalize-inheritance) -#+sbcl -(import 'sb-mop::finalize-inheritance) -#+allegro -(import 'clos::finalize-inheritance) -#+openmcl -(import 'ccl::finalize-inheritance) (deftest non-transient-class-slot-1 (signals-condition Index: elephant/tests/testserializer.lisp diff -u elephant/tests/testserializer.lisp:1.3 elephant/tests/testserializer.lisp:1.4 --- elephant/tests/testserializer.lisp:1.3 Sat Sep 4 10:25:07 2004 +++ elephant/tests/testserializer.lisp Sat Sep 4 11:16:11 2004 @@ -1,8 +1,4 @@ (in-package :ele-tests) -(import 'ele::*out-buf*) -(import 'ele::serialize) -(import 'ele::deserialize) -(import 'ele::buffer-stream-buffer) (defun in-out-value (var) (serialize var *out-buf*)

1 0

[elephant-cvs] CVS update: elephant/Makefile
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant In directory common-lisp.net:/tmp/cvs-serv22981 Modified Files: Makefile Log Message: back to Linux default Date: Sat Sep 4 11:03:38 2004 Author: blee Index: elephant/Makefile diff -u elephant/Makefile:1.2 elephant/Makefile:1.3 --- elephant/Makefile:1.2 Thu Sep 2 09:03:51 2004 +++ elephant/Makefile Sat Sep 4 11:03:37 2004 @@ -7,13 +7,13 @@ SHELL=/bin/sh UNAME:=$(shell uname -s) -# *BSD users will probably want -DBLIBDIR=/usr/local/lib/db42 -DBINCDIR=/usr/local/include/db42 +DB42DIR=/usr/local/BerkeleyDB.4.2 +DBLIBDIR=$(DB42DIR)/lib/ +DBINCDIR=$(DB42DIR)/include/ -#DB42DIR=/usr/local/BerkeleyDB.4.2 -#DBLIBDIR=$(DB42DIR)/lib/ -#DBINCDIR=$(DB42DIR)/include/ +# *BSD users will probably want +#DBLIBDIR=/usr/local/lib/db42 +#DBINCDIR=/usr/local/include/db42 INSTALLDIR=/usr/local/share/common-lisp/elephant-0.1/

1 0

[elephant-cvs] CVS update: elephant/src/serializer.lisp
by blee＠common-lisp.net 04 Sep '04

04 Sep '04

Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv22085/src Modified Files: serializer.lisp Log Message: really fixed the array types (hopefully!) Date: Sat Sep 4 10:59:40 2004 Author: blee Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.7 elephant/src/serializer.lisp:1.8 --- elephant/src/serializer.lisp:1.7 Sat Sep 4 10:20:37 2004 +++ elephant/src/serializer.lisp Sat Sep 4 10:59:40 2004 @@ -355,19 +355,23 @@ (setf (gethash '(complex double-float) array-type-to-byte) #x06) (setf (gethash 'fixnum array-type-to-byte) #x07) (setf (gethash 'bit array-type-to-byte) #x08) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + (let ((counter 8)) (loop for i from 2 to 65 for spec = (list 'unsigned-byte i) for uspec = (upgraded-array-element-type spec) - unless (gethash uspec array-type-to-byte) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter))) + (setf (gethash spec array-type-to-byte) (incf counter))) (loop for i from 2 to 65 for spec = (list 'signed-byte i) for uspec = (upgraded-array-element-type spec) - unless (gethash uspec array-type-to-byte) + when (type= spec uspec) do - (setf (gethash uspec array-type-to-byte) (incf counter)))) + (setf (gethash spec array-type-to-byte) (incf counter)))) (loop for key being the hash-key of array-type-to-byte using (hash-value value)

1 0