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

[elephant-cvs] CVS elephant/tests
by ieslick 02 Feb '07

02 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv3271/tests Modified Files: testbdb.lisp Log Message: Large changeset to enable thread safety; more *auto-commit* removal; sql class-root fix; new transaction model; cleaned up defaults for *store-controller* --- /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2006/11/11 22:53:13 1.2 +++ /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/02 23:52:00 1.3 @@ -30,7 +30,7 @@ (deftest prepares-bdb (progn (setq db nil) - (if (and (find-package :db-bdb) + (if (and (find-package :db-bdb) (eq (first (elephant::controller-spec *store-controller*)) :BDB)) (finishes (prepare-bdb)) @@ -72,12 +72,12 @@ (db-bdb::db-sequence-initial-value seq (- most-positive-fixnum 99)) (db-bdb::db-sequence-open seq "testseq1" :auto-commit t :create t :thread t) - (loop for i = (db-bdb::db-sequence-get-fixnum seq 1 :auto-commit t :txn-nosync t) + (loop for i = (db-bdb::db-sequence-get-fixnum seq 1 :txn-nosync t) for j from (- most-positive-fixnum 99) to most-positive-fixnum while (> i 0) do (assert (= i j)) - finally (db-bdb::db-sequence-remove seq :auto-commit t)))) + finally (db-bdb::db-sequence-remove seq)))) (deftest test-seq1 (if (not db) @@ -93,14 +93,13 @@ (db-bdb::db-sequence-set-flags seq :seq-dec t :seq-wrap t) (db-bdb::db-sequence-set-range seq most-negative-fixnum 0) (db-bdb::db-sequence-initial-value seq (+ most-negative-fixnum 99)) - (db-bdb::db-sequence-open seq "testseq2" - :auto-commit t :create t :thread t) - (loop for i = (db-bdb::db-sequence-get-fixnum seq 1 :auto-commit t :txn-nosync t) + (db-bdb::db-sequence-open seq "testseq2" :create t :thread t) + (loop for i = (db-bdb::db-sequence-get-fixnum seq 1 :txn-nosync t) for j from (+ most-negative-fixnum 99) downto most-negative-fixnum while (< i 0) do (assert (= i j)) - finally (db-bdb::db-sequence-remove seq :auto-commit t)))) + finally (db-bdb::db-sequence-remove seq)))) (deftest test-seq2 (if (not db)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 02 Feb '07

02 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv3271/src/elephant Modified Files: backend.lisp classes.lisp classindex-utils.lisp classindex.lisp collections.lisp controller.lisp package.lisp serializer.lisp serializer2.lisp transactions.lisp unicode2.lisp variables.lisp Log Message: Large changeset to enable thread safety; more *auto-commit* removal; sql class-root fix; new transaction model; cleaned up defaults for *store-controller* --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/01/26 14:41:13 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/02 23:51:58 1.8 @@ -67,9 +67,7 @@ #:cursor-oid #:cursor-initialized-p ;; Transactions - #:*transaction-stack* #:*current-transaction* - #:*auto-commit* #:execute-transaction #:controller-start-transaction #:controller-commit-transaction --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2006/04/26 17:53:44 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/02 23:51:58 1.10 @@ -166,7 +166,7 @@ (setf (slot-value-using-class class instance slot-def) (getf initargs initarg)) (return t)))) - (with-transaction (:store-controller (get-con instance)) + (ensure-transaction (:store-controller (get-con instance)) (loop for slot-def in (class-slots class) unless (initialize-from-initarg slot-def) when (member (slot-definition-name slot-def) persistent-slot-inits :test #'eq) @@ -214,7 +214,7 @@ ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) - (with-transaction (:store-controller (get-con current)) + (ensure-transaction (:store-controller (get-con current)) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) do (setf (slot-value-using-class new-class --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2006/04/26 17:53:44 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/02 23:51:58 1.4 @@ -346,6 +346,7 @@ (dump-class-index class) (map-btree #'(lambda (k v) + (declare (ignore v)) (dump-class-index k) ) bt)) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/07/21 16:32:45 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/02 23:51:58 1.15 @@ -74,8 +74,7 @@ (if (no-indexing-needed? class instance slot-def oid) (with-transaction (:store-controller con) (persistent-slot-writer con new-value instance slot-name)) - (let ((class-idx (find-class-index class)) - (*auto-commit* nil)) + (let ((class-idx (find-class-index class))) ;; (format t "Indexing object: ~A oid: ~A~%" instance oid) (with-transaction (:store-controller con) ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/01/31 20:05:38 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/02 23:51:58 1.7 @@ -325,14 +325,15 @@ (defmethod map-btree (fn (btree btree)) "Like maphash. Default implementation - overridable" - (with-btree-cursor (curs btree) - (loop - (multiple-value-bind (more k v) (cursor-next curs) - (unless more (return nil)) - (funcall fn k v))))) + (ensure-transaction (:store-controller (get-con btree)) + (with-btree-cursor (curs btree) + (loop + (multiple-value-bind (more k v) (cursor-next curs) + (unless more (return nil)) + (funcall fn k v)))))) (defmethod empty-btree-p ((btree btree)) - (with-transaction (:store-controller (get-con btree)) + (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (cur btree) (multiple-value-bind (valid k) (cursor-next cur) (cond ((not valid) ;; truly empty --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/31 20:05:38 1.26 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/02 23:51:58 1.27 @@ -20,7 +20,7 @@ (in-package "ELEPHANT") ;; -;; TRACKING THE OBJECT STORE +;; TRACKING OBJECT STORES ;; (defparameter *elephant-backends* @@ -39,6 +39,7 @@ (gethash name *elephant-controller-init*)) (defvar *dbconnection-spec* (make-hash-table :test 'equal)) +(defvar *dbconnection-lock* (ele-make-lock)) (defmethod get-con ((instance persistent) &optional (sc *store-controller*)) "This is used to find and validate the connection spec @@ -77,7 +78,8 @@ (let ((init (lookup-backend-con-init (first spec)))) (unless init (error "Store controller init function not registered for backend ~A." (car spec))) (let ((sc (funcall (symbol-function init) spec))) - (setf (gethash spec *dbconnection-spec*) sc) + (ele-with-lock (*dbconnection-lock*) + (setf (gethash spec *dbconnection-spec*) sc)) sc))) @@ -108,21 +110,25 @@ ;; (defun open-store (spec &rest args) - "Conveniently open a store controller." + "Conveniently open a store controller. Set *store-controller* to the new controller + unless it is already set (opening a second controller means you must keep track of + controllers yourself. *store-controller* is a convenience variable for single-store + applications" (assert (consp spec)) - (setq *store-controller* (get-controller spec)) - (load-user-configuration *store-controller*) - (apply #'open-controller *store-controller* args) - (initialize-serializer *store-controller*) - ) + (let ((controller (get-controller spec))) + (unless *store-controller* + (setq *store-controller* controller)) + (load-user-configuration controller) + (apply #'open-controller controller args) + (initialize-serializer controller) + controller)) (defun close-store (&optional sc) "Conveniently close the store controller." - (declare (special *store-controller*)) - (if (or sc *store-controller*) - (progn - (close-controller (or sc *store-controller*)) - (setf *store-controller* nil)))) + (when (or sc *store-controller*) + (close-controller (or sc *store-controller*))) + (unless sc + (setf *store-controller* nil))) (defmacro with-open-store ((spec) &body body) "Executes the body with an open controller, @@ -144,13 +150,15 @@ :initarg :spec :documentation "Backend create functions should pass in :spec during make-instance") ;; Generic support for the object, indexing and root protocols - (instance-cache :accessor instance-cache :initform (make-cache-table :test 'eql) - :documentation "This is an instance cache and part of the metaclass - protocol. Backends should not override") (root :reader controller-root :documentation "This should be a persistent btree instantiated by the backend") (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") + (instance-cache :accessor instance-cache :initform (make-cache-table :test 'eql) + :documentation "This is an instance cache and part of the metaclass + protocol. Backends should not override") + (instance-cache-lock :accessor instance-cache-lock :initform (ele-make-lock) + :documentation "Protection for updates to the cache from multiple threads") ;; Upgradable serializer strategy (database-version :accessor controller-version-cached :initform nil) (serializer-version :accessor controller-serializer-version :initform nil) @@ -166,6 +174,7 @@ (defun load-user-configuration (controller) ;; Placeholder + (declare (ignorable controller)) nil) (defun initialize-serializer (sc) @@ -199,7 +208,8 @@ (defun cache-instance (sc obj) "Cache a persistent object with the controller." (declare (type store-controller sc)) - (setf (get-cache (oid obj) (instance-cache sc)) obj)) + (ele-with-lock ((instance-cache-lock sc)) + (setf (get-cache (oid obj) (instance-cache sc)) obj))) (defun get-cached-instance (sc oid class-name) "Get a cached instance, or instantiate!" @@ -215,8 +225,9 @@ "Reset the instance cache (flush object lookups). Useful for testing. Does not reclaim existing objects so there will be duplicate instances with identical functionality" - (setf (instance-cache sc) - (make-cache-table :test 'eql))) + (ele-with-lock ((instance-cache-lock sc)) + (setf (instance-cache sc) + (make-cache-table :test 'eql)))) (defparameter *legacy-conversions-db* '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/22 23:11:08 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/02 23:51:58 1.9 @@ -25,8 +25,9 @@ (:documentation "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") - (:export #:*store-controller* #:*current-transaction* #:*auto-commit* - #:*elephant-lib-path* #:*elephant-code-version* #:*fast-symbols* + (:export #:*store-controller* #:*current-transaction* + #:*elephant-lib-path* #:*elephant-code-version* + #:with-elephant-variables #:store-controller #:controller-root #:controller-class-root #:controller-version #:controller-serializer-version @@ -38,7 +39,7 @@ #:controller-fast-symbols-p #:optimize-storage - #:with-transaction + #:with-transaction #:ensure-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/02 22:39:23 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/02 23:51:58 1.20 @@ -170,6 +170,8 @@ (the (unsigned-byte 8) (gethash ty array-type-to-byte))) (defun int-byte-spec (position) + "Shared byte-spec peformance hack; not thread safe so removed + from use for serializer2" (declare (optimize (speed 3) (safety 0)) (type (unsigned-byte 24) position)) #+(or cmu sbcl allegro) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/01 15:19:50 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/02 23:51:58 1.10 @@ -36,8 +36,7 @@ (eval-when (compile) (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) - (inline int-byte-spec - serialize deserialize + (inline serialize deserialize slots-and-values deserialize-bignum))) @@ -310,8 +309,11 @@ (type buffer-stream bs)) (let* ((num (abs frob)) (word-size (ceiling (/ (integer-length num) 32))) - (needed (* word-size 4))) - (declare (type fixnum word-size needed)) + (needed (* word-size 4)) + (byte-spec (byte 32 0))) + (declare (type fixnum word-size needed) + (type cons byte-spec) + (ignorable byte-spec)) (if (< frob 0) (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) @@ -321,10 +323,11 @@ ;; there is an OpenMCL function which should work ;; and non-cons do - #+(or cmu sbcl) - (buffer-write-uint (ldb (int-byte-spec i) num) bs) ;; (%bignum-ref num i) bs) - #+(or allegro lispworks openmcl) - (buffer-write-uint (ldb (int-byte-spec i) num) bs)))) + #+(or cmu sbcl allegro) + (progn (setf (cdr byte-spec) (* 32 i)) + (buffer-write-uint (ldb byte-spec num) bs)) ;; (%bignum-ref num i) bs) + #+(or lispworks openmcl) + (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs)))) ;;; ;;; DESERIALIZER @@ -480,9 +483,15 @@ (declare (type buffer-stream bs) (type fixnum length) (type boolean positive)) - (loop for i from 0 below (/ length 4) - for byte-spec = (int-byte-spec i) - with num integer = 0 - do - (setq num (dpb (buffer-read-uint bs) byte-spec num)) - finally (return (if positive num (- num))))) \ No newline at end of file + (let ((int-byte-spec (byte 32 0))) + (declare (dynamic-extent int-byte-spec) + (ignorable int-byte-spec)) + (loop for i from 0 below (/ length 4) + for byte-spec = + #+(or cmu sbcl allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) + #+(or lispworks openmcl) (byte 32 (* 32 i)) + with num integer = 0 + do + (setq num (dpb (buffer-read-uint bs) byte-spec num)) + finally + (return (if positive num (- num)))))) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/12/16 19:35:10 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/02 23:51:58 1.5 @@ -24,36 +24,52 @@ "This is an interface to the backend's transaction function. The body should be executed in a dynamic environment that protects against non-local exist, provides ACID properties for DB operations within the - body and properly bind any relevant parameters.")) + body and properly binds any relevant parameters.")) -;; Good defaults for bdb elephant -(defmacro with-transaction ((&key (store-controller '*store-controller*) - transaction - environment - (parent '*current-transaction*) - degree-2 dirty-read txn-nosync - txn-nowait txn-sync - (retries 200)) - &body body) +(defmacro with-transaction ((&rest keyargs &key + (store-controller '*store-controller*) + (parent '*current-transaction*) + (retries 200) + &allow-other-keys) + &body body) "Execute a body with a transaction in place. On success, the transaction is committed. Otherwise, the transaction is aborted. If the body deadlocks, the body is re-executed in a new transaction, retrying a fixed number of iterations. - *auto-commit* is false for the body of the transaction." + If nested, the backend must support nested transactions." `(funcall #'execute-transaction ,store-controller (lambda () ,@body) - :transaction ,transaction - :environment ,environment :parent ,parent :retries ,retries - :degree-2 ,degree-2 - :dirty-read ,dirty-read - :txn-nosync ,txn-nosync - :txn-nowait ,txn-nowait - :txn-sync ,txn-sync)) + ,@(remove-keywords '(:store-controller :parent :retries) + keyargs))) + +(defmacro ensure-transaction ((&rest keyargs &key + (store-controller '*store-controller*) + (transaction '*current-transaction*) + (retries 200) + &allow-other-keys) + &body body) + "Execute the body with the existing transaction, or a new transaction if + none is currently running. This allows sequences of database actions to + be run atomically whether there is or is not an existing transaction + (rather than relying on auto-commit). with-transaction nests transactions + where as ensure-transaction can be part of an enclosing, flat transaction" + (let ((txn-fn (gensym))) + `(let ((,txn-fn (lambda () ,@body))) + (if ,transaction + (funcall ,txn-fn) + (funcall #'execute-transaction ,store-controller + ,txn-fn + :parent nil + :transaction nil + :retries ,retries + ,@(remove-keywords '(:store-controller :parent :transaction :retries) + keyargs)))))) + ;; -;; An interface to manage transactions explicitely +;; An interface to manage transactions explicitly ;; ;; Controller methods to implement @@ -61,43 +77,17 @@ (defgeneric controller-start-transaction (store-controller &key &allow-other-keys) (:documentation "Start an elephant transaction")) -(defgeneric controller-commit-transaction (store-controller &key &allow-other-keys) +(defgeneric controller-commit-transaction (store-controller transaction &key &allow-other-keys) (:documentation "Commit an elephant transaction")) -(defgeneric controller-abort-transaction (store-controller &key &allow-other-keys) +(defgeneric controller-abort-transaction (store-controller transaction &key &allow-other-keys) (:documentation "Abort an elephant transaction")) ;; -;; User Interface -;; +;; Utility +; -(defun start-ele-transaction (&key (store-controller *store-controller*) - (parent *current-transaction*) - degree-2 - dirty-read - txn-nosync - txn-nowait - txn-sync) - "Start a transaction. May be nested but not interleaved." - (vector-push-extend *current-transaction* *transaction-stack*) - (setq *current-transaction* - (controller-start-transaction store-controller - :parent parent - :degree-2 degree-2 - :dirty-read dirty-read - :txn-nosync txn-nosync - :txn-nowait txn-nowait - :txn-sync txn-sync))) - -(defun commit-transaction (&key (store-controller *store-controller*) txn-nosync txn-sync &allow-other-keys) - "Commit the current transaction." - (controller-commit-transaction store-controller - :transaction *current-transaction* - :txn-nosync txn-nosync - :txn-sync txn-sync) - (setq *current-transaction* (vector-pop *transaction-stack*))) - -(defun abort-transaction (&key (store-controller *store-controller*) &allow-other-keys) - "Abort the current transaction." - (controller-abort-transaction store-controller :transaction *current-transaction*) - (setq *current-transaction* (vector-pop *transaction-stack*))) +(defun remove-keywords (key-names args) + (loop for ( name val ) on args by #'cddr + unless (member name key-names) + append (list name val))) --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/25 18:18:00 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/02 23:51:58 1.3 @@ -23,6 +23,8 @@ (in-package :elephant-serializer2) +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0))) + ;; ;; Serialize string: simplify store by discovering utf8/utf16 and utf32; trade off ;; storage for computation time. Unicode makes fast memcpy too complicated so we'll @@ -31,8 +33,7 @@ (defun serialize-string (string bstream) "Try to write each format type and bail if code is too big" - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bstream) + (declare (type buffer-stream bstream) (type string string)) (cond ((and (not (equal "" string)) (< (char-code (char string 0)) #x7F)) (serialize-to-utf8 string bstream)) @@ -46,8 +47,7 @@ (defun serialize-to-utf8 (string bstream) "Standard serialization" - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bstream) + (declare (type buffer-stream bstream) (type string string)) (elephant-memutil::with-struct-slots ((buffer buffer-stream-buffer) (size buffer-stream-size) @@ -63,7 +63,7 @@ (succeed () (return-from serialize-to-utf8 t))) (buffer-write-byte +utf8-string+ bstream) - (buffer-write-int characters bstream) + (buffer-write-int32 characters bstream) (let ((needed (+ size characters))) (declare (type fixnum needed)) (when (> needed allocated) @@ -86,8 +86,7 @@ (defun serialize-to-utf16le (string bstream) "Serialize to utf16le compliant format unless contains code pages > 0" - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bstream) + (declare (type buffer-stream bstream) (type string string)) (elephant-memutil::with-struct-slots ((buffer buffer-stream-buffer) (size buffer-stream-size) @@ -103,7 +102,7 @@ (succeed () (return-from serialize-to-utf16le t))) (buffer-write-byte +utf16-string+ bstream) - (buffer-write-int characters bstream) + (buffer-write-int32 characters bstream) (let ((needed (+ size (* characters 2)))) (when (> needed allocated) (resize-buffer-stream bstream needed)) @@ -129,16 +128,15 @@ (defun serialize-to-utf32le (string bstream) "Serialize to utf32 compliant format unless contains code pages > 0" - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bstream) - (type string string)) + (declare (type buffer-stream bstream) + (type string string)) (elephant-memutil::with-struct-slots ((buffer buffer-stream-buffer) (size buffer-stream-size) (allocated buffer-stream-length)) bstream (let* ((characters (length string))) (buffer-write-byte +utf32-string+ bstream) - (buffer-write-int characters bstream) + (buffer-write-int32 characters bstream) (let ((needed (+ size (* 4 characters)))) (when (> needed allocated) (resize-buffer-stream bstream needed)) @@ -197,24 +195,24 @@ (defgeneric deserialize-string (type bstream &optional temp-string)) (defmethod deserialize-string ((type (eql :utf8)) bstream &optional temp-string) - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (declare (type buffer-stream bstream)) ;; Default char-code method - (let* ((length (buffer-read-int bstream)) + (let* ((length (buffer-read-int32 bstream)) (pos (elephant-memutil::buffer-stream-position bstream))) (incf (elephant-memutil::buffer-stream-position bstream) length) (progn (let ((string (or temp-string (make-string length :element-type 'character)))) (loop for i fixnum from 0 below length do - (setf (schar string i) - (code-char (uffi:deref-array (buffer-stream-buffer bstream) '(:array :unsigned-byte) (+ pos i))))) + (setf (char string i) + (code-char (uffi:deref-array (buffer-stream-buffer bstream) + '(:array :unsigned-byte) + (+ pos i))))) (the simple-string string))))) (defmethod deserialize-string ((type (eql :utf16le)) bstream &optional temp-string) "All returned strings are simple-strings for, uh, simplicity" - (declare (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) - (let* ((length (buffer-read-int bstream)) + (declare (type buffer-stream bstream)) + (let* ((length (buffer-read-int32 bstream)) (string (or temp-string (make-string length :element-type 'character))) (pos (elephant-memutil::buffer-stream-position bstream)) (code 0)) @@ -233,9 +231,10 @@ (the simple-string string))) (defmethod deserialize-string ((type (eql :utf32le)) bstream &optional temp-string) + (declare (type buffer-stream bstream)) (macrolet ((next-byte (offset) `(uffi:deref-array (buffer-stream-buffer bstream) '(:array :unsigned-byte) (+ (* i 4) pos ,offset)))) - (let* ((length (buffer-read-int bstream)) + (let* ((length (buffer-read-int32 bstream)) (string (or temp-string (make-string length :element-type 'character))) (pos (elephant-memutil::buffer-stream-position bstream)) (code 0)) --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/22 23:11:08 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/02/02 23:51:58 1.10 @@ -17,17 +17,9 @@ ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; - (in-package "ELEPHANT") -(declaim (type fixnum *lisp-obj-id*) - (type hash-table *circularity-hash*) - (type boolean *auto-commit*)) - -(defvar *cachesize* 100 - "Size of the OID sequence cache.") - -;;;;;;;;;;;;;;;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;; Versioning Support (defvar *elephant-code-version* '(0 6 1) @@ -43,12 +35,21 @@ Users attempting to directly write this variable will run into an error") -;;;;;;;;;;;;;;;;; -;;;; Serializer optimization parameters +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;;; Optimization parameters + +(defvar *cachesize* 100 + "Size of the OID sequence cache.") (defvar *circularity-initial-hash-size* 50 "This is the default size of the circularity cache used in the serializer") +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Legacy Thread-local specials + +#+(or cmu sbcl allegro) +(defvar *resourced-byte-spec* (byte 32 0) + "Byte specs on CMUCL, SBCL and Allegro are conses.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Thread-local specials @@ -56,35 +57,11 @@ (defvar *store-controller* nil "The store controller which persistent objects talk to.") -;; Specials which control persistent objects -(defvar *auto-commit* T - "Commit things not in transactions?") - -(defvar *transaction-stack* (make-array 0 :adjustable t :fill-pointer t) - "Used if the user manually creates transactions.") - -(defvar *current-transaction* +NULL-VOID+ +(defvar *current-transaction* nil "The transaction which is currently in effect.") -#+(or cmu sbcl allegro) -(defvar *resourced-byte-spec* (byte 32 0) - "Byte specs on CMUCL, SBCL and Allegro are conses.") - -;; -;; Thread-specific specials -;; - -;; NOTE: how to handle (*errno-buffer* (allocate-foreign-object :int 1)) -(defparameter *elephant-thread-local-vars* - '((*store-controller* *store-controller*) - (*current-transaction* +NULL-VOID+) - (*transaction-stack* (make-array 0 :adjustable t :fill-pointer t)) - #+(or cmu sbcl allegro) (*resourced-byte-spec* (byte 32 0)))) - -(defmacro with-elephant-variables (&body body) - `(let ,*elephant-thread-local-vars* - (declare (special ,(mapcar #'car *elephant-thread-local-vars*))) - ,@body)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Utilities ;; get rid of spot idx and adjust the arrray (defun remove-indexed-element-and-adjust (idx array)

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 02 Feb '07

02 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv3271/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp sql-transaction.lisp Log Message: Large changeset to enable thread safety; more *auto-commit* removal; sql class-root fix; new transaction model; cleaned up defaults for *store-controller* --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/01/26 14:41:08 1.8 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/02 23:51:58 1.9 @@ -133,7 +133,7 @@ (do ((i 0 (1+ i)) (tup tuples (cdr tup))) ((= i len) nil) - (setf (aref (:sql-crsr-ks cursor) i) + (setf (aref (:sql-crsr-ks cursor) i) (deserialize-from-base64-string (caar tup) sc))) (sort (:sql-crsr-ks cursor) #'my-generic-less-than) (setf (:sql-crsr-ck cursor) 0) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/01/26 14:41:08 1.13 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/02 23:51:58 1.14 @@ -356,7 +356,7 @@ (elephant::initialize-serializer sc) ;; These should get oid 0 and 1 respectively (setf (slot-value sc 'root) (make-instance 'sql-btree :sc sc :from-oid 0)) - (setf (slot-value sc 'class-root) (make-instance 'sql-indexed-btree :sc sc :from-oid 1)) + (setf (slot-value sc 'class-root) (make-instance 'sql-btree :sc sc :from-oid 1)) sc) ) ) @@ -371,6 +371,7 @@ ;; (actually clsql has pooling and other complications, I am not sure ;; that this is complete.) (clsql:disconnect :database (controller-db sc)) + (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) )) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2006/11/11 18:41:11 1.3 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2007/02/02 23:51:58 1.4 @@ -37,11 +37,14 @@ (clsql::set-autocommit t))))) (defmethod controller-start-transaction ((sc sql-store-controller) &key &allow-other-keys) - (clsql:start-transaction :database (controller-db sc))) + (clsql:start-transaction :database (controller-db sc)) + 'active-clsql-transaction) -(defmethod controller-commit-transaction ((sc sql-store-controller) &key &allow-other-keys) +(defmethod controller-commit-transaction ((sc sql-store-controller) transaction &key &allow-other-keys) + (declare (ignore transaction)) (clsql:commit :database (controller-db sc))) -(defmethod controller-abort-transaction ((sc sql-store-controller) &key &allow-other-keys) +(defmethod controller-abort-transaction ((sc sql-store-controller) transaction &key &allow-other-keys) + (declare (ignore transaction)) (clsql:rollback :database (controller-db sc)))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 02 Feb '07

02 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv3271/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp bdb-slots.lisp bdb-transactions.lisp berkeley-db.lisp Log Message: Large changeset to enable thread safety; more *auto-commit* removal; sql class-root fix; new transaction model; cleaned up defaults for *store-controller* --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/01 15:19:49 1.13 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/02 23:51:58 1.14 @@ -110,14 +110,14 @@ (defmethod build-btree-index ((sc bdb-store-controller) &key primary key-form) (make-instance 'bdb-btree-index :primary primary :key-form key-form :sc sc)) -(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form populate) +(defmethod add-index ((bt bdb-indexed-btree) &key index-name key-form (populate t)) (let ((sc (get-con bt))) ;; Setting the value of *store-controller* is unfortunately ;; absolutely required at present, I think because the copying ;; of objects is calling "make-instance" without an argument. ;; I am sure I can find a way to make this cleaner, somehow. (if (and (not (null index-name)) - (symbolp index-name) + (symbolp index-name) (or (symbolp key-form) (listp key-form))) ;; Can it be that this fails? (let ((ht (indices bt)) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/01 04:03:26 1.19 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/02 23:51:58 1.20 @@ -62,7 +62,7 @@ ;; (defmethod open-controller ((sc bdb-store-controller) &key (recover nil) - (recover-fatal nil) (thread t) (errfile nil) + (recover-fatal nil) (thread t) ;; (errfile nil) (deadlock-detect nil)) (let ((env (db-env-create))) (setf (controller-environment sc) env) @@ -158,7 +158,7 @@ "Get the next OID." (declare (type bdb-store-controller sc)) (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ - :auto-commit t :txn-nosync t)) + :txn-nosync t)) ;; ;; Automated Deadlock Support --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/01/22 22:22:35 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/02/02 23:51:58 1.2 @@ -23,8 +23,9 @@ ;; Persistent slot protocol implementation ;; +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0))) + (defmethod persistent-slot-reader ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) @@ -37,20 +38,16 @@ (error 'unbound-slot :instance instance :name name))))) (defmethod persistent-slot-writer ((sc bdb-store-controller) new-value instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) -;; (format t "psw -- sc: ~A ct: ~A ac: ~A~%" *store-controller* *current-transaction* *auto-commit*) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) (serialize new-value value-buf sc) (db-put-buffered (controller-db sc) key-buf value-buf - :transaction *current-transaction* - :auto-commit *auto-commit*) + :transaction (txn-default *current-transaction*)) new-value)) (defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) @@ -59,10 +56,8 @@ (if buf t nil)))) (defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name) -;; (declare (optimize (speed 3) (safety 1) (space 1))) (with-buffer-streams (key-buf) (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) (db-delete-buffered (controller-db sc) key-buf - :transaction *current-transaction* - :auto-commit *auto-commit*))) + :transaction (txn-default *current-transaction*)))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2006/11/11 18:41:10 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/02 23:51:58 1.5 @@ -21,11 +21,10 @@ (defmethod execute-transaction ((sc bdb-store-controller) txn-fn &key - transaction environment parent - (retries 100) degree-2 - dirty-read txn-nosync txn-nowait txn-sync) - (let ((env (if environment environment - (controller-environment sc)))) + transaction parent environment + (retries 100) + degree-2 dirty-read txn-nosync txn-nowait txn-sync) + (let ((env (if environment environment (controller-environment sc)))) (loop for count fixnum from 1 to retries for success of-type boolean = nil @@ -33,7 +32,7 @@ (let ((txn (if transaction transaction (db-transaction-begin env - :parent parent + :parent (if parent parent +NULL-VOID+) :degree-2 degree-2 :dirty-read dirty-read :txn-nosync txn-nosync @@ -42,20 +41,17 @@ (declare (type pointer-void txn) (dynamic-extent txn)) (let ((result - (let ((*current-transaction* txn) - (*auto-commit* nil)) - (declare (special *current-transaction* *auto-commit*)) -;; (dynamic-extent *current-transaction* *auto-commit*)) + (let ((*current-transaction* txn)) + (declare (special *current-transaction*)) (catch 'transaction (unwind-protect (prog1 (funcall txn-fn) (setq success t) - (db-transaction-commit :transaction txn - :txn-nosync txn-nosync - :txn-sync txn-sync)) + (db-transaction-commit txn :txn-nosync txn-nosync + :txn-sync txn-sync)) (unless success - (db-transaction-abort :transaction txn))))))) + (db-transaction-abort txn))))))) (unless (and (eq result txn) (not success)) (return result)))) finally (error "Too many retries in transaction")))) @@ -79,6 +75,7 @@ dirty-read degree-2 &allow-other-keys) + (assert (not *current-transaction*)) (db-transaction-begin (controller-environment sc) :parent parent :txn-nosync txn-nosync @@ -88,8 +85,101 @@ :degree-2 degree-2)) -(defmethod controller-commit-transaction ((sc bdb-store-controller) &key transaction &allow-other-keys) - (db-transaction-commit :transaction transaction)) +(defmethod controller-commit-transaction ((sc bdb-store-controller) transaction &key &allow-other-keys) + (assert (not *current-transaction*)) + (db-transaction-commit transaction)) -(defmethod controller-abort-transaction ((sc bdb-store-controller) &key &allow-other-keys) - (db-transaction-abort)) \ No newline at end of file +(defmethod controller-abort-transaction ((sc bdb-store-controller) transaction &key &allow-other-keys) + (assert (not *current-transaction*)) + (db-transaction-abort transaction)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Old versions of with-transaction +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +(defmacro with-transaction ((&key transaction environment + (parent '*current-transaction*) + (retries 100) + dirty-read read-uncommitted + txn-nosync txn-nowait txn-sync) + &body body) + (let ((txn (if transaction transaction (gensym))) + (count (gensym)) + (result (gensym)) + (success (gensym))) + `(loop + for ,count fixnum from 1 to ,retries + for ,success of-type boolean = nil + do + (with-alien ((,txn (* t) + (db-transaction-begin ,environment + :parent ,parent + :dirty-read (or ,dirty-read ,read-uncommitted) + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync))) + (let ((,result + (let ((*current-transaction* ,txn)) + (declare (special *current-transaction*) + (dynamic-extent *current-transaction*)) + (catch 'transaction + (unwind-protect + (prog1 (progn ,@body) + (setq ,success t) + (db-transaction-commit :transaction ,txn + :txn-nosync ,txn-nosync + :txn-sync ,txn-sync)) + (unless ,success + (db-transaction-abort :transaction ,txn))))))) + (unless (and (eq ,result ,txn) (not ,success)) + (return ,result)))) + finally (error "Too many retries")))) + +(defmacro with-transaction ((&key transaction environment + (parent '*current-transaction*) + (retries 100) + degree-2 read-committed + dirty-read read-uncommitted + txn-nosync txn-nowait txn-sync) + &body body) + "Execute a body with a transaction in place. On success, +the transaction is committed. Otherwise, the transaction is +aborted. If the body deadlocks, the body is re-executed in +a new transaction, retrying a fixed number of iterations." + (let ((txn (if transaction transaction (gensym))) + (count (gensym)) + (result (gensym)) + (success (gensym))) + `(loop + for ,count fixnum from 1 to ,retries + for ,success of-type boolean = nil + do + (let ((,txn + (db-transaction-begin ,environment + :parent ,parent + :degree-2 (or ,degree-2 ,read-committed) + :dirty-read (or ,dirty-read ,read-uncommitted) + :txn-nosync ,txn-nosync + :txn-nowait ,txn-nowait + :txn-sync ,txn-sync))) + (declare (type pointer-void ,txn) + (dynamic-extent ,txn)) + (let ((,result + (let ((*current-transaction* ,txn)) + (declare (special *current-transaction*) + (dynamic-extent *current-transaction*)) + (catch 'transaction + (unwind-protect + (prog1 (progn ,@body) + (setq ,success t) + (db-transaction-commit :transaction ,txn + :txn-nosync ,txn-nosync + :txn-sync ,txn-sync)) + (unless ,success + (db-transaction-abort :transaction ,txn))))))) + (unless (and (eq ,result ,txn) (not ,success)) + (return ,result)))) + finally (error "Too many retries")))) +|# --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/31 22:24:16 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/02 23:51:58 1.7 @@ -72,6 +72,9 @@ ) +(defmacro txn-default (dvar) + `(if ,dvar ,dvar +NULL-VOID+)) + ;; ;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -132,6 +135,8 @@ (defconstant DB_FIRST 7) (defconstant DB_GET_BOTH 8) (defconstant DB_GET_BOTH_RANGE 10) +(defconstant DB_KEYFIRST 13) +(defconstant DB_KEYLAST 14) (defconstant DB_LAST 15) (defconstant DB_NEXT 16) (defconstant DB_NEXT_DUP 17) @@ -220,8 +225,6 @@ ;; makes flags into keywords ;; makes keyword args, cstring wrappers -(defvar *errno-buffer* (allocate-foreign-object :int 1)) - (eval-when (:compile-toplevel) (defun make-wrapper-args (args flags keys) (if (or flags keys) @@ -404,7 +407,7 @@ :returning :int) (wrap-errno db-env-open (dbenvp home flags mode) - :flags (init-cdb init-lock init-log + :flags (auto-commit init-cdb init-lock init-log init-mpool init-rep init-txn recover recover-fatal create lockdown private system-mem thread @@ -423,7 +426,7 @@ (wrap-errno db-env-dbremove (env transaction file database flags) :flags (auto-commit) - :keys ((transaction *current-transaction*) + :keys ((transaction (txn-default *current-transaction*)) (database +NULL-CHAR+)) :cstrings (file database) :transaction transaction @@ -440,7 +443,7 @@ (wrap-errno db-env-dbrename (env transaction file database newname flags) :flags (auto-commit) - :keys ((transaction *current-transaction*) + :keys ((transaction (txn-default *current-transaction*)) (database +NULL-CHAR+)) :cstrings (file database newname) :transaction transaction @@ -535,7 +538,7 @@ :flags (auto-commit create dirty-read read-uncommitted excl nommap rdonly thread truncate ) - :keys ((transaction *current-transaction*) + :keys ((transaction (txn-default *current-transaction*)) (file +NULL-CHAR+) (database +NULL-CHAR+) (type DB-UNKNOWN) @@ -584,7 +587,8 @@ :returning :int) (wrap-errno db-truncate (db transaction flags) :flags (auto-commit) - :keys ((transaction *current-transaction*)) :outs 2 + :keys ((transaction (txn-default *current-transaction*))) + :outs 2 :transaction transaction :documentation "Truncate (erase) a DB.") @@ -625,8 +629,8 @@ :returning :int) (defun db-get-key-buffered (db key-buffer-stream value-buffer-stream - &key (transaction *current-transaction*) - auto-commit get-both degree-2 read-committed + &key (transaction (txn-default *current-transaction*)) + get-both degree-2 read-committed dirty-read read-uncommitted) "Get a key / value pair from a DB. The key is encoded in a buffer-stream. Space for the value is passed in as a @@ -634,7 +638,7 @@ decoding, or NIL if nothing was found." (declare (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream) - (type boolean auto-commit get-both degree-2 read-committed dirty-read read-uncommitted)) + (type boolean get-both degree-2 read-committed dirty-read read-uncommitted)) (loop for value-length fixnum = (buffer-stream-length value-buffer-stream) do @@ -644,8 +648,7 @@ (buffer-stream-size key-buffer-stream) (buffer-stream-buffer value-buffer-stream) value-length - (flags :auto-commit auto-commit - :get-both get-both + (flags :get-both get-both :degree-2 (or degree-2 read-committed) :dirty-read (or dirty-read read-uncommitted))) (declare (type fixnum result-size errno)) @@ -675,8 +678,8 @@ (defun db-get-buffered (db key value-buffer-stream &key (key-size (length key)) - (transaction *current-transaction*) - auto-commit get-both degree-2 read-committed + (transaction (txn-default *current-transaction*)) + get-both degree-2 read-committed dirty-read read-uncommitted) "Get a key / value pair from a DB. The key is passed as a string. Space for the value is passed in as a @@ -686,7 +689,7 @@ (type string key) (type buffer-stream value-buffer-stream) (type fixnum key-size) - (type boolean auto-commit get-both degree-2 read-committed + (type boolean get-both degree-2 read-committed dirty-read read-uncommitted)) (with-cstring (k key) (loop @@ -696,8 +699,7 @@ (%db-get-buffered db transaction k key-size (buffer-stream-buffer value-buffer-stream) value-length - (flags :auto-commit auto-commit - :get-both get-both + (flags :get-both get-both :degree-2 (or degree-2 read-committed) :dirty-read (or dirty-read read-uncommitted))) (declare (type fixnum result-size errno)) @@ -715,8 +717,8 @@ (t (error 'db-error :errno errno))))))) (defun db-get (db key &key (key-size (length key)) - (transaction *current-transaction*) - auto-commit get-both degree-2 read-committed + (transaction (txn-default *current-transaction*)) + get-both degree-2 read-committed dirty-read read-uncommitted) "Get a key / value pair from a DB. The key is passed as a string, and the value is returned as a string. If nothing @@ -724,7 +726,7 @@ (declare (type pointer-void db transaction) (type string key) (type fixnum key-size) - (type boolean auto-commit get-both degree-2 read-committed + (type boolean get-both degree-2 read-committed dirty-read read-uncommitted)) (with-cstring (k key) (with-buffer-streams (value-buffer-stream) @@ -735,8 +737,7 @@ (%db-get-buffered db transaction k key-size (buffer-stream-buffer value-buffer-stream) value-length - (flags :auto-commit auto-commit - :get-both get-both + (flags :get-both get-both :degree-2 (or degree-2 read-committed) :dirty-read (or dirty-read read-uncommitted))) (declare (type fixnum result-size errno)) @@ -766,21 +767,21 @@ :returning :int) (defun db-put-buffered (db key-buffer-stream value-buffer-stream - &key (transaction *current-transaction*) auto-commit + &key (transaction (txn-default *current-transaction*)) exists-error-p) "Put a key / value pair into a DB. The pair are encoded in buffer-streams. T on success, or nil if the key already exists and EXISTS-ERROR-P is NIL." (declare (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream) - (type boolean auto-commit exists-error-p)) + (type boolean exists-error-p)) (let ((errno (%db-put-buffered db transaction (buffer-stream-buffer key-buffer-stream) (buffer-stream-size key-buffer-stream) (buffer-stream-buffer value-buffer-stream) (buffer-stream-size value-buffer-stream) - (flags :auto-commit auto-commit)))) + 0))) (declare (type fixnum errno)) (cond ((= errno 0) t) ((and (= errno DB_KEYEXIST) (not exists-error-p)) @@ -800,15 +801,14 @@ :returning :int) (wrap-errno db-put (db transaction key key-size value value-size flags) - :flags (auto-commit) + :flags () :keys ((key-size (length key)) (value-size (length value)) - (transaction *current-transaction*)) + (transaction (txn-default *current-transaction*))) :cstrings (key value) :declarations (declare (type pointer-void db transaction) (type string key value) - (type fixnum key-size value-size) - (type boolean auto-commit)) + (type fixnum key-size value-size)) :transaction transaction :documentation "Put a key / value pair into a DB. The pair are strings.") @@ -821,18 +821,17 @@ (flags :unsigned-int)) :returning :int) -(defun db-delete-buffered (db key-buffer-stream &key auto-commit - (transaction *current-transaction*)) +(defun db-delete-buffered (db key-buffer-stream + &key (transaction (txn-default *current-transaction*))) "Delete a key / value pair from a DB. The key is encoded in a buffer-stream. T on success, NIL if the key wasn't found." (declare (type pointer-void db transaction) - (type buffer-stream key-buffer-stream) - (type boolean auto-commit)) + (type buffer-stream key-buffer-stream)) (let ((errno (%db-delete-buffered db transaction (buffer-stream-buffer key-buffer-stream) (buffer-stream-size key-buffer-stream) - (flags :auto-commit auto-commit)))) + 0))) (declare (type fixnum errno)) (cond ((= errno 0) t) ((or (= errno DB_NOTFOUND) @@ -851,16 +850,16 @@ (flags :unsigned-int)) :returning :int) -(defun db-delete (db key &key auto-commit (key-size (length key)) - (transaction *current-transaction*)) +(defun db-delete (db key &key (key-size (length key)) + (transaction (txn-default *current-transaction*))) "Delete a key / value pair from a DB. The key is a string. T on success, NIL if the key wasn't found." (declare (type pointer-void db transaction) (type string key) - (type fixnum key-size) (type boolean auto-commit)) + (type fixnum key-size)) (with-cstrings ((key key)) (let ((errno (%db-delete db transaction key - key-size (flags :auto-commit auto-commit)))) + key-size 0))) (declare (type fixnum errno)) (cond ((= errno 0) t) ((or (= errno DB_NOTFOUND) @@ -881,7 +880,7 @@ :returning :int) (defun db-delete-kv-buffered (db key-buffer-stream value-buffer-stream - &key (transaction *current-transaction*)) + &key (transaction (txn-default *current-transaction*))) "Delete a specific key / value pair from a DB with duplicates. The key and value are encoded as buffer-streams. T on success, NIL if the key / value pair @@ -918,7 +917,7 @@ (end-size :unsigned-int :out)) :returning :int) -(defun db-compact (db start stop end &key (transaction *current-transaction*) +(defun db-compact (db start stop end &key (transaction (txn-default *current-transaction*)) freelist-only free-space) (declare (type pointer-void db transaction) (type buffer-stream start stop) @@ -956,20 +955,22 @@ (errnop (* :int))) :returning :pointer-void) -(defun db-cursor (db &key (transaction *current-transaction*) +(defun db-cursor (db &key (transaction (txn-default *current-transaction*)) degree-2 read-committed dirty-read read-uncommitted) "Create a cursor." (declare (type pointer-void db) - (type boolean degree-2 read-committed dirty-read read-uncommitted) - (type pointer-int *errno-buffer*)) - (let* ((curs (%db-cursor db transaction (flags :degree-2 (or degree-2 read-committed) - :dirty-read (or dirty-read read-uncommitted)) - *errno-buffer*)) - (errno (deref-array *errno-buffer* '(:array :int) 0))) - (declare (type pointer-void curs) - (type fixnum errno)) - (if (= errno 0) curs - (error 'db-error :errno errno)))) + (type boolean degree-2 read-committed dirty-read read-uncommitted)) + (let ((errno-buffer (allocate-foreign-object :int 1))) + (declare (type pointer-int errno-buffer)) + (let* ((curs (%db-cursor db transaction + (flags :degree-2 (or degree-2 read-committed) + :dirty-read (or dirty-read read-uncommitted)) + errno-buffer)) + (errno (deref-array errno-buffer '(:array :int) 0))) + (declare (type pointer-void curs) + (type fixnum errno)) + (if (= errno 0) curs + (error 'db-error :errno errno))))) (def-function ("db_cursor_close" %db-cursor-close) ((cursor :pointer-void)) @@ -1005,13 +1006,15 @@ (defun db-cursor-duplicate (cursor &key (position t)) "Duplicate a cursor." (declare (type pointer-void cursor)) - (let* ((newc (%db-cursor-dup cursor (flags :position position) - *errno-buffer*)) - (errno (deref-array *errno-buffer* '(:array :int) 0))) - (declare (type pointer-void newc) - (type fixnum errno)) - (if (= errno 0) newc - (error 'db-error :errno errno)))) + (let ((errno-buffer (allocate-foreign-object :int 1))) + (declare (type pointer-int errno-buffer)) + (let* ((newc (%db-cursor-dup cursor (flags :position position) + errno-buffer)) + (errno (deref-array errno-buffer '(:array :int) 0))) + (declare (type pointer-void newc) + (type fixnum errno)) + (if (= errno 0) newc + (error 'db-error :errno errno))))) (def-function ("db_cursor_get_raw" %db-cursor-get-key-buffered) ((cursor :pointer-void) @@ -1377,35 +1380,35 @@ (errno (* :int))) :returning :pointer-void) -(defun db-transaction-begin (env &key (parent *current-transaction*) +(defun db-transaction-begin (env &key parent degree-2 read-committed dirty-read read-uncommitted txn-nosync txn-nowait txn-sync) "Start a transaction. Transactions may be nested." (declare (type pointer-void env parent) (type boolean degree-2 read-committed dirty-read read-uncommitted - txn-nosync txn-nowait txn-sync) - (type pointer-int *errno-buffer*)) - (let* ((txn - (%db-txn-begin env parent - (flags :degree-2 (or degree-2 read-committed) - :dirty-read (or dirty-read read-uncommitted) - :txn-nosync txn-nosync - :txn-nowait txn-nowait - :txn-sync txn-sync) - *errno-buffer*)) - (errno (deref-array *errno-buffer* '(:array :int) 0))) - (declare (type pointer-void txn) - (type fixnum errno)) - (if (= errno 0) - txn - (error 'db-error :errno errno)))) + txn-nosync txn-nowait txn-sync)) + (let ((errno-buffer (allocate-foreign-object :int 1))) + (declare (type pointer-int errno-buffer)) + (let* ((txn + (%db-txn-begin env parent + (flags :degree-2 (or degree-2 read-committed) + :dirty-read (or dirty-read read-uncommitted) + :txn-nosync txn-nosync + :txn-nowait txn-nowait + :txn-sync txn-sync) + errno-buffer)) + (errno (deref-array errno-buffer '(:array :int) 0))) + (declare (type pointer-void txn) + (type fixnum errno)) + (if (= errno 0) + txn + (error 'db-error :errno errno))))) (def-function ("db_txn_abort" %db-txn-abort) ((txn :pointer-void)) :returning :int) (wrap-errno (db-transaction-abort %db-txn-abort) (transaction) - :keys ((transaction *current-transaction*)) :declarations (declare (type pointer-void transaction)) :documentation "Abort a transaction.") @@ -1415,106 +1418,18 @@ :returning :int) (wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) - :keys ((transaction *current-transaction*)) :flags (txn-nosync txn-sync) :declarations (declare (type pointer-void transaction) (type boolean txn-nosync txn-sync)) :documentation "Commit a transaction.") -#| -(defmacro with-transaction ((&key transaction environment - (parent '*current-transaction*) - (retries 100) - dirty-read read-uncommitted - txn-nosync txn-nowait txn-sync) - &body body) [208 lines skipped]

1 0

[elephant-cvs] CVS elephant
by ieslick 02 Feb '07

02 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv3271 Modified Files: TODO config.sexp Log Message: Large changeset to enable thread safety; more *auto-commit* removal; sql class-root fix; new transaction model; cleaned up defaults for *store-controller* --- /project/elephant/cvsroot/elephant/TODO 2007/02/01 04:03:26 1.39 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/02 23:51:58 1.40 @@ -6,32 +6,13 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -Lisp support: -- OpenMCL 1.1 on Mac OS X -- Win32 builds -- Lispworks? - Active tasks: -- Full 64-bit support (arrays, native 64-bit fixnums, etc) - - Set parameter at startup based on *features* - - Mark fixnums appropriately: 32-bit lisps can decode 64-bit fixnums as bignums (two 32-bit entities) - - propogate assumptions to bignum byte specs - - are there other fixed assumptions? - - char vs. uint8 in buffer-stream to read-out (See Marco e-mail) - -- Ensure serialization is thread-safe and reasonably efficient +- Support locks in serializer for all systems - Provide support for fast and slow critical sections by lisps: buffer-streams, circularity-arrays/hashes, shared controller side-effects... (see email) - - Resourced-byte-spec should be per-thread (or removed - ok to cons during bignum serialization) -- Think about dynamic vs. object-based store & transaction variables - - Perform error checking when mixed - - Current store specific *current-transaction* stack -- Allow elephant threads to appropriately bind dynamic variables? -- Thread safety for all global vars -- Thread safe API option for user-managed store-controller? -- Thread safe API for transactions -- Throw condition when store spec is invalid, etc -- Test with BDB 4.5? +- Trace all paths to db-put or db-delete and ensure that there is a check or a + default ensure-transaction around the primitive components - write a document + clarifying transaction design & assumptions in the backend] BDB Features: ? Determine how to detect deadlock conditions as an optional run-safe mode? @@ -39,74 +20,72 @@ functions and ability to launch shell command. Closing the store stops the sub-process. ? Always support locks that timeout? Tradeoffs? -- Roll deprecation of *auto-commit* through code base so leaf functions stop referring to it -- Trace all paths to db-put or db-delete and ensure that there is a check or a - default with-transaction around the primitive components - write a document - clarifying transaction design & assumptions in the backend] 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) - Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API -Indexing efficiency and policies: -- 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? -- Reclaim table storage on index drop? It's nice to be able to reconnect sometimes! - Perhaps an API command that allows explicit dropping of tables for a class and a policy - parameter that determines if this is the default? +ALPHA RELEASE ITEMS -Performance: -- Implement unicode performance hacks for various lisps; validate UTF8 works everywhere -- Metering and understanding locking issues. Large transactions seem - to use a lot of locks. In general understanding how to use Berkeley DB - efficiently seems like a good thing. (From Ben) -- 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) +Lisp support: +- 64-bit lisp verification +- Win32 builds + - Windows support for asdf-based library builds? Include 32-bit dll in release? +- OpenMCL 1.1 on Mac OS X +- Lispworks Stability: -- Delete persistent slot values from the slot store with remove-kv to ensure that - there's no data left lying around if you define then redefine a class and add - back a persistent slot name that you thought was deleted and it gets the old - value by default. -- Cleaner failure modes if operations are performed without repository or without - transaction or auto-commit (auto-commit solved by 4.4?) - Review and address all NOTE comments in the code -- Use SWIG and CFFI to better track changes in defconstant? -RELEASE ISSUES +Migration: +- Validate migration 0.6.0->0.6.1 +- Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs + +BETA RELEASE ITEMS Test coverage: - Test for optimize storage method (just add probe-file methods to get file size) - Multi-threading stress tests? Ensure that there are conflicts and lots of serialization happening concurrently to make sure that multi-threading is in good shape - -Utilities and Build features: -- Validate migration 0.6.0->0.6.1 - - Validate that migrate can use either O(c) or O(n/c) where c << n memory -- Windows support for asdf-based library builds? Include dll? +- Unicode tests + - Test with UTF-16 and UTF-32 strings (construct with char-code?) + - Ensure that variable length UTF-8 is automatically stored as UTF-16 Documentation: -- Migrate code base to SVN and create tickets in TRAC -- Add notes about with-transaction usage (abort & commit behavior on exit) -- Add notes about fast-symbols +- Migrate code base to Darcs and create tickets in TRAC +- Add notes about with/ensure-transaction usage (abort & commit behavior on exit) - Add notes about optimize-storage -- Add notes about new BDB 4.4 *auto-commit* behavior. Default for entire store-controller, - will auto create a transaction if none is active if open with :auto-commit t or will - never auto-commit (regardless of operator flags) if it is not. Make sure open-store - defaults to auto-commit and there is a flag to turn it off. +- Add notes about deadlock-detect +- Add notes about new BDB 4.4 *auto-commit* behavior. Default for entire + store-controller will auto create a transaction if none is active if open + with :auto-commit t or will never auto-commit (regardless of operator flags) + if it is not. Make sure open-store defaults to auto-commit and there is a + flag to turn it off. 0.6.1 - Features COMPLETED to date ---------------------------------- -January 22, 2006 checkins: +Feburary 2nd, 2007 checkins: +x Check for manual & automatic transactions running concurrently +x Modify *current-transaction* to be null on default, allowing backends to choose the default format (vs. +NULL-VOID+) +x Update BDB backend to properly provide result +x Roll deprecation of *auto-commit* through code base so leaf functions stop referring to it; modify berkeley-db to not refer to auto-commit except where it's appropriate (open commands) +x Ensure serialization is thread-safe and reasonably efficient +x Resourced-byte-spec should be per-thread (or removed - ok to cons during bignum serialization) +x Allow elephant threads to appropriately bind dynamic variables? +x Thread safety for all global vars +x Thread safe API option for user-managed store-controller? +x Thread safe API for transactions +x Ported to and tested with BDB 4.5 +x Full 64-bit support (arrays, native 64-bit fixnums, etc) + x Mark fixnums appropriately: 32-bit lisps can decode 64-bit fixnums as bignums (two 32-bit entities) + x char vs. uint8 in buffer-stream to read-out (See Marco e-mail) + +January 22, 2007 checkins: x Modularize serializers for easy upgrade x MCL 1.1 unicode support; clean up other lisp support for unicode x Simplify user-specific configuration parameters using config.sexp and my-config.sexp x Ensure thread safety in buffer-stream allocation! -January 2006 checkins; minor fixes +January 2007 checkins; minor fixes x Think through default *store-controller* vs. explicit parameter passing referencing all over the APIs (Enable explicit passing everywhere, maintain *store-controller* defaults. This makes multi-threading support simpler. Users can pass the store controller or rely on a global *store-controller*) @@ -134,17 +113,41 @@ 0.6.2 - Advanded work, low-hanging fruit (Summer '07) -------------------------------------------------- - - BDB sorting - - Compare strings of different types in BDB C sorting function - - Or support Lisp sorting callback +Storage and Indexing: +- 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? +- Reclaim table storage on index drop? It's nice to be able to reconnect sometimes! + Perhaps an API command that allows explicit dropping of tables for a class and a policy + parameter that determines if this is the default? +- Delete persistent slot values from the slot store with remove-kv to ensure that + there's no data left lying around if you define then redefine a class and add + back a persistent slot name that you thought was deleted and it gets the old + value by default. + +Performance: +- Implement unicode performance hacks for various lisps; validate UTF8 works everywhere +- Metering and understanding locking issues. Large transactions seem + to use a lot of locks. In general understanding how to use Berkeley DB + efficiently seems like a good thing. (From Ben) +- 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) +- Improve SQL serializer performance (Robert/Ian) + +Design: + - Use SWIG and CFFI to better track changes in defconstant? + - Evaluate porting elephant to closer-to-MOP to make it easier to + support additional lisps and to seriously clean up + metaclasses.lisp and classes.lisp protocols + +Features: - Persistent variables (abstraction that allows compound lisp objects at the cost of full serialization after each write that indirects through the API). Can this be done with clean semantics or should we punt it? - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - - Evaluate porting elephant to closer-to-MOP to make it easier to - support additional lisps and to seriously clean up - metaclasses.lisp and classes.lisp protocols - A wrapper around migration that emulates a stop-and-copy GC + +Documentation: - 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. @@ -153,7 +156,6 @@ - A guide to dealing with multiple open stores - A guide to performance - An overview of licensing issues... - - Improve SQL serializer performance (Robert/Ian) 0.7.0: Fast In-Memory Database (Not backwards compatible) -------------------------------------------------- --- /project/elephant/cvsroot/elephant/config.sexp 2007/01/25 18:17:59 1.4 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/02/02 23:51:58 1.5 @@ -1,10 +1,15 @@ -((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.4/") - (:berkeley-db-lib-dir . "/opt/local/lib/db44/") - (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib") +((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.5/") + (:berkeley-db-lib-dir . "/opt/local/lib/db45/") + (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.5/lib/libDB-4.5.dylib") (:pthread-lib . nil) (:clsql-lib . nil)) +;; Berkeley 4.5 is required, each system will have different settings for +;; these directories, use this as an indication of what each key means +;; ;; Typical pthread settings are: /lib/tls/libpthread.so.0 +;; ;; nil means that the library in question is not loaded -;; NOTE: The latest SBCL on linux no longer needs the pthread library, +;; +;; NOTE: The latest SBCL (0.9.17+) on linux no longer needs the pthread library, ;; it is statically linked against it now with the new thread support \ No newline at end of file

1 0

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

02 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv21940/elephant Modified Files: serializer.lisp Log Message: These args when in a bad order. --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/26 14:41:13 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/02 22:39:23 1.19 @@ -51,8 +51,8 @@ (with-buffer-streams (other) (deserialize (elephant-memutil::buffer-write-byte-vector - other (cl-base64::base64-string-to-usb8-array x) + other ) sc) ))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 01 Feb '07

01 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv18919/tests Modified Files: testserializer.lisp Log Message: Finish 64-bit update; clean up memutil; fix array flag type error in SBCL; more efficient and correct hash serialization in new serializer --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 04:37:25 1.14 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 15:19:50 1.15 @@ -47,10 +47,75 @@ (typep (in-out-value most-negative-fixnum) 'fixnum)) t t t t t) +;; +;; Validate 32/64 bit memutils operation (white box test) +;; + +(deftest read-32-bit-fixnum + (progn + (with-buffer-streams (bs) + (if (not (elephant-memutil::little-endian-p)) + (elephant-memutil::buffer-write-byte 1 bs)) + (loop for i from 1 upto 3 do + (elephant-memutil::buffer-write-byte 0 bs)) + (if (elephant-memutil::little-endian-p) + (elephant-memutil::buffer-write-byte 1 bs)) + (elephant-memutil::buffer-read-fixnum32 bs))) + #x1000000) + +(deftest read-64-bit-fixnum + (progn + (with-buffer-streams (bs) + (if (not (elephant-memutil::little-endian-p)) + (elephant-memutil::buffer-write-byte 1 bs)) + (loop for i from 1 upto 7 do + (elephant-memutil::buffer-write-byte 0 bs)) + (if (elephant-memutil::little-endian-p) + (elephant-memutil::buffer-write-byte 1 bs)) + (elephant-memutil::buffer-read-fixnum64 bs))) + #x100000000000000) + +;; +;; Use serializer to write fixnum +;; Verify bytes and length of output +;; + +(deftest write-32-bit-fixnum + (progn + (with-buffer-streams (bs) + (serialize #x01000000 bs *store-controller*) + (elephant-memutil::buffer-read-byte bs) ;; skip tag + (and (= (elephant-memutil::buffer-stream-size bs) 5) + (if (elephant-memutil::little-endian-p) + (= (progn (loop for i from 1 upto 3 do + (elephant-memutil::buffer-read-byte bs)) + (elephant-memutil::buffer-read-byte bs)) + 1) + (= (elephant-memutil::buffer-read-byte bs) + 1))))) + t) + +(deftest write-64-bit-fixnum + (progn + (with-buffer-streams (bs) + (serialize #x0100000000000000 bs *store-controller*) + (elephant-memutil::buffer-read-byte bs) ;; skip tag + (if (< most-positive-fixnum elephant-memutil::+2^32+) + t + (and (= (elephant-memutil::buffer-stream-size bs) 9) + (if (elephant-memutil::little-endian-p) + (= (progn (loop for i from 1 upto 7 do + (elephant-memutil::buffer-read-byte bs)) + (elephant-memutil::buffer-read-byte bs)) + 1) + (= (elephant-memutil::buffer-read-byte bs) + 1)))))) + t) + (deftest bignums (are-not-null - (in-out-equal 10000000000) - (in-out-equal -10000000000) + (in-out-equal (+ most-positive-fixnum 100)) + (in-out-equal (- most-negative-fixnum 100)) (loop for i from 0 to 2000 always (in-out-equal (expt 2 i))) (loop for i from 0 to 2000 @@ -167,22 +232,21 @@ (deftest hash-tables-1 (let* ((ht (make-hash-table :test 'equalp :size 333 :rehash-size 1.2 :rehash-threshold 0.8)) - (size (hash-table-size ht)) (rehash-size (hash-table-rehash-size ht)) (rehash-threshold (hash-table-rehash-threshold ht)) - (out (in-out-value ht))) + (out (in-out-value ht))) (are-not-null (eq (hash-table-test out) 'equalp) - (= (hash-table-size ht) size) - (= (hash-table-rehash-size ht) rehash-size) - (= (hash-table-rehash-threshold ht) rehash-threshold) +;; (= (hash-table-size out) size) ;; size is not equal, only kv pairs are stored +;; (= (hash-table-rehash-size out) rehash-size) ;; hint only, implementation not constrained +;; (= (hash-table-rehash-threshold out) rehash-threshold) ;; hints only, implementation not constrained (eq (hash-table-test (in-out-value (make-hash-table :test 'eq))) 'eq) (eq (hash-table-test (in-out-value (make-hash-table :test 'eql))) 'eql) (eq (hash-table-test (in-out-value (make-hash-table :test 'equal))) 'equal) (eq (hash-table-test (in-out-value (make-hash-table :test 'equalp))) 'equalp))) - t t t t t t t t) + t t t t t) (deftest hash-tables-2 (let ((ht (make-hash-table :test 'equalp))) @@ -391,33 +455,4 @@ (eq (get-value f2 h) f2)))) t t t t t t t t) -(defparameter +little-endian+ nil) -(defparameter +big-endian+ t) - -(defun determine-endianness () - (with-buffer-streams (bs) - (%serialize 1 bs *store-controller*) - (elephant-memutil::buffer-read-byte bs) - ;; If little endian, switch defaults - (when (= (elephant-memutil::buffer-read-byte bs) 1) - (setf +little-endian+ t) - (setf +big-endian+ nil)))) - -;; -;; Manually write bytes -;; Verify read out using serializer -;; - -;;(deftest read-32-bit-fixnum -;; (progn nil) -;; t) - -;;(deftest read-64-bit-fixnum -;; (progn nil) -;; t) -;; -;; Clear the buffer stream -;; Use serializer to write fixnum if 64-bit -;; Verify bytes and length of output -;; \ No newline at end of file

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 01 Feb '07

01 Feb '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv18919/src/memutil Modified Files: memutil.lisp Log Message: Finish 64-bit update; clean up memutil; fix array flag type error in SBCL; more efficient and correct hash serialization in new serializer --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 04:37:25 1.17 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 15:19:50 1.18 @@ -48,19 +48,18 @@ #:buffer-write-int #:buffer-write-uint #:buffer-read-byte #:buffer-read-fixnum - #:buffer-read-fixnum32 - #:buffer-read-fixnum64 + #:buffer-read-fixnum32 #:buffer-read-fixnum64 #:buffer-read-int #:buffer-read-uint #:buffer-read-int32 #:buffer-read-uint32 #:buffer-read-int64 #:buffer-read-uint64 #:buffer-read-float #:buffer-read-double + #:buffer-write-oid #:buffer-read-oid + #:buffer-read-ucs1-string #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string - #:byte-length - - #:serialize-string #:deserialize-string + #:byte-length #:little-endian-p #:pointer-int #:pointer-void #:array-or-pointer-char +NULL-CHAR+ +NULL-VOID+ @@ -98,11 +97,13 @@ (inline read-int read-uint read-float read-double write-int write-uint write-float write-double offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs - ;;resize-buffer-stream - ;;buffer-stream-buffer buffer-stream-size buffer-stream-position - ;;buffer-stream-length + ;; resize-buffer-stream + ;; buffer-stream-buffer buffer-stream-size buffer-stream-position + ;; buffer-stream-length + buffer-write-oid buffer-read-oid reset-buffer-stream - buffer-write-byte buffer-write-int32 buffer-write-uint32 + buffer-write-byte + buffer-write-int32 buffer-write-uint32 buffer-write-int64 buffer-write-uint64 buffer-write-float buffer-write-double buffer-write-string buffer-read-byte buffer-read-fixnum buffer-read-int32 @@ -174,7 +175,9 @@ ,@(loop for name in names collect (list 'return-buffer-stream name)))))) +;; ;; Buffer management / pointer arithmetic +;; ;; Notes: on Allegro: with-cast-pointer + deref-array is ;; faster than FFI + C pointer arithmetic. however pointer @@ -694,7 +697,7 @@ (setf (aref v i) (buffer-read-byte bs)))) nil))) -(defun buffer-write-byte-vector (bs bv) +(defun buffer-write-byte-vector (bv bs) "Read the whole buffer into byte vector." (declare (type buffer-stream bs)) (let* ((position (buffer-stream-position bs)) @@ -704,9 +707,19 @@ (dotimes (i writable bs) (buffer-write-byte (aref bv i) bs)))) -(defun buffer-write-int (bs int) - ;; deprecated, better to use explicit int32 or int64 version - (buffer-write-int32 bs int)) +;; +;; Compatibility +;; + +(defun buffer-write-oid (i bs) + (buffer-write-int32 i bs)) + +(defun buffer-read-oid (bs) + (buffer-read-fixnum32 bs)) + +;; +;; Legacy support +;; (defun buffer-read-int (bs) ;; deprecated, better to use explicit int32 or int64 version @@ -716,13 +729,17 @@ ;; deprecated, better to use explicit int32 or int64 version (the fixnum (buffer-read-fixnum32 bs))) +(defun buffer-write-int (int bs) + ;; deprecated, better to use explicit int32 or int64 version + (buffer-write-int32 int bs)) + (defun buffer-read-uint (bs) ;; deprecated, better to use explicit int32 or int64 version (buffer-read-uint32 bs)) -(defun buffer-write-uint (bs int) +(defun buffer-write-uint (int bs) ;; deprecated, better to use explicit int32 or int64 version - (buffer-write-uint32 bs int)) + (buffer-write-uint32 int bs)) (defconstant +2^32+ 4294967296) (defconstant +2^64+ 18446744073709551616) @@ -753,8 +770,13 @@ (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 8)) (if (< #.most-positive-fixnum +2^32+) - (+ (read-int32 (buffer-stream-buffer bs) position) - (* +2^32+ (read-int32 (buffer-stream-buffer bs) (+ position 4)))) + ;; 32-bit or less fixnums; need to process as bignums + (let ((first (read-int32 (buffer-stream-buffer bs) position)) + (second (read-int32 (buffer-stream-buffer bs) (+ position 4)))) + (if (little-endian-p) + (+ first (ash second 32)) + (+ second (ash first 32)))) + ;; Native 64-bit fixnums (NOTE: issues with non 32/64 bit fixnums?) (the fixnum (read-int64 (buffer-stream-buffer bs) position))))) (defun buffer-read-int64 (bs) @@ -865,3 +887,24 @@ (* sb-vm:vector-data-offset sb-vm:n-word-bits) (* byte-length sb-vm:n-byte-bits)) res))) + +;; +;; What kind of machine are we on? +;; + +(defparameter +little-endian+ nil) + +(defun little-endian-p () + #+(or :x86 :x86-64 :LITTLE-ENDIAN) t + #+(or :PPC :POWERPC :BIG-ENDIAN) nil + #-(or :x86 :x86-64 :LITTLE-ENDIAN :PPC :POWERPC :BIG-ENDIAN) + (progn + (unless +little-endian+ + (with-buffer-streams (bs) + (buffer-write-int32 #x1 bs) + (if (= 0 (buffer-read-byte bs)) + (setf +little-endian+ 2) + (setf +little-endian+ 1)))) + (if (eq +little-endian+ 1) t nil))) + +

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 01 Feb '07

01 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv18919/src/elephant Modified Files: serializer2.lisp Log Message: Finish 64-bit update; clean up memutil; fix array flag type error in SBCL; more efficient and correct hash serialization in new serializer --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/01 04:03:27 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/01 15:19:50 1.9 @@ -80,8 +80,8 @@ (defconstant +nil+ #x3F) ;; Arrays -(defconstant +fill-pointer-p+ #x40) -(defconstant +adjustable-p+ #x80) +(defconstant +fill-pointer-p+ #x20) +(defconstant +adjustable-p+ #x40) ;; ;; NOTE: Used bad coding practice here: without-interrupts is a single-CPU @@ -158,16 +158,20 @@ (incf *lisp-obj-id*)) (%serialize (frob) (etypecase frob - (fixnum ;; (integer #.most-negative-fixnum #.most-positive-fixnum) - ;; Should be compiled away... - (if (< #.most-positive-fixnum +2^32+) + (fixnum + (if (< #.most-positive-fixnum +2^32+) ;; should be compiled away (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) (progn (assert (< #.most-positive-fixnum +2^64+)) - (buffer-write-byte +fixnum64+ bs) - (buffer-write-int64 frob bs)))) + (if (< frob +2^32+) + (progn + (buffer-write-byte +fixnum32+ bs) + (buffer-write-int32 frob bs)) + (progn + (buffer-write-byte +fixnum64+ bs) + (buffer-write-int64 frob bs)))))) (null (buffer-write-byte +nil+ bs)) (symbol @@ -397,14 +401,18 @@ (declare (dynamic-extent id maybe-cons) (type fixnum id)) (if maybe-hash maybe-hash - (let ((h (make-hash-table :test (%deserialize bs) - :rehash-size (%deserialize bs) - :rehash-threshold - (%deserialize bs)))) + (let* ((test (%deserialize bs)) + (rehash-size (%deserialize bs)) + (rehash-threshold (%deserialize bs)) + (size (%deserialize bs)) + (h (make-hash-table :test test + :rehash-size rehash-size + :rehash-threshold rehash-threshold + :size (ceiling (* (ceiling (/ (+ size 10) rehash-threshold)) rehash-size))))) (add-object h) - (loop for i fixnum from 0 below (%deserialize bs) + (loop for i fixnum from 0 below size do - (setf (gethash (%deserialize bs) h) + (setf (gethash (%deserialize bs) h) (%deserialize bs))) h)))) ((= tag +object+) @@ -448,7 +456,7 @@ (buffer-read-int32 bs) collect (%deserialize bs)) :element-type (array-type-from-byte - (logand #x3f flags)) + (logand #x1f flags)) :fill-pointer (/= 0 (logand +fill-pointer-p+ flags)) :adjustable (/= 0 (logand +adjustable-p+ @@ -469,8 +477,7 @@ result)))))) (defun deserialize-bignum (bs length positive) - (declare (optimize (speed 3) (safety 2)) - (type buffer-stream bs) + (declare (type buffer-stream bs) (type fixnum length) (type boolean positive)) (loop for i from 0 below (/ length 4)

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 01 Feb '07

01 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv18919/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Finish 64-bit update; clean up memutil; fix array flag type error in SBCL; more efficient and correct hash serialization in new serializer --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/01/31 20:05:37 1.12 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/01 15:19:49 1.13 @@ -36,7 +36,7 @@ (defmethod get-value (key (bt bdb-btree)) (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (let ((buf (db-get-key-buffered (controller-btrees sc) key-buf value-buf))) @@ -45,7 +45,7 @@ (defmethod existsp (key (bt bdb-btree)) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-btrees (get-con bt)) @@ -58,7 +58,7 @@ ;; (with-transaction () (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (serialize value value-buf sc) (db-put-buffered (controller-btrees sc) @@ -69,7 +69,7 @@ ;; (labels ((write-value () ;; (let ((sc (get-con bt))) ;; (with-buffer-streams (key-buf value-buf) -;; (buffer-write-int (oid bt) key-buf) +;; (buffer-write-oid (oid bt) key-buf) ;; (serialize key key-buf sc) ;; (serialize value value-buf sc) ;; (db-put-buffered (controller-btrees sc) @@ -85,7 +85,7 @@ ;; (with-transaction (:store-controller (get-con bt)) (let ((sc (get-con bt)) ) (with-buffer-streams (key-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (db-delete-buffered (controller-btrees sc) key-buf)))) @@ -135,9 +135,9 @@ (let ((sc (get-con bt))) (with-buffer-streams (primary-buf secondary-buf) (flet ((index (key skey) - (buffer-write-int (oid bt) primary-buf) + (buffer-write-oid (oid bt) primary-buf) (serialize key primary-buf sc) - (buffer-write-int (oid index) secondary-buf) + (buffer-write-oid (oid index) secondary-buf) (serialize skey secondary-buf sc) ;; should silently do nothing if ;; the key/value already exists @@ -187,7 +187,7 @@ (let ((sc (get-con bt))) (let ((indices (indices-cache bt))) (with-buffer-streams (key-buf value-buf secondary-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (serialize value value-buf sc) (with-transaction (:store-controller sc) @@ -199,7 +199,7 @@ (funcall (key-fn index) index key value) (when index? ;; Manually write value into secondary index - (buffer-write-int (oid index) secondary-buf) + (buffer-write-oid (oid index) secondary-buf) (serialize secondary-key secondary-buf sc) ;; should silently do nothing if the key/value already ;; exists @@ -213,7 +213,7 @@ "Remove a key / value pair, and update secondary indices." (let ((sc (get-con bt))) (with-buffer-streams (key-buf secondary-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (with-transaction (:store-controller sc) (let ((value (get-value key bt))) @@ -225,7 +225,7 @@ (multiple-value-bind (index? secondary-key) (funcall (key-fn index) index key value) (when index? - (buffer-write-int (oid index) secondary-buf) + (buffer-write-oid (oid index) secondary-buf) (serialize secondary-key secondary-buf sc) ;; need to remove kv pairs with a cursor! -- ;; this is a C performance hack @@ -247,7 +247,7 @@ (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-indices-assoc (get-con bt)) @@ -258,13 +258,13 @@ (defmethod get-primary-key (key (bt btree-index)) (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) + (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (let ((buf (db-get-key-buffered (controller-indices sc) key-buf value-buf))) (if buf - (let ((oid (buffer-read-fixnum buf))) + (let ((oid (buffer-read-oid buf))) (values (deserialize buf sc) oid)) (values nil nil)))))) @@ -298,7 +298,7 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) (deserialize val sc))) @@ -307,11 +307,11 @@ (defmethod cursor-first ((cursor bdb-cursor)) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) @@ -322,7 +322,7 @@ (defmethod cursor-last ((cursor bdb-cursor)) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (buffer-write-oid (+ (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) @@ -330,7 +330,7 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) @@ -339,7 +339,7 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) @@ -353,7 +353,7 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (values t (deserialize key sc) (deserialize val sc)) (setf (cursor-initialized-p cursor) nil))))) @@ -366,7 +366,7 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (values t (deserialize key sc) (deserialize val sc)) (setf (cursor-initialized-p cursor) nil)))) @@ -375,7 +375,7 @@ (defmethod cursor-set ((cursor bdb-cursor) key) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) @@ -389,12 +389,12 @@ (defmethod cursor-set-range ((cursor bdb-cursor) key) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (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))) + (if (and k (= (buffer-read-oid k) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize k sc) (deserialize val sc))) @@ -403,7 +403,7 @@ (defmethod cursor-get-both ((cursor bdb-cursor) key value) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (serialize value value-buf sc) (multiple-value-bind (k v) @@ -418,7 +418,7 @@ (defmethod cursor-get-both-range ((cursor bdb-cursor) key value) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (serialize value value-buf sc) (multiple-value-bind (k v) @@ -436,7 +436,7 @@ (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))) + (when (and key (= (buffer-read-oid key) (cursor-oid cursor))) ;; in case of a secondary index this should delete everything ;; as specified by the BDB docs. (remove-kv (deserialize key (get-con (cursor-btree cursor))) @@ -456,7 +456,7 @@ (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))) + (if (and k (= (buffer-read-oid k) (cursor-oid cursor))) (setf (get-value (deserialize k (get-con (cursor-btree cursor))) (cursor-btree cursor)) @@ -485,35 +485,35 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (let ((sc (get-con (cursor-btree cursor)))) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc))))) + (progn (buffer-read-oid pkey) (deserialize pkey sc))))) (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pfirst ((cursor bdb-secondary-cursor)) (with-buffer-streams (key-buf pkey-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (let ((sc (get-con (cursor-btree cursor)))) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc))))) + (progn (buffer-read-oid pkey) (deserialize pkey sc))))) (setf (cursor-initialized-p cursor) nil))))) ;;A bit of a hack..... (defmethod cursor-plast ((cursor bdb-secondary-cursor)) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf pkey-buf value-buf) - (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) + (buffer-write-oid (+ (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) @@ -521,24 +521,24 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc)))) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-pnext ((cursor bdb-secondary-cursor)) @@ -547,11 +547,11 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (let ((sc (get-con (cursor-btree cursor)))) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc)))) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (setf (cursor-initialized-p cursor) nil)))) (cursor-pfirst cursor))) @@ -561,18 +561,18 @@ (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))) + (if (and key (= (buffer-read-oid key) (cursor-oid cursor))) (let ((sc (get-con (cursor-btree cursor)))) (values t (deserialize key sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc)))) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (setf (cursor-initialized-p cursor) nil)))) (cursor-plast cursor))) (defmethod cursor-pset ((cursor bdb-secondary-cursor) key) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf pkey-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (multiple-value-bind (k pkey val) (db-cursor-pset-buffered (cursor-handle cursor) @@ -581,32 +581,32 @@ (progn (setf (cursor-initialized-p cursor) t) (values t key (deserialize val sc) - (progn (buffer-read-int pkey) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf pkey-buf value-buf) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) (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))) + (if (and k (= (buffer-read-oid k) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) (values t (deserialize k sc) (deserialize val sc) - (progn (buffer-read-int pkey) (deserialize pkey sc)))) + (progn (buffer-read-oid pkey) (deserialize pkey sc)))) (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor)))) (sc (get-con (cursor-btree cursor)))) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) (serialize key key-buf sc) - (buffer-write-int primary-oid pkey-buf) + (buffer-write-oid primary-oid pkey-buf) (serialize pkey pkey-buf sc) (multiple-value-bind (k p val) (db-cursor-pget-both-buffered (cursor-handle cursor) @@ -621,9 +621,9 @@ (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor)))) (sc (get-con (cursor-btree cursor)))) - (buffer-write-int (cursor-oid cursor) key-buf) + (buffer-write-oid (cursor-oid cursor) key-buf) [92 lines skipped]

1 0