From ieslick at common-lisp.net Thu Feb 1 04:03:26 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:03:26 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070201040326.A15124C00A@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv1882 Modified Files: TODO Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte --- /project/elephant/cvsroot/elephant/TODO 2007/01/31 20:05:37 1.38 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/01 04:03:26 1.39 @@ -6,6 +6,11 @@ 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* From ieslick at common-lisp.net Thu Feb 1 04:03:26 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:03:26 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070201040326.35D9583004@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv1882/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/31 22:24:16 1.18 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/01 04:03:26 1.19 @@ -27,8 +27,6 @@ :accessor controller-environment) (oid-db :type (or null pointer-void) :accessor controller-oid-db) (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) - (symid-db :type (or null pointer-void) :accessor controller-symid-db) - (symid-seq :type (or null pointer-void) :accessor controller-symid-seq) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) @@ -117,19 +115,6 @@ :auto-commit t :create t :thread t) (setf (controller-oid-seq sc) oid-seq))) - (let ((db (db-create env))) - (setf (controller-symid-db sc) db) - (db-open db :file "%ELEPHANTSYMID" :database "%ELEPHANTSYMID" - :auto-commit t :type DB-BTREE :create t :thread thread) - (let ((symid-seq (db-sequence-create db))) - (db-sequence-set-cachesize symid-seq *cachesize*) - (db-sequence-set-flags symid-seq :seq-inc t :seq-wrap t) - (db-sequence-set-range symid-seq 0 most-positive-fixnum) - (db-sequence-initial-value symid-seq 0) - (db-sequence-open symid-seq "%ELEPHANTSYMID" - :auto-commit t :create t :thread t) - (setf (controller-symid-seq sc) symid-seq))) - (setf (slot-value sc 'root) (make-instance 'bdb-btree :from-oid -1 :sc sc)) @@ -153,10 +138,6 @@ ;; clean instance cache (flush-instance-cache sc) ;; close handles / environment - (db-sequence-close (controller-symid-seq sc)) - (setf (controller-symid-seq sc) nil) - (db-close (controller-symid-db sc)) - (setf (controller-symid-db sc) nil) (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) (db-close (controller-oid-db sc)) @@ -179,13 +160,6 @@ (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ :auto-commit t :txn-nosync t)) -(defmethod next-symid ((sc bdb-store-controller)) - (declare (type bdb-store-controller sc)) - (db-sequence-get-fixnum (controller-symid-seq sc) 1 :transaction +NULL-VOID+ - :auto-commit t :txn-nosync t)) - - - ;; ;; Automated Deadlock Support ;; From ieslick at common-lisp.net Thu Feb 1 04:03:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:03:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070201040327.7BDE15535E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv1882/src/elephant Modified Files: serializer1.lisp serializer2.lisp Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/21 21:20:04 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/01 04:03:27 1.3 @@ -93,7 +93,8 @@ (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) - (type buffer-stream bs)) + (type buffer-stream bs) + (ignore sc)) (setq *lisp-obj-id* 0) (clear-circularity-hash) (labels --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/31 20:05:38 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/01 04:03:27 1.8 @@ -144,6 +144,9 @@ ;; SERIALIZER ;; +(defconstant +2^32+ 4294967296) +(defconstant +2^64+ 18446744073709551616) + (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare (type buffer-stream bs) @@ -155,9 +158,16 @@ (incf *lisp-obj-id*)) (%serialize (frob) (etypecase frob - ((integer #.most-negative-fixnum #.most-positive-fixnum) - (buffer-write-byte +fixnum32+ bs) - (buffer-write-int frob bs)) + (fixnum ;; (integer #.most-negative-fixnum #.most-positive-fixnum) + ;; Should be compiled away... + (if (< #.most-positive-fixnum +2^32+) + (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)))) (null (buffer-write-byte +nil+ bs)) (symbol @@ -174,7 +184,7 @@ (serialize-string frob bs)) (persistent (buffer-write-byte +persistent+ bs) - (buffer-write-int (oid frob) bs) + (buffer-write-int32 (oid frob) bs) ;; This circumlocution is necessitated by ;; an apparent bug in SBCL 9.9 --- type-of sometimes ;; does NOT return the "proper name" of the class as the @@ -196,10 +206,10 @@ (standard-object (buffer-write-byte +object+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) @@ -220,10 +230,10 @@ (cons (buffer-write-byte +cons+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (car frob)) (%serialize (cdr frob)))))) @@ -234,10 +244,10 @@ (hash-table (buffer-write-byte +hash-table+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (%serialize (hash-table-test frob)) (%serialize (hash-table-rehash-size frob)) @@ -251,9 +261,9 @@ ;; (structure-object ;; (buffer-write-byte +struct+ bs) ;; (let ((idp (gethash frob *circularity-hash*))) - ;; (if idp (buffer-write-int idp bs) + ;; (if idp (buffer-write-int32 idp bs) ;; (progn - ;; (buffer-write-int (incf *lisp-obj-id*) bs) + ;; (buffer-write-int32 (incf *lisp-obj-id*) bs) ;; (setf (gethash frbo *circularity-hash*) *lisp-obj-id*) ;; (%serialize (type-of frob)) ;; (let ((svs (slots-and-values frob))) @@ -264,10 +274,10 @@ (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) + (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) - (buffer-write-int id bs) + (buffer-write-int32 id bs) (setf (gethash frob *circularity-hash*) id)) (buffer-write-byte (logior (byte-from-array-type (array-element-type frob)) @@ -277,12 +287,11 @@ +adjustable-p+ 0)) bs) (let ((rank (array-rank frob))) - (buffer-write-int rank bs) + (buffer-write-int32 rank bs) (loop for i fixnum from 0 below rank - do (buffer-write-int (array-dimension frob i) - bs))) + do (%serialize (array-dimension frob i)))) (when (array-has-fill-pointer-p frob) - (buffer-write-int (fill-pointer frob) bs)) + (%serialize (fill-pointer frob))) (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) @@ -334,8 +343,10 @@ (declare (type foreign-char tag) (dynamic-extent tag)) (cond - ((= tag +fixnum32+) - (buffer-read-fixnum bs)) + ((= tag +fixnum32+) + (buffer-read-fixnum32 bs)) + ((= tag +fixnum64+) + (buffer-read-fixnum64 bs)) ((= tag +nil+) nil) ((= tag +utf8-string+) (deserialize-string :utf8 bs)) @@ -352,7 +363,7 @@ (make-symbol name)))) ((= tag +persistent+) (get-cached-instance sc - (buffer-read-fixnum bs) + (buffer-read-fixnum32 bs) (%deserialize bs))) ((= tag +single-float+) (buffer-read-float bs)) @@ -428,14 +439,14 @@ (%deserialize bs))) o))))))) ((= tag +array+) - (let* ((id (buffer-read-fixnum bs)) + (let* ((id (buffer-read-fixnum32 bs)) (maybe-array (lookup-id id))) (if maybe-array maybe-array (let* ((flags (buffer-read-byte bs)) (a (make-array (loop for i fixnum from 0 below - (buffer-read-int bs) - collect (buffer-read-int bs)) + (buffer-read-int32 bs) + collect (%deserialize bs)) :element-type (array-type-from-byte (logand #x3f flags)) :fill-pointer (/= 0 (logand +fill-pointer-p+ @@ -443,7 +454,7 @@ :adjustable (/= 0 (logand +adjustable-p+ flags))))) (when (array-has-fill-pointer-p a) - (setf (fill-pointer a) (buffer-read-int bs))) + (setf (fill-pointer a) (%deserialize bs))) (add-object a) (loop for i fixnum from 0 below (array-total-size a) do From ieslick at common-lisp.net Thu Feb 1 04:03:29 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:03:29 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070201040329.F199F55396@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv1882/src/memutil Modified Files: libmemutil.c memutil.lisp Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte --- /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2006/11/11 18:41:11 1.2 +++ /project/elephant/cvsroot/elephant/src/memutil/libmemutil.c 2007/02/01 04:03:27 1.3 @@ -57,48 +57,47 @@ #include #include +#include /* Pointer arithmetic utility functions */ -/* should these be in network-byte order? probably not..... */ -int read_int(char *buf, int offset) { - int i; - memcpy(&i, buf+offset, sizeof(int)); - return i; -} - -unsigned int read_uint(char *buf, int offset) { - unsigned int ui; - memcpy(&ui, buf+offset, sizeof(unsigned int)); - return ui; -} -float read_float(char *buf, int offset) { - float f; - memcpy(&f, buf+offset, sizeof(float)); - return f; -} +/* NOTE: Byte order is on a per-machine basis, serialized streams using this + library will not be compatable between little-endian and big-endian platforms */ -double read_double(char *buf, int offset) { - double d; - memcpy(&d, buf+offset, sizeof(double)); - return d; -} +/*------------------------------------------------------------------------------ + reader_and_writer -void write_int(char *buf, int num, int offset) { - memcpy(buf+offset, &num, sizeof(int)); -} + Generates the following code: -void write_uint(char *buf, unsigned int num, int offset) { - memcpy(buf+offset, &num, sizeof(unsigned int)); -} - -void write_float(char *buf, float num, int offset) { - memcpy(buf+offset, &num, sizeof(float)); -} - -void write_double(char *buf, double num, int offset) { - memcpy(buf+offset, &num, sizeof(double)); -} + double read_double(char *buf, int offset) { + double d; + memcpy(&d, buf+offset, sizeof(double)); + return d; + } + void write_double(char *buf, double num, int offset) { + memcpy(buf+offset, &num, sizeof(double)); + } + When called like this: + reader_and_writer(double) +-------------------------------------------------------------------------------- +*/ + +#define reader_and_writer( DATATYPE ) \ +DATATYPE read_##DATATYPE (char *buf, int offset) { \ + DATATYPE i; \ + memcpy(&i, buf+offset, sizeof( DATATYPE )); \ + return i; \ +} \ +void write_##DATATYPE (char *buf, DATATYPE num, int offset) { \ + memcpy(buf+offset, &num, sizeof( DATATYPE )); \ +} + +reader_and_writer(int32_t) +reader_and_writer(uint32_t) +reader_and_writer(int64_t) +reader_and_writer(uint64_t) +reader_and_writer(float) +reader_and_writer(double) char *offset_charp(char *p, int offset) { return p + offset; --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/01/31 20:05:38 1.15 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 04:03:28 1.16 @@ -40,11 +40,17 @@ #:resize-buffer-stream #:resize-buffer-stream-no-copy #:reset-buffer-stream #:buffer-stream-buffer #:buffer-stream-length #:buffer-stream-size - #:buffer-write-byte #:buffer-write-int - #:buffer-write-uint #:buffer-write-float #:buffer-write-double - #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum - #:buffer-read-int #:buffer-read-uint #:buffer-read-float - #:buffer-read-double + + #:buffer-write-byte #:buffer-write-float + #:buffer-write-double #:buffer-write-string + #:buffer-write-int32 #:buffer-write-uint32 + #:buffer-write-int64 #:buffer-write-uint64 + + #:buffer-read-byte #:buffer-read-fixnum32 #:buffer-read-fixnum64 + #:buffer-read-int32 #:buffer-read-uint32 + #:buffer-read-int64 #:buffer-read-uint64 + #:buffer-read-float #:buffer-read-double + #:buffer-read-ucs1-string #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string #+(and sbcl sb-unicode) #:buffer-read-ucs4-string @@ -92,11 +98,12 @@ ;;buffer-stream-buffer buffer-stream-size buffer-stream-position ;;buffer-stream-length reset-buffer-stream - buffer-write-byte buffer-write-int buffer-write-uint + 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-int - buffer-read-uint buffer-read-float buffer-read-double - buffer-read-ucs1-string + buffer-read-byte buffer-read-fixnum buffer-read-int32 + buffer-read-uint32 buffer-read-int64 buffer-read-uint64 + buffer-read-float buffer-read-double buffer-read-ucs1-string #+(or lispworks (and allegro ics)) buffer-read-ucs2-string #+(and sbcl sb-unicode) buffer-read-ucs4-string)) ) @@ -174,7 +181,7 @@ ;; TODO: #+openmcl versions which do macptr arith. #+(or cmu sbcl) -(defun read-int (buf offset) +(defun read-int32 (buf offset) "Read a 32-bit signed integer from a foreign char buffer." (declare (type (alien (* char)) buf) (type fixnum offset)) @@ -183,7 +190,16 @@ (* (signed 32)))))) #+(or cmu sbcl) -(defun read-uint (buf offset) +(defun read-int64 (buf offset) + "Read a 64-bit signed integer from a foreign char buffer." + (declare (type (alien (* char)) buf) + (type fixnum offset)) + (the (signed-byte 64) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (signed 64)))))) + +#+(or cmu sbcl) +(defun read-uint32 (buf offset) "Read a 32-bit unsigned integer from a foreign char buffer." (declare (type (alien (* char)) buf) (type fixnum offset)) @@ -191,6 +207,16 @@ (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) (* (unsigned 32)))))) + +#+(or cmu sbcl) +(defun read-uint64 (buf offset) + "Read a 64-bit unsigned integer from a foreign char buffer." + (declare (type (alien (* char)) buf) + (type fixnum offset)) + (the (signed-byte 64) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (signed 64)))))) + #+(or cmu sbcl) (defun read-float (buf offset) "Read a single-float from a foreign char buffer." @@ -210,7 +236,7 @@ (* double-float))))) #+(or cmu sbcl) -(defun write-int (buf num offset) +(defun write-int32 (buf num offset) "Write a 32-bit signed integer to a foreign char buffer." (declare (type (alien (* char)) buf) (type (signed-byte 32) num) @@ -219,7 +245,16 @@ (* (signed 32)))) num)) #+(or cmu sbcl) -(defun write-uint (buf num offset) +(defun write-int64 (buf num offset) + "Write a 64-bit signed integer to a foreign char buffer." + (declare (type (alien (* char)) buf) + (type (signed-byte 64) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (signed 64)))) num)) + +#+(or cmu sbcl) +(defun write-uint32 (buf num offset) "Write a 32-bit unsigned integer to a foreign char buffer." (declare (type (alien (* char)) buf) (type (unsigned-byte 32) num) @@ -228,6 +263,14 @@ (* (unsigned 32)))) num)) #+(or cmu sbcl) +(defun write-uint64 (buf num offset) + "Write a 64-bit unsigned integer to a foreign char buffer." + (declare (type (alien (* char)) buf) + (type (unsigned-byte 64) num) + (type fixnum offset)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (* (unsigned 64)))) num)) +#+(or cmu sbcl) (defun write-float (buf num offset) "Write a single-float to a foreign char buffer." (declare (type (alien (* char)) buf) @@ -253,18 +296,30 @@ (sap-alien (sap+ (alien-sap p) offset) (* char))) #-(or cmu sbcl) -(def-function ("read_int" read-int) +(def-function ("read_int32" read-int32) ((buf array-or-pointer-char) (offset :int)) :returning :int) #-(or cmu sbcl) -(def-function ("read_uint" read-uint) +(def-function ("read_uint32" read-uint32) ((buf array-or-pointer-char) (offset :int)) :returning :unsigned-int) #-(or cmu sbcl) +(def-function ("read_int64" read-int64) + ((buf array-or-pointer-char) + (offset :int)) + :returning :long) + +#-(or cmu sbcl) +(def-function ("read_uint64" read-uint64) + ((buf array-or-pointer-char) + (offset :int)) + :returning :unsigned-long) + +#-(or cmu sbcl) (def-function ("read_float" read-float) ((buf array-or-pointer-char) (offset :int)) @@ -277,20 +332,34 @@ :returning :double) #-(or cmu sbcl) -(def-function ("write_int" write-int) +(def-function ("write_int32" write-int32) ((buf array-or-pointer-char) (num :int) (offset :int)) :returning :void) #-(or cmu sbcl) -(def-function ("write_uint" write-uint) +(def-function ("write_uint32" write-uint32) ((buf array-or-pointer-char) (num :unsigned-int) (offset :int)) :returning :void) #-(or cmu sbcl) +(def-function ("write_int64" write-int64) + ((buf array-or-pointer-char) + (num :long) + (offset :int)) + :returning :void) + +#-(or cmu sbcl) +(def-function ("write_uint64" write-uint64) + ((buf array-or-pointer-char) + (num :unsigned-long) + (offset :int)) + :returning :void) + +#-(or cmu sbcl) (def-function ("write_float" write-float) ((buf array-or-pointer-char) (num :float) @@ -482,7 +551,7 @@ (setf (deref-array buf '(:array :char) size) b) (setf size needed)))) -(defun buffer-write-int (i bs) +(defun buffer-write-int32 (i bs) "Write a 32-bit signed integer." (declare (type buffer-stream bs) (type (signed-byte 32) i)) @@ -493,11 +562,11 @@ (let ((needed (+ size 4))) (when (> needed len) (resize-buffer-stream bs needed)) - (write-int buf i size) + (write-int32 buf i size) (setf size needed) nil))) -(defun buffer-write-uint (u bs) +(defun buffer-write-uint32 (u bs) "Write a 32-bit unsigned integer." (declare (type buffer-stream bs) (type (unsigned-byte 32) u)) @@ -508,7 +577,37 @@ (let ((needed (+ size 4))) (when (> needed len) (resize-buffer-stream bs needed)) - (write-uint buf u size) + (write-uint32 buf u size) + (setf size needed) + nil))) + +(defun buffer-write-int64 (i bs) + "Write a 64-bit signed integer." + (declare (type buffer-stream bs) + (type (signed-byte 64) i)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-int64 buf i size) + (setf size needed) + nil))) + +(defun buffer-write-uint64 (u bs) + "Write a 64-bit unsigned integer." + (declare (type buffer-stream bs) + (type (unsigned-byte 64) u)) + (with-struct-slots ((buf buffer-stream-buffer) + (size buffer-stream-size) + (len buffer-stream-length)) + bs + (let ((needed (+ size 8))) + (when (> needed len) + (resize-buffer-stream bs needed)) + (write-uint64 buf u size) (setf size needed) nil))) @@ -600,28 +699,73 @@ (writable (max vlen (- size position)))) (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)) + +(defun buffer-read-int (bs) + ;; deprecated, better to use explicit int32 or int64 version + (buffer-read-int32 bs)) (defun buffer-read-fixnum (bs) + ;; deprecated, better to use explicit int32 or int64 version + (the fixnum (buffer-read-fixnum32 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) + ;; deprecated, better to use explicit int32 or int64 version + (buffer-write-uint32 bs int)) + +(defconstant +2^32+ 4294967296) +(defconstant +2^64+ 18446744073709551616) + +(defun buffer-read-fixnum32 (bs) "Read a 32-bit signed integer, which is assumed to be a fixnum." (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) (the fixnum (read-int (buffer-stream-buffer bs) position)))) -(defun buffer-read-int (bs) +(defun buffer-read-int32 (bs) "Read a 32-bit signed integer." (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) - (the (signed-byte 32) (read-int (buffer-stream-buffer bs) position)))) + (the (signed-byte 32) (read-int32 (buffer-stream-buffer bs) position)))) -(defun buffer-read-uint (bs) +(defun buffer-read-uint32 (bs) "Read a 32-bit unsigned integer." (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) - (the (unsigned-byte 32)(read-uint (buffer-stream-buffer bs) position)))) + (the (unsigned-byte 32)(read-uint32 (buffer-stream-buffer bs) position)))) + +(defun buffer-read-fixnum64 (bs) + (declare (type buffer-stream bs)) + (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)))) + (the fixnum (read-int64 (buffer-stream-buffer bs) position))))) + +(defun buffer-read-int64 (bs) + "Read a 64-bit signed integer." + (declare (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 8)) + (the (signed-byte 64) (read-int64 (buffer-stream-buffer bs) position)))) + +(defun buffer-read-uint64 (bs) + "Read a 64-bit unsigned integer." + (declare (type buffer-stream bs)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position 8)) + (the (unsigned-byte 64) (read-uint64 (buffer-stream-buffer bs) position)))) (defun buffer-read-float (bs) "Read a single-float." From ieslick at common-lisp.net Thu Feb 1 04:03:30 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:03:30 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070201040330.8123F6104A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv1882/tests Modified Files: testserializer.lisp Log Message: Added 64-bit support, verified for 32-bit lisp via Allegro/Mac OS X. Thanks to Henrik Hjelte --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/01/22 16:17:44 1.12 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 04:03:30 1.13 @@ -391,5 +391,4 @@ (eq (get-value f2 h) f2)))) t t t t t t t t) - From ieslick at common-lisp.net Thu Feb 1 04:37:25 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:37:25 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070201043725.F12774717F@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv6719/src/memutil Modified Files: memutil.lisp Log Message: Package name fixes caught by SBCL tests --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 04:03:28 1.16 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 04:37:25 1.17 @@ -45,8 +45,12 @@ #:buffer-write-double #:buffer-write-string #:buffer-write-int32 #:buffer-write-uint32 #:buffer-write-int64 #:buffer-write-uint64 + #:buffer-write-int #:buffer-write-uint - #:buffer-read-byte #:buffer-read-fixnum32 #:buffer-read-fixnum64 + #:buffer-read-byte #:buffer-read-fixnum + #: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 @@ -728,7 +732,7 @@ (declare (type buffer-stream bs)) (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position 4)) - (the fixnum (read-int (buffer-stream-buffer bs) position)))) + (the fixnum (read-int32 (buffer-stream-buffer bs) position)))) (defun buffer-read-int32 (bs) "Read a 32-bit signed integer." From ieslick at common-lisp.net Thu Feb 1 04:37:26 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 31 Jan 2007 23:37:26 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070201043726.2E2B24814A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv6719/tests Modified Files: testserializer.lisp Log Message: Package name fixes caught by SBCL tests --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 04:03:30 1.13 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 04:37:25 1.14 @@ -391,4 +391,33 @@ (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 From ieslick at common-lisp.net Thu Feb 1 15:19:50 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 1 Feb 2007 10:19:50 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070201151950.190192E1BE@common-lisp.net> 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] From ieslick at common-lisp.net Thu Feb 1 15:19:50 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 1 Feb 2007 10:19:50 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070201151950.501CC36012@common-lisp.net> 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) From ieslick at common-lisp.net Thu Feb 1 15:19:50 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 1 Feb 2007 10:19:50 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070201151950.8EBBF3A01B@common-lisp.net> 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))) + + From ieslick at common-lisp.net Thu Feb 1 15:19:50 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 1 Feb 2007 10:19:50 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070201151950.C6F084C045@common-lisp.net> 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 From rread at common-lisp.net Fri Feb 2 22:39:23 2007 From: rread at common-lisp.net (rread) Date: Fri, 2 Feb 2007 17:39:23 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070202223923.41E3961026@common-lisp.net> 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) )) From ieslick at common-lisp.net Fri Feb 2 23:51:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 18:51:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070202235158.2823E1E010@common-lisp.net> 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 From ieslick at common-lisp.net Fri Feb 2 23:51:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 18:51:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070202235158.6E14E1E06F@common-lisp.net> 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 , at 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 , at 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] From ieslick at common-lisp.net Fri Feb 2 23:51:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 18:51:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070202235158.ABB761E010@common-lisp.net> 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))) From ieslick at common-lisp.net Fri Feb 2 23:52:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 18:52:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070202235200.17EF41F00E@common-lisp.net> 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 () , at 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 () , at 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*))) - , at body)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Utilities ;; get rid of spot idx and adjust the arrray (defun remove-indexed-element-and-adjust (idx array) From ieslick at common-lisp.net Fri Feb 2 23:52:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 18:52:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070202235200.A83E41F003@common-lisp.net> 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) From ieslick at common-lisp.net Sat Feb 3 00:47:23 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:47:23 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070203004723.9DF1215146@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv11740/utils Log Message: Directory /project/elephant/cvsroot/elephant/src/utils added to the repository From ieslick at common-lisp.net Sat Feb 3 00:57:33 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:33 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070203005733.EC7C11C0C4@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv12026 Modified Files: TODO elephant.asd Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/TODO 2007/02/02 23:51:58 1.40 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/03 00:57:33 1.41 @@ -7,9 +7,6 @@ -------------------------------------------- Active tasks: -- 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) - 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] @@ -64,6 +61,9 @@ ---------------------------------- Feburary 2nd, 2007 checkins: +x Support locks in serializer for all systems + x Provide support for fast and slow critical sections by lisps: buffer-streams, + circularity-arrays/hashes, shared controller side-effects... (see email) 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 --- /project/elephant/cvsroot/elephant/elephant.asd 2007/01/29 15:15:04 1.25 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/03 00:57:33 1.26 @@ -155,15 +155,19 @@ :components ((:module :src :components - ((:module memutil + ((:module utils + :components + ((:file "package") + (:file "locks"))) + (:module memutil :components ((:elephant-c-source "libmemutil") (:file "memutil")) - :serial t) + :serial t + :depends-on (utils)) (:module elephant :components ((:file "package") - (:file "cross-platform") #+cmu (:file "cmu-mop-patches") #+openmcl (:file "openmcl-mop-patches") (:file "variables") @@ -182,6 +186,6 @@ (:file "migrate") (:file "backend")) :serial t - :depends-on (memutil))))) + :depends-on (memutil utils))))) :depends-on (:uffi :cl-base64)) From ieslick at common-lisp.net Sat Feb 3 00:57:34 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:34 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070203005734.2AFE01F000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv12026/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/02 23:51:58 1.20 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/03 00:57:33 1.21 @@ -111,8 +111,7 @@ (db-sequence-set-flags oid-seq :seq-inc t :seq-wrap t) (db-sequence-set-range oid-seq 0 most-positive-fixnum) (db-sequence-initial-value oid-seq 0) - (db-sequence-open oid-seq "%ELEPHANTOID" - :auto-commit t :create t :thread t) + (db-sequence-open oid-seq "%ELEPHANTOID" :create t :thread t) (setf (controller-oid-seq sc) oid-seq))) (setf (slot-value sc 'root) From ieslick at common-lisp.net Sat Feb 3 00:57:34 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:34 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070203005734.9B70424007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv12026/src/elephant Modified Files: package.lisp serializer2.lisp Removed Files: cross-platform.lisp Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/02 23:51:58 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/03 00:57:34 1.10 @@ -20,7 +20,7 @@ (in-package :cl-user) (defpackage elephant - (:use common-lisp elephant-memutil) + (:use :common-lisp :elephant-memutil :elephant-utils) (:nicknames ele :ele) (:documentation "Elephant: an object-oriented database for Common Lisp with @@ -93,9 +93,6 @@ #:drop-instances ;; Utilities - #:ele-make-lock - #:ele-with-lock - #:ele-without-interrupts #:slots-and-values ) #+cmu --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/02 23:51:58 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/03 00:57:34 1.11 @@ -17,7 +17,7 @@ (in-package :elephant) (defpackage :elephant-serializer2 - (:use :cl :elephant :elephant-memutil) + (:use :cl :elephant :elephant-memutil :elephant-utils) (:import-from :elephant *circularity-initial-hash-size* #+(or cmu sbcl allegro) @@ -97,12 +97,14 @@ (defparameter *circularity-hash-queue* (make-array 20 :fill-pointer 0 :adjustable t) "Circularity ids for the serializer.") +(defvar *serializer-fast-lock* (ele-make-fast-lock)) + (defun get-circularity-hash () "Get a clean hash for object serialization" (declare (type fixnum *circularity-initial-hash-size*)) (if (= 0 (length *circularity-hash-queue*)) (make-hash-table :test 'eq :size *circularity-initial-hash-size*) - (ele-without-interrupts + (ele-with-fast-lock (*serializer-fast-lock*) (vector-pop *circularity-hash-queue*)))) (defun release-circularity-hash (hash) @@ -110,7 +112,7 @@ (declare (type hash-table hash)) (unless (= (hash-table-count hash) 0) (clrhash hash)) - (ele-without-interrupts + (ele-with-fast-lock (*serializer-fast-lock*) (vector-push-extend hash *circularity-hash-queue*))) ;; @@ -129,14 +131,14 @@ (if (= 0 (length *circularity-vector-queue*)) (make-array 50 :element-type t :initial-element nil :fill-pointer 0 :adjustable t) - (ele-without-interrupts + (ele-with-fast-lock (*serializer-fast-lock*) (vector-pop *circularity-vector-queue*)))) (defun release-circularity-vector (vector) "Don't need to erase, just reset fill-pointer as it determines extent of valid data" (setf (fill-pointer vector) 0) - (ele-without-interrupts + (ele-with-fast-lock (*serializer-fast-lock*) (vector-push-extend vector *circularity-vector-queue* 20))) ;; From ieslick at common-lisp.net Sat Feb 3 00:57:34 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:34 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070203005734.CD52224053@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv12026/src/memutil Modified Files: memutil.lisp Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/01 15:19:50 1.18 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 00:57:34 1.19 @@ -21,7 +21,7 @@ (:documentation "A low-level UFFI-based memory access and serialization toolkit. Provides basic cross-platform binary serialization support for backends.") - (:use common-lisp uffi) + (:use common-lisp uffi elephant-utils) #+cmu (:use alien) #+sbcl @@ -121,22 +121,15 @@ (defvar +NULL-CHAR+ (make-null-pointer :char) "A null pointer to a char type.") - -(defmacro memutil-without-interrupts (&body body) - "Ensure platform dependent atomicity" - `( - #+allegro excl:without-interrupts - #+lispworks lispworks:without-interrupts - #+sbcl sb-sys:without-interrupts - #+cmu system:without-interrupts - #+openmcl ccl:without-interrupts - , at body)) - +;; ;; Thread local storage (special variables) +;; (defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) "Vector of buffer-streams, which you can grab / return.") +(defvar *buffer-streams-lock* (ele-make-fast-lock)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; buffer-streams @@ -156,13 +149,13 @@ "Grab a buffer-stream from the *buffer-streams* resource pool." (if (= (length *buffer-streams*) 0) (make-buffer-stream) - (memutil-without-interrupts + (ele-with-fast-lock (*buffer-streams-lock*) (vector-pop *buffer-streams*)))) (defun return-buffer-stream (bs) "Return a buffer-stream to the *buffer-streams* resource pool." (reset-buffer-stream bs) - (memutil-without-interrupts + (ele-with-fast-lock (*buffer-streams-lock*) (vector-push-extend bs *buffer-streams*))) (defmacro with-buffer-streams (names &body body) From ieslick at common-lisp.net Sat Feb 3 00:57:35 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:35 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070203005735.28A522B02C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv12026/src/utils Added Files: locks.lisp package.lisp Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/src/utils/locks.lisp 2007/02/03 00:57:35 NONE +++ /project/elephant/cvsroot/elephant/src/utils/locks.lisp 2007/02/03 00:57:35 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; cross-platform.lisp -- convert Lisp data to/from byte arrays ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :elephant-utils) ;; This is a quick portability hack to avoid external dependencies, if we get ;; too many of these do we need to import a standard library? do we need to import ;; 'port' or some other thread layer to the elephant dependency list? (defun ele-make-lock () #+allegro (mp::make-process-lock) #+cmu (mp:make-lock) #+sbcl (sb-thread:make-mutex) #+mcl (ccl:make-lock) #+lispworks (mp:make-lock) #-(or allegro sbcl cmu lispworks mcl) nil ) (defmacro ele-with-lock ((lock &rest ignored) &body body) (declare (ignore ignored) (ignorable lock)) #+allegro `(mp:with-process-lock (,lock) , at body) #+cmu `(mp:with-lock-held (,lock) , at body) #+sbcl `(sb-thread:with-mutex (,lock) , at body) #+lispworks `(mp:with-lock (,lock) , at body) #+mcl `(ccl:with-lock-grabbed (,lock) , at body) #-(or allegro sbcl cmu lispworks mcl) `(progn , at body) ) ;; ;; For tight loops we need a fast lock, for lisps that support this ;; with-interrupts or something similar this can help performance ;; (defun ele-make-fast-lock () #+allegro nil #-allegro (ele-make-lock)) (defmacro ele-with-fast-lock ((lock &rest ignored) &body body) (declare (ignorable lock ignored)) #+allegro `(excl:without-interrupts , at body) #-allegro `(ele-with-lock (,lock , at ignored) , at body)) --- /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/03 00:57:35 NONE +++ /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/03 00:57:35 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; package.lisp -- package definition ;;; ;;; Initial version 2/3/2007 by Ian Eslick ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :cl-user) (defpackage elephant-utils (:use common-lisp) (:export #:ele-make-lock #:ele-with-lock #:ele-make-fast-lock #:ele-with-fast-lock)) From ieslick at common-lisp.net Sat Feb 3 00:57:35 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 19:57:35 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070203005735.683BF2E1D5@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv12026/tests Modified Files: testbdb.lisp Log Message: Fixed bug from last checkin; implemented abstraction for fast-locks for systems that have such a thing (such as without-interrupts in non-parallel lisps) --- /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/02 23:52:00 1.3 +++ /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/03 00:57:35 1.4 @@ -70,8 +70,7 @@ (db-bdb::db-sequence-set-flags seq :seq-inc t :seq-wrap t) (db-bdb::db-sequence-set-range seq 0 most-positive-fixnum) (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) + (db-bdb::db-sequence-open seq "testseq1" :create t :thread 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) From ieslick at common-lisp.net Sat Feb 3 04:09:14 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 23:09:14 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070203040914.158F116035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv11297/src/elephant Modified Files: controller.lisp unicode2.lisp Log Message: Clean up auto-commit usage in tests; change buffer-stream to unsigned-char - this may break things for sbcl but works for Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/02 23:51:58 1.27 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/03 04:09:13 1.28 @@ -119,8 +119,8 @@ (unless *store-controller* (setq *store-controller* controller)) (load-user-configuration controller) - (apply #'open-controller controller args) (initialize-serializer controller) + (apply #'open-controller controller args) controller)) (defun close-store (&optional sc) --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/02 23:51:58 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/03 04:09:13 1.4 @@ -112,16 +112,20 @@ (let ((code (char-code (schar string i)))) (when (> code #xFFFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size)) +;; (coerce (ldb (byte 8 8) code) '(signed 8))) (ldb (byte 8 8) code)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size 1)) +;; (coerce (ldb (byte 8 0) code) '(signed 8)))))) (ldb (byte 8 0) code))))) (string (loop for i fixnum from 0 below characters do - (let ((code (char-code (char string i)))) + (let ((code (char-code (schar string i)))) (when (> code #xFFFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size)) +;; (coerce (ldb (byte 8 8) code) '(signed 8))) (ldb (byte 8 8) code)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ (* i 2) size 1)) +;; (coerce (ldb (byte 8 0) code) '(signed 8))))))) (ldb (byte 8 0) code)))))) (incf size (* characters 2)) (succeed)))))) From ieslick at common-lisp.net Sat Feb 3 04:09:14 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 23:09:14 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070203040914.4E5601703F@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv11297/src/memutil Modified Files: memutil.lisp Log Message: Clean up auto-commit usage in tests; change buffer-stream to unsigned-char - this may break things for sbcl but works for Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 00:57:34 1.19 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 04:09:14 1.20 @@ -77,8 +77,8 @@ (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) (def-foreign-type array-or-pointer-char - #+allegro (:array :char) - #+(or cmu sbcl scl openmcl) (* :char)) + #+allegro (:array :unsigned-char) + #+(or cmu sbcl scl openmcl) (* :unsigned-char)) (def-type array-or-pointer-char array-or-pointer-char) ;; Standard utility for copying two foreign buffers -- From ieslick at common-lisp.net Sat Feb 3 04:09:16 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 2 Feb 2007 23:09:16 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070203040916.69EFC1A0A2@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv11297/tests Modified Files: mop-tests.lisp testcollections.lisp testindexing.lisp testmigration.lisp Log Message: Clean up auto-commit usage in tests; change buffer-stream to unsigned-char - this may break things for sbcl but works for Allegro on Mac OS X --- /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2006/02/19 04:53:02 1.11 +++ /project/elephant/cvsroot/elephant/tests/mop-tests.lisp 2007/02/03 04:09:14 1.12 @@ -151,15 +151,13 @@ t) (deftest initform-test - (let ((*auto-commit* t)) - (slot-value (make-instance 'p-initform-test :sc *store-controller*) 'slot1)) + (slot-value (make-instance 'p-initform-test :sc *store-controller*) 'slot1) 10) (deftest initarg-test - (let ((*auto-commit* t)) - (values - (slot-value (make-instance 'p-initform-test-2 :sc *store-controller*) 'slot1) - (slot-value (make-instance 'p-initform-test-2 :slot1 20 :sc *store-controller*) 'slot1))) + (values + (slot-value (make-instance 'p-initform-test-2 :sc *store-controller*) 'slot1) + (slot-value (make-instance 'p-initform-test-2 :slot1 20 :sc *store-controller*) 'slot1)) 10 20) (deftest no-eval-initform @@ -167,8 +165,7 @@ (defclass no-eval-initform () ((slot1 :initarg :slot1 :initform (error "Shouldn't be called"))) (:metaclass persistent-metaclass)) - (let ((*auto-commit* t)) - (make-instance 'no-eval-initform :slot1 "something" :sc *store-controller* )) + (make-instance 'no-eval-initform :slot1 "something" :sc *store-controller* ) t) t) @@ -192,8 +189,7 @@ (defclass update-class () ((slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) - (let* ((*auto-commit* t) - (foo (make-instance 'update-class :sc *store-controller*))) + (let* ((foo (make-instance 'update-class :sc *store-controller*))) (defclass update-class () ((slot2 :initform 2 :accessor slot2)) (:metaclass persistent-metaclass)) @@ -213,8 +209,7 @@ (slot2 :initform 2 :accessor slot2)) (:metaclass persistent-metaclass)) - (let* ((*auto-commit* t) - (foo (make-instance 'class-one :sc *store-controller*))) + (let* ((foo (make-instance 'class-one :sc *store-controller*))) (change-class foo (find-class 'class-two)) (values (slot1 foo) @@ -246,8 +241,7 @@ (slot2 :initform 2 :accessor slot2)) (:metaclass persistent-metaclass)) - (let* ((*auto-commit* t) - (foo (make-instance 'class-one :sc *store-controller*))) + (let* ((foo (make-instance 'class-one :sc *store-controller*))) (change-class foo (find-class 'class-two)) (values (slot1 foo) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2006/11/11 18:41:11 1.13 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/03 04:09:14 1.14 @@ -15,20 +15,15 @@ (in-package :ele-tests) (deftest basicpersistence - (let ((*prev-commit* *auto-commit*) - (*auto-commit* t) - (rv nil)) - (unwind-protect - (let ((x (gensym))) - (add-to-root "x" x) - ;; Clear instances - (flush-instance-cache *store-controller*) - ;; Are gensyms equal across db instantiations? - ;; This forces a refetch of the object from db - (setq rv (equal (format nil "~A" x) - (format nil "~A" (get-from-root "x"))))) - (progn - (setq *auto-commit* *prev-commit*))) + (let ((rv nil)) + (let ((x (gensym))) + (add-to-root "x" x) + ;; Clear instances + (flush-instance-cache *store-controller*) + ;; Are gensyms equal across db instantiations? + ;; This forces a refetch of the object from db + (setq rv (equal (format nil "~A" x) + (format nil "~A" (get-from-root "x"))))) rv) t) @@ -626,26 +621,19 @@ (deftest add-get-remove (let ((r1 '()) - (r2 '()) - (*prev-commit* *auto-commit*)) - (unwind-protect - (progn - (setq *auto-commit* t) - (add-to-root "x1" "y1") - (add-to-root "x2" "y2") - (setf r1 (get-from-root "x1")) - (setf r2 (get-from-root "x2")) - (remove-from-root "x1") - (remove-from-root "x2") - (and - (equal "y1" r1) - (equal "y2" r2) - (equal nil (get-from-root "x1")) - (equal nil (get-from-root "x2")) - ) - ) - (setq *auto-commit* *prev-commit*) - )) + (r2 '())) + (add-to-root "x1" "y1") + (add-to-root "x2" "y2") + (setf r1 (get-from-root "x1")) + (setf r2 (get-from-root "x2")) + (remove-from-root "x1") + (remove-from-root "x2") + (and + (equal "y1" r1) + (equal "y2" r2) + (equal nil (get-from-root "x1")) + (equal nil (get-from-root "x2")) + )) t) (deftest add-get-remove-symbol @@ -654,52 +642,34 @@ (f1 '()) (f2 '()) (b1 '()) - (b2 '()) - (*prev-commit* *auto-commit*)) - (unwind-protect - (progn - (setq *auto-commit* t) - (add-to-root "my key" foo) - (add-to-root "my other key" foo) - (setf f1 (get-from-root "my key")) - (setf f2 (get-from-root "my other key")) - (add-to-root "my key" bar) - (add-to-root "my other key" bar) - (setf b1 (get-from-root "my key")) - (setf b2 (get-from-root "my other key")) - (and - (equal f1 f2) - (equal b1 b2) - (equal f1 foo) - (equal b1 bar) - )) - (setq *auto-commit* *prev-commit*) - )) + (b2 '())) + (add-to-root "my key" foo) + (add-to-root "my other key" foo) + (setf f1 (get-from-root "my key")) + (setf f2 (get-from-root "my other key")) + (add-to-root "my key" bar) + (add-to-root "my other key" bar) + (setf b1 (get-from-root "my key")) + (setf b2 (get-from-root "my other key")) + (and + (equal f1 f2) + (equal b1 b2) + (equal f1 foo) + (equal b1 bar))) t) (deftest existsp (let ((exists1 '()) (exists2 '()) (exists3 '()) - (key "my key") - (*prev-commit* *auto-commit*) - ) - (unwind-protect - (progn - (setq *auto-commit* t) - (remove-from-root key) - (setf exists1 - (root-existsp key) - ) - (add-to-root key 'a) - (setf exists2 (root-existsp key)) - (remove-from-root key) - (setf exists3 (root-existsp key)) - ) - (setq *auto-commit* *prev-commit*) - ) - (values exists1 exists2 exists3) - ) + (key "my key")) + (remove-from-root key) + (setf exists1 (root-existsp key)) + (add-to-root key 'a) + (setf exists2 (root-existsp key)) + (remove-from-root key) + (setf exists3 (root-existsp key)) + (values exists1 exists2 exists3)) nil t nil ) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/01/25 19:37:55 1.21 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/03 04:09:14 1.22 @@ -72,7 +72,6 @@ (let ((n 105)) ;;(format t "Global vars:~%") ;;(format t "~%basic store: ~A ~A~%" *store-controller* (elephant::controller-spec *store-controller*)) -;; (format t "auto-commit: ~A~%" *auto-commit*) (when (class-indexedp-by-name 'idx-one) (disable-class-indexing 'idx-one :errorp nil) @@ -289,11 +288,7 @@ &key) (setf (slot3 new) (slot2 old))) - (let ((*auto-commit* t) - (foo nil)) - (declare (special *auto-commit*) - (dynamic-extent *auto-commit*)) - (setf foo (make-instance 'idx-six)) + (let ((foo (make-instance 'idx-six))) (change-class foo 'idx-seven) (values --- /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2006/04/26 19:19:12 1.13 +++ /project/elephant/cvsroot/elephant/tests/testmigration.lisp 2007/02/03 04:09:14 1.14 @@ -35,7 +35,6 @@ (format t "~%Single store mode: ignoring") t) (let* ((*store-controller*) - (*auto-commit* t) (sc1 (open-store *test-spec-primary* :recover t)) (sc2 (open-store *test-spec-secondary* :recover t))) (unwind-protect @@ -56,10 +55,9 @@ (format t "~%Single store mode: ignoring") nil) (let ((*store-controller* nil) - (*auto-commit* t) (sc1 (open-store *test-spec-primary* :recover t)) (sc2 (open-store *test-spec-secondary* :recover t))) - (declare (special *store-controller* *auto-commit*)) + (declare (special *store-controller*)) (unwind-protect (let ((ibt (make-btree sc1))) (with-transaction (:store-controller sc1) @@ -81,12 +79,9 @@ t) (let ((old-store *store-controller*) (*store-controller* nil) - (*prev-commit* *auto-commit*) - (*auto-commit* t) (rv nil) (sc1 (open-store *test-spec-primary* :recover t)) (sc2 (open-store *test-spec-secondary* :recover t))) - (declare (special *auto-commit*)) (unwind-protect (let* ((ibt (make-indexed-btree sc1))) (let ((index @@ -111,7 +106,6 @@ (not (btree-differ ibt mig))))) (progn (setq *store-controller* old-store) - (setq *auto-commit* *prev-commit*) (close-store sc1) (close-store sc2))))) t) @@ -123,11 +117,10 @@ (progn (format t "~%Single store mode: ignoring") t) - (let ((*auto-commit* t) - (*store-controller* nil) + (let ((*store-controller* nil) (sc1 (open-store *test-spec-primary* :recover t)) (sc2 (open-store *test-spec-secondary* :recover t))) - (declare (special *auto-commit* *store-controller*)) + (declare (special *store-controller*)) (unwind-protect (progn ;; Make instances @@ -163,11 +156,10 @@ (values 3 1 1 1 1 10 20 )) (progn ;; (format t "Opening store~%") - (let ((*auto-commit* nil) - (sc2 (open-store *test-spec-secondary* :recover t)) + (let ((sc2 (open-store *test-spec-secondary* :recover t)) (sc1 (open-store *test-spec-primary* :recover t)) (*store-controller* nil)) - (declare (special *auto-commit* *store-controller*)) + (declare (special *store-controller*)) (unwind-protect ;; ensure class index is initialized in sc1 (progn From ieslick at common-lisp.net Sat Feb 3 14:07:01 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 09:07:01 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070203140701.7204515145@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv25441/src/elephant Modified Files: backend.lisp Log Message: Fix SBCL type issues by converting buffer stream from char to unsigned-char --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/02 23:51:58 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/03 14:07:01 1.9 @@ -123,8 +123,6 @@ #:cursor-oid #:cursor-initialized-p ;; Transactions - #:*transaction-stack* - #:*auto-commit* #:*current-transaction* #:execute-transaction #:controller-start-transaction From ieslick at common-lisp.net Sat Feb 3 14:07:01 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 09:07:01 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070203140701.A888919001@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv25441/src/memutil Modified Files: memutil.lisp Log Message: Fix SBCL type issues by converting buffer stream from char to unsigned-char --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 04:09:14 1.20 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 14:07:01 1.21 @@ -140,7 +140,7 @@ (defstruct buffer-stream "A stream-like interface to foreign (alien) char buffers." - (buffer (allocate-foreign-object :char 10) :type array-or-pointer-char) + (buffer (allocate-foreign-object :unsigned-char 10) :type array-or-pointer-char) (size 0 :type fixnum) (position 0 :type fixnum) (length 10 :type fixnum)) @@ -183,117 +183,117 @@ #+(or cmu sbcl) (defun read-int32 (buf offset) "Read a 32-bit signed integer from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the (signed-byte 32) - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (signed 32)))))) #+(or cmu sbcl) (defun read-int64 (buf offset) "Read a 64-bit signed integer from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the (signed-byte 64) - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (signed 64)))))) #+(or cmu sbcl) (defun read-uint32 (buf offset) "Read a 32-bit unsigned integer from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the (unsigned-byte 32) - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (unsigned 32)))))) #+(or cmu sbcl) (defun read-uint64 (buf offset) "Read a 64-bit unsigned integer from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the (signed-byte 64) - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (signed 64)))))) #+(or cmu sbcl) (defun read-float (buf offset) "Read a single-float from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the single-float - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* single-float))))) #+(or cmu sbcl) (defun read-double (buf offset) "Read a double-float from a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type fixnum offset)) (the double-float - (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* double-float))))) #+(or cmu sbcl) (defun write-int32 (buf num offset) "Write a 32-bit signed integer to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type (signed-byte 32) num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (signed 32)))) num)) #+(or cmu sbcl) (defun write-int64 (buf num offset) "Write a 64-bit signed integer to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type (signed-byte 64) num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (signed 64)))) num)) #+(or cmu sbcl) (defun write-uint32 (buf num offset) "Write a 32-bit unsigned integer to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type (unsigned-byte 32) num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (unsigned 32)))) num)) #+(or cmu sbcl) (defun write-uint64 (buf num offset) "Write a 64-bit unsigned integer to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type (unsigned-byte 64) num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* (unsigned 64)))) num)) #+(or cmu sbcl) (defun write-float (buf num offset) "Write a single-float to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type single-float num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* single-float))) num)) #+(or cmu sbcl) (defun write-double (buf num offset) "Write a double-float to a foreign char buffer." - (declare (type (alien (* char)) buf) + (declare (type (alien (* unsigned-char)) buf) (type double-float num) (type fixnum offset)) - (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* char)) + (setf (deref (cast (sap-alien (sap+ (alien-sap buf) offset) (* unsigned-char)) (* double-float))) num)) #+(or cmu sbcl) (defun offset-char-pointer (p offset) "Pointer arithmetic." - (declare (type (alien (* char)) p) + (declare (type (alien (* unsigned-char)) p) (type fixnum offset)) - (sap-alien (sap+ (alien-sap p) offset) (* char))) + (sap-alien (sap+ (alien-sap p) offset) (* unsigned-char))) #-(or cmu sbcl) (def-function ("read_int32" read-int32) @@ -502,7 +502,7 @@ (when (> length len) (let ((newlen (max length (* len 2)))) (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) + (let ((newbuf (allocate-foreign-object :unsigned-char newlen))) ;; technically we just need to copy from position to size..... (when (null-pointer-p newbuf) (error "Failed to allocate buffer stream of length ~A. allocate-foreign-object returned a null pointer" newlen)) @@ -523,7 +523,7 @@ (when (> length len) (let ((newlen (max length (* len 2)))) (declare (type fixnum newlen)) - (let ((newbuf (allocate-foreign-object :char newlen))) + (let ((newbuf (allocate-foreign-object :unsigned-char newlen))) (when (null-pointer-p newbuf) (error "Failed to allocate buffer stream of length ~A. allocate-foreign-object returned a null pointer" newlen)) (free-foreign-object buf) From ieslick at common-lisp.net Sat Feb 3 14:07:01 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 09:07:01 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070203140701.ED07019001@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv25441/tests Modified Files: testserializer.lisp Log Message: Fix SBCL type issues by converting buffer stream from char to unsigned-char --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/01 15:19:50 1.15 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/03 14:07:01 1.16 @@ -430,8 +430,7 @@ (:metaclass persistent-metaclass)) (deftest persistent - (let* ((*auto-commit* t) - (f1 (make-instance 'pfoo :sc *store-controller*)) + (let* ((f1 (make-instance 'pfoo :sc *store-controller*)) (f2 (make-instance 'pfoo :slot1 "this is a string" :sc *store-controller*)) (b1 (make-instance 'pbar :slot2 "another string" :sc *store-controller*)) (b2 (make-instance 'pbar :sc *store-controller*)) From rread at common-lisp.net Sun Feb 4 00:07:45 2007 From: rread at common-lisp.net (rread) Date: Sat, 3 Feb 2007 19:07:45 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070204000745.9E9255535E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv12286 Modified Files: testcollections.lisp Log Message: Checking in a better tests, with a lot of debugging stuff included for now. --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/03 04:09:14 1.14 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/04 00:07:45 1.15 @@ -174,7 +174,7 @@ (let ((obj (get-value 1 index1))) (and (= (slot1 obj) 1) - (= (slot2 obj) (* 1 100))))) + (= (slot2 obj) (* 1 100))))) t) (deftest indexed-get-from-slot1 @@ -384,8 +384,8 @@ t) (defun crunch (s k v) - (declare (ignore s v)) - (values t (floor (/ k 10)))) + (declare (ignore s k)) + (values t (floor (/ (- v) 10)))) (deftest add-indices2 (finishes @@ -408,18 +408,38 @@ t) (deftest get-from-index3 - (loop for i from 0 to 1000 - always (= (* i -10) (get-value i index3))) - t) + (let ((v)) +;; (trace get-value) +;; (trace crunch) + (unwind-protect + (setf v (loop for i from 0 to 1000 +;; always (= (- i) (floor (/ (get-value i index3) 10))))) + always + (multiple-value-bind (bool res) + (crunch nil nil (get-value i index3)) + (= res i)))) +;; (untrace)) + ) + v) + t) (deftest dup-test (with-transaction (:store-controller *store-controller*) - (with-btree-cursor (curs index3) - (loop for (more k v) = (multiple-value-list - (cursor-first curs)) - then (multiple-value-list (cursor-next-dup curs)) - while more - collect v))) + (unwind-protect + (progn +;; (trace cursor-first) +;; (trace cursor-next-dup) +;; (trace db-clsql::sql-get-from-clcn-nth) +;; (trace db-clsql::has-key-value-scnd) + (with-btree-cursor (curs index3) + (loop for (more k v) = (multiple-value-list + (cursor-first curs)) + then (multiple-value-list (cursor-next-dup curs)) + while more + collect v))) + (untrace) + ) + ) (0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) @@ -466,6 +486,14 @@ ;; Note: If this is not done inside a transaction, ;; it HANGS BDB! (with-transaction (:store-controller *store-controller*) + (unwind-protect + (progn +;; (trace cursor-first) +;; (trace cursor-next-dup) +;; (trace cursor-last) +;; (trace cursor-delete) +;; (trace get-value) +;; (trace has-key-value) (let* ((ibt (make-indexed-btree *store-controller*)) (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) (loop for i from 0 to 10 @@ -478,15 +506,21 @@ (cursor-last c) (cursor-delete c) ) - (equal - (list - (get-value 4 ibt) - (get-value 5 ibt) - (get-value 9 ibt) - (get-value 10 ibt) - ) - '(16 25 nil 100)) + (let ((res + (equal + (list + (get-value 4 ibt) + (get-value 5 ibt) + (get-value 9 ibt) + (get-value 10 ibt) + ) + '(16 25 81 nil)))) + (untrace) + res + ) )) + ) + ) t) (deftest indexed-delete @@ -525,23 +559,45 @@ (deftest cur-del2 - (with-transaction (:store-controller *store-controller*) - (let* ((ibt (make-indexed-btree *store-controller*)) - (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (with-btree-cursor (c id1) - (cursor-first c) - (cursor-next-dup c) - (cursor-delete c) - ) - (equal (list - (get-value 1 id1) ;; - (get-value 0 id1) ;; This should be 0, but is returning nil! - ) - '(1 0)) - )) + (unwind-protect + (with-transaction (:store-controller *store-controller*) + (let* ((ibt (make-indexed-btree *store-controller*)) + (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) + (progn + (untrace) +;; (trace cursor-first) +;; (trace cursor-next-dup) +;; (trace cursor-last) +;; (trace cursor-delete) +;; (trace get-value) +;; (trace cursor-current) +;; (trace db-clsql::cursor-initialized-p) +;; (trace remove-kv) +;; (trace db-clsql::cursor-next-dup-x) +;; (trace db-clsql::has-key-value-scnd) +;; (trace db-clsql::sql-from-clcn-key-and-value-existsp) +;; (trace db-clsql::sql-add-to-clcn) +;; (trace odd) +;; (trace crunch) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (with-btree-cursor (c id1) + (cursor-first c) + (cursor-next-dup c) + (cursor-delete c) + ) + (let ((res + (equal (list + (get-value 1 id1) ;; + (get-value 0 id1) ;; This should be 0, but is returning nil! + ) + '(1 0)))) + (untrace) + res) + ) + )) + (untrace)) t) From ieslick at common-lisp.net Sun Feb 4 04:34:56 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 23:34:56 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070204043456.5A9CE15145@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv16382 Modified Files: TODO Log Message: char to unsigned char fix in BDB; cleaned up modular serializer initialization in BDB and SQL backends and main protocol --- /project/elephant/cvsroot/elephant/TODO 2007/02/03 00:57:33 1.41 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/04 04:34:56 1.42 @@ -7,9 +7,14 @@ -------------------------------------------- Active tasks: +- Fix (cursor-last) bug to Robert's new test +- Fix indexing-timing, delete-instances bug reported by Robert + - 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] +- Fix *dbconnection-spec* to support multiple controllers for multiple threads + for CLSQL backend BDB Features: ? Determine how to detect deadlock conditions as an optional run-safe mode? @@ -60,6 +65,11 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- +February 3rd, 2007 checkins: +x Finished char -> unsigned char for buffer streams to solve SBCL type problems +x Finished new serializer-initialization and open-controller protocol to handle + subtle issues in database metadata and the user of the serializer + Feburary 2nd, 2007 checkins: x Support locks in serializer for all systems x Provide support for fast and slow critical sections by lisps: buffer-streams, From ieslick at common-lisp.net Sun Feb 4 04:34:56 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 23:34:56 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070204043456.A2C4D1701C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv16382/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp libberkeley-db.c Log Message: char to unsigned char fix in BDB; cleaned up modular serializer initialization in BDB and SQL backends and main protocol --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/02 23:51:58 1.14 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/04 04:34:56 1.15 @@ -151,7 +151,7 @@ (continue t)) (loop while continue do - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) (with-btree-cursor (cursor bt) (if last-key (cursor-set cursor last-key) @@ -190,7 +190,7 @@ (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) (serialize value value-buf sc) - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) (db-put-buffered (controller-btrees sc) key-buf value-buf) (loop for index being the hash-value of indices @@ -215,7 +215,7 @@ (with-buffer-streams (key-buf secondary-buf) (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value (let ((indices (indices-cache bt))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/03 00:57:33 1.21 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/04 04:34:56 1.22 @@ -22,15 +22,16 @@ (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))) (defclass bdb-store-controller (store-controller) - ((db :type (or null pointer-void) :accessor controller-db :initform '()) - (environment :type (or null pointer-void) + ((environment :type (or null pointer-void) :accessor controller-environment) - (oid-db :type (or null pointer-void) :accessor controller-oid-db) - (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) + (metadata :type (or null pointer-void) :accessor controller-metadata) + (db :type (or null pointer-void) :accessor controller-db :initform '()) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) :accessor controller-indices-assoc) + (oid-db :type (or null pointer-void) :accessor controller-oid-db) + (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) (deadlock-pid :accessor controller-deadlock-pid :initform nil) (deadlock-input :accessor controller-deadlock-input :initform nil)) (:documentation "Class of objects responsible for the @@ -62,9 +63,11 @@ ;; (defmethod open-controller ((sc bdb-store-controller) &key (recover nil) - (recover-fatal nil) (thread t) ;; (errfile nil) + (recover-fatal nil) (thread t) (deadlock-detect nil)) - (let ((env (db-env-create))) + (let ((env (db-env-create)) + (new-p (not (probe-file (make-pathname :defaults (second (controller-spec sc)) + :name "%ELEPHANT"))))) (setf (controller-environment sc) env) (db-env-set-flags env 0 :auto-commit t) (db-env-open env (namestring (second (controller-spec sc))) @@ -74,10 +77,25 @@ ) (db-env-set-timeout env 100000 :set-transaction-timeout t) (db-env-set-timeout env 100000 :set-lock-timeout t) - (let ((db (db-create env)) + (let ((metadata (db-create env)) + (db (db-create env)) (btrees (db-create env)) (indices (db-create env)) (indices-assoc (db-create env))) + + ;; Open metadata database + (setf (controller-metadata sc) metadata) + (db-open metadata :file "%ELEPHANT" :database "%METADATA" + :auto-commit t :type DB-BTREE :create t :thread t) + + ;; Establish database version if new + (when new-p (set-database-version sc)) + + ;; Initialize serializer so we can load proper sorting C function + ;; based on serializer type + (initialize-serializer sc) + + ;; Open main class, slot-value and index databases (setf (controller-db sc) db) (db-open db :file "%ELEPHANT" :database "%ELEPHANTDB" :auto-commit t :type DB-BTREE :create t :thread thread) @@ -120,9 +138,6 @@ (setf (slot-value sc 'class-root) (make-instance 'bdb-btree :from-oid -2 :sc sc)) -;; (when errfile -;; (db-set-error-file (controller-db sc) errfile)) - (when deadlock-detect (start-deadlock-detector sc)) @@ -149,6 +164,8 @@ (setf (controller-btrees sc) nil) (db-close (controller-db sc)) (setf (controller-db sc) nil) + (db-close (controller-metadata sc)) + (setf (controller-metadata sc) nil) (db-env-close (controller-environment sc)) (setf (controller-environment sc) nil) nil)) @@ -160,6 +177,44 @@ :txn-nosync t)) ;; +;; Store the database version +;; +;; For BDB this can be in a file; different backends may require a different approach. + +(defmethod database-version ((sc bdb-store-controller)) + "Elephant protocol to provide the version tag or nil if unmarked" + (with-buffer-streams (key val) + (serialize-database-version-key key) + (let ((buf (db-get-key-buffered (controller-metadata sc) + key val))) + (if buf (deserialize-database-version-value buf) + nil)))) + +(defun set-database-version (sc) + "Internal use when creating new database" + (with-buffer-streams (key val) + (serialize-database-version-key key) + (serialize-database-version-value *elephant-code-version* val) + (db-put-buffered (controller-metadata sc) + key val) + *elephant-code-version*)) + +;; (defmethod old-database-version ((sc bdb-store-controller)) +;; "A version determination for a given store +;; controller that is independant of the serializer as the +;; serializer is dispatched based on the code version which is a +;; list of the form '(0 6 0)" +;; (let ((version (elephant::controller-version-cached sc))) +;; (if version version +;; (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) +;; (if (probe-file path) +;; (with-open-file (stream path :direction :input) +;; (setf (elephant::controller-version-cached sc) (read stream))) +;; (with-open-file (stream path :direction :output) +;; (setf (elephant::controller-version-cached sc) +;; (write *elephant-code-version* :stream stream)))))))) + +;; ;; Automated Deadlock Support ;; @@ -242,20 +297,3 @@ :free-space free-space))) (values (deserialize end ctrl)))) -;; Store the serializer version. For BDB this can be in a file; different backends -;; may require a different approach. -(defmethod database-version ((sc bdb-store-controller)) - "A version determination for a given store - controller that is independant of the serializer as the - serializer is dispatched based on the code version which is a - list of the form '(0 6 0)" - (let ((version (elephant::controller-version-cached sc))) - (if version version - (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) - (if (probe-file path) - (with-open-file (stream path :direction :input) - (setf (elephant::controller-version-cached sc) (read stream))) - (with-open-file (stream path :direction :output) - (setf (elephant::controller-version-cached sc) - (write *elephant-code-version* :stream stream)))))))) - --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/31 20:05:37 1.7 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/02/04 04:34:56 1.8 @@ -67,94 +67,94 @@ /* should these be in network-byte order? probably not..... */ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ -int read_int(char *buf, int offset) { +int read_int(unsigned char *buf, int offset) { int i; memcpy(&i, buf+offset, sizeof(int)); return i; } -int read_uint(char *buf, int offset) { +int read_uint(unsigned char *buf, int offset) { unsigned int ui; memcpy(&ui, buf+offset, sizeof(unsigned int)); return ui; } -int32_t read_int32(char *buf, int offset) { +int32_t read_int32(unsigned char *buf, int offset) { int32_t i; memcpy(&i, buf+offset, sizeof(int32_t)); return i; } -uint32_t read_uint32(char *buf, int offset) { +uint32_t read_uint32(unsigned char *buf, int offset) { uint32_t ui; memcpy(&ui, buf+offset, sizeof(uint32_t)); return ui; } -int64_t read_int64(char *buf, int offset) { +int64_t read_int64(unsigned char *buf, int offset) { int64_t i; memcpy(&i, buf+offset, sizeof(int64_t)); return i; } -uint64_t read_uint64(char *buf, int offset) { +uint64_t read_uint64(unsigned char *buf, int offset) { uint64_t ui; memcpy(&ui, buf+offset, sizeof(uint64_t)); return ui; } -float read_float(char *buf, int offset) { +float read_float(unsigned char *buf, int offset) { float f; memcpy(&f, buf+offset, sizeof(float)); return f; } -double read_double(char *buf, int offset) { +double read_double(unsigned char *buf, int offset) { double d; memcpy(&d, buf+offset, sizeof(double)); return d; } /* Platform specific integer */ -void write_int(char *buf, int num, int offset) { +void write_int(unsigned char *buf, int num, int offset) { memcpy(buf+offset, &num, sizeof(int)); } -void write_uint(char *buf, unsigned int num, int offset) { +void write_uint(unsigned char *buf, unsigned int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); } /* Well-defined integer widths */ -void write_int32(char *buf, int32_t num, int offset) { +void write_int32(unsigned char *buf, int32_t num, int offset) { memcpy(buf+offset, &num, sizeof(int32_t)); } -void write_uint32(char *buf, uint32_t num, int offset) { +void write_uint32(unsigned char *buf, uint32_t num, int offset) { memcpy(buf+offset, &num, sizeof(uint32_t)); } -void write_int64(char *buf, int64_t num, int offset) { +void write_int64(unsigned char *buf, int64_t num, int offset) { memcpy(buf+offset, &num, sizeof(int64_t)); } -void write_uint64(char *buf, uint64_t num, int offset) { +void write_uint64(unsigned char *buf, uint64_t num, int offset) { memcpy(buf+offset, &num, sizeof(uint64_t)); } -void write_float(char *buf, float num, int offset) { +void write_float(unsigned char *buf, float num, int offset) { memcpy(buf+offset, &num, sizeof(float)); } -void write_double(char *buf, double num, int offset) { +void write_double(unsigned char *buf, double num, int offset) { memcpy(buf+offset, &num, sizeof(double)); } -char *offset_charp(char *p, int offset) { +unsigned char *offset_charp(unsigned char *p, int offset) { return p + offset; } -void copy_buf(char *dest, int dest_offset, char *src, int src_offset, +void copy_buf(unsigned char *dest, int dest_offset, unsigned char *src, int src_offset, int length) { memcpy(dest + dest_offset, src + src_offset, length); } @@ -177,7 +177,7 @@ return envp; } -char * db_strerr(int error) { +char *db_strerr(int error) { return db_strerror(error); } @@ -275,8 +275,8 @@ /* We manage our own buffers (DB_DBT_USERMEM). */ int db_get_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_size, - char *buffer, u_int32_t buffer_length, + unsigned char *key, u_int32_t key_size, + unsigned char *buffer, u_int32_t buffer_length, u_int32_t flags, u_int32_t *result_size) { DBT DBTKey, DBTValue; int ret; @@ -296,8 +296,8 @@ } int db_put_raw(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_size, - char *value, u_int32_t value_size, + unsigned char *key, u_int32_t key_size, + unsigned char *value, u_int32_t value_size, u_int32_t flags) { DBT DBTKey, DBTValue; @@ -312,7 +312,7 @@ } int db_del(DB *db, DB_TXN *txnid, - char *key, u_int32_t key_size, + unsigned char *key, u_int32_t key_size, u_int32_t flags) { DBT DBTKey; @@ -323,10 +323,10 @@ } int db_compact(DB *db, DB_TXN *txnid, - char *start, u_int32_t start_size, - char *stop, u_int32_t stop_size, + unsigned char *start, u_int32_t start_size, + unsigned char *stop, u_int32_t stop_size, u_int32_t flags, - char *end, u_int32_t end_length, + unsigned char *end, u_int32_t end_length, u_int32_t *end_size) { DBT DBTStart, DBTStop, DBTEnd; int errno; @@ -380,9 +380,9 @@ } int db_cursor_get_raw(DBC *cursor, - char *keybuf, u_int32_t keybuf_size, + unsigned char *keybuf, u_int32_t keybuf_size, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_size, + unsigned char *buffer, u_int32_t buffer_size, u_int32_t buffer_length, u_int32_t flags, u_int32_t *ret_key_size, u_int32_t *result_size) { @@ -408,11 +408,11 @@ } int db_cursor_pget_raw(DBC *cursor, - char *keybuf, u_int32_t keybuf_size, + unsigned char *keybuf, u_int32_t keybuf_size, u_int32_t keybuf_length, - char *pkeybuf, u_int32_t pkeybuf_size, + unsigned char *pkeybuf, u_int32_t pkeybuf_size, u_int32_t pkeybuf_length, - char *buffer, u_int32_t buffer_size, + unsigned char *buffer, u_int32_t buffer_size, u_int32_t buffer_length, u_int32_t flags, u_int32_t *ret_key_size, @@ -446,8 +446,8 @@ } int db_cursor_put_raw(DBC *cursor, - char *key, u_int32_t key_size, - char *value, u_int32_t value_size, + unsigned char *key, u_int32_t key_size, + unsigned char *value, u_int32_t value_size, u_int32_t flags) { DBT DBTKey, DBTValue; @@ -465,8 +465,8 @@ /* Silently does nothing if the key/value isn't found. Can't use auto-commit here! */ int db_del_kv(DB *db, DB_TXN *tid, - char *key, u_int32_t key_size, - char *value, u_int32_t value_size) { + unsigned char *key, u_int32_t key_size, + unsigned char *value, u_int32_t value_size) { DBT DBTKey, DBTValue; DBC *cursor; int ret, c_ret; @@ -495,9 +495,9 @@ /* Bulk retrieval */ int db_cursor_get_multiple_key(DBC *cursor, - char *keybuf, u_int32_t keybuf_size, + unsigned char *keybuf, u_int32_t keybuf_size, u_int32_t keybuf_length, - char *buffer, u_int32_t buffer_size, + unsigned char *buffer, u_int32_t buffer_size, u_int32_t buffer_length, u_int32_t flags, u_int32_t *ret_key_size, u_int32_t *result_size, @@ -568,7 +568,7 @@ } int db_sequence_open(DB_SEQUENCE *seq, DB_TXN *txnid, - char *key, u_int32_t key_size, u_int32_t flags) { + unsigned char *key, u_int32_t key_size, u_int32_t flags) { DBT DBTKey; memset(&DBTKey, 0, sizeof(DBT)); DBTKey.data = key; @@ -667,7 +667,7 @@ } int db_env_lock_get(DB_ENV *env, u_int32_t locker, - u_int32_t flags, char *object, u_int32_t object_size, + u_int32_t flags, unsigned char *object, u_int32_t object_size, const db_lockmode_t lock_mode, DB_LOCK *lock) { DBT DBTObject; memset(&DBTObject, 0, sizeof(DBT)); @@ -728,8 +728,8 @@ /* Poor man's counters */ int next_counter(DB_ENV *env, DB *db, DB_TXN *parent, - char *key, u_int32_t key_size, - char *lockid, u_int32_t lockid_size) { + unsigned char *key, u_int32_t key_size, + unsigned char *lockid, u_int32_t lockid_size) { DB_LOCK lock; DBT DBTKey, DBTData; DB_TXN *tid; @@ -822,12 +822,14 @@ #include -double read_num(char *buf); -int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2); +#define S_RESERVED 0xF0 + +double read_num(unsigned char *buf); +int case_cmp(const unsigned char *a, int32_t length1, const unsigned char *b, int32_t length2); int wcs_cmp(const wchar_t *a, int32_t length1, const wchar_t *b, int32_t length2); -int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2); -int utf16_cmp(const char *s1, int32_t length1, - const char *s2, int32_t length2); +int lex_cmp(const unsigned char *a, int32_t length1, const unsigned char *b, int32_t length2); +int utf16_cmp(const unsigned char *s1, int32_t length1, + const unsigned char *s2, int32_t length2); #define S1_FIXNUM 1 #define S1_CHAR 2 @@ -867,9 +869,9 @@ int lisp_compare1(DB *dbp, const DBT *a, const DBT *b) { int difference; double ddifference; - char *ad, *bd, at, bt; - ad = (char*)a->data; - bd = (char*)b->data; + unsigned char *ad, *bd, at, bt; + ad = (unsigned char *)a->data; + bd = (unsigned char *)b->data; /* Compare OIDs. */ difference = read_int(ad, 0) - read_int(bd, 0); @@ -877,7 +879,7 @@ /* Have a type tag? */ if (a->size == 4) - if (b->size == 4) + if (b->size == 4) return 0; else return -1; @@ -903,6 +905,8 @@ switch (at) { case S1_NIL: /* nil */ return 0; + case S_RESERVED: + return ad[5] < bd[5]; /* different tags */ case S1_UCS1_SYMBOL: /* 8-bit symbol */ case S1_UCS1_STRING: /* 8-bit string */ case S1_UCS1_PATHNAME: /* 8-bit pathname */ @@ -924,8 +928,8 @@ #define exp2(c) (pow(2,(c))) #endif -double read_num(char *buf) { - char *limit; +double read_num(unsigned char *buf) { + unsigned char *limit; double i, result, denom; switch (buf[0]) { case S1_FIXNUM: @@ -1026,6 +1030,7 @@ #define S2_STRUCT 20 #define S2_CLASS 21 #define S2_NIL 0x3F + #define S2_FILL_POINTER_P 0x40 #define S2_ADJUSTABLE_P 0x80 @@ -1040,16 +1045,16 @@ *****/ -double read_num2(char *buf); +double read_num2(unsigned char *buf); /* New serializer */ int lisp_compare2(DB *dbp, const DBT *a, const DBT *b) { int difference; int offset; double ddifference; - char *ad, *bd, at, bt; - ad = (char*)a->data; - bd = (char*)b->data; + unsigned char *ad, *bd, at, bt; + ad = (unsigned char *)a->data; + bd = (unsigned char *)b->data; /* Compare OIDs: OIDs are limited by native integer width */ difference = read_int(ad, 0) - read_int(bd, 0); @@ -1103,6 +1108,8 @@ switch (at) { case S2_NIL: /* nil */ return 0; + case S_RESERVED: + return ad[5] < bd[5]; /* different tags */ case S2_UTF8_STRING: /* 8-bit string */ return case_cmp(ad+9+offset, read_int32(ad+offset, 5), bd+9+offset, read_int32(bd+offset, 5)); case S2_UTF16_STRING: /* 16-bit string */ @@ -1134,8 +1141,8 @@ } } -double read_num2(char *buf) { - char *limit; +double read_num2(unsigned char *buf) { + unsigned char *limit; double i, result, denom; switch (buf[0]) { case S2_FIXNUM32: @@ -1219,11 +1226,11 @@ typedef unsigned short uint16_t; #endif -int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { +int case_cmp(const unsigned char *a, int32_t length1, const unsigned char *b, int32_t length2) { int min, sizediff, diff; sizediff = length1 - length2; min = sizediff > 0 ? length2 : length1; - diff = strncasecmp(a, b, min); + diff = strncasecmp((char *)a, (char *)b, min); if (diff == 0) return sizediff; return diff; } @@ -1238,7 +1245,7 @@ return diff; } -int lex_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { +int lex_cmp(const unsigned char *a, int32_t length1, const unsigned char *b, int32_t length2) { int min, sizediff, diff; sizediff = length1 - length2; min = sizediff > 0 ? length2 : length1; @@ -1258,9 +1265,9 @@ /* compare UTF-16 strings */ /* memcmp/UnicodeString style, both length-specified */ /* don't assume byte-aligned! */ -int utf16_cmp(const char *s1, int32_t length1, - const char *s2, int32_t length2) { - const char *start1, *start2, *limit1, *limit2; [6 lines skipped] From ieslick at common-lisp.net Sun Feb 4 04:34:56 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 23:34:56 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070204043456.D5EF11703B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv16382/src/db-clsql Modified Files: sql-controller.lisp Log Message: char to unsigned char fix in BDB; cleaned up modular serializer initialization in BDB and SQL backends and main protocol --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/02 23:51:58 1.14 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/04 04:34:56 1.15 @@ -238,7 +238,7 @@ ;; ALL OF THIS needs to be inside a transaction. (clsql::create-table [version] '( - ([serializerversion] text :not-null) + ([dbversion] text :not-null) ) :database con ) ) @@ -313,34 +313,34 @@ controller that is independant of the serializer as the serializer is dispatched based on the code version which is a list of the form '(0 6 0)" - (let* ((con (controller-db sc)) - (version (elephant::controller-version-cached sc))) - (if version version - (let ((tuples - (clsql::select [serializerversion] - :from [version] - :database con))) - ;; The table should exists, but there may or may not be a record there... - (setf (elephant::controller-version-cached sc) - (if tuples - (read-from-string (caar tuples)) - (clsql::insert-records :into [version] - :attributes '(serializerversion) - :values (list (format nil "~A" *elephant-code-version*)) - :database con) - ) - ))))) + (let* ((con (controller-db sc))) + (let ((tuples + (clsql::select [dbversion] + :from [version] + :database con))) + ;; The table should exists, but there may or may not be a record there... + (if tuples + (read-from-string (caar tuples)) + nil)))) + +(defun set-database-version (sc) + (let ((con (controller-db sc))) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" *elephant-code-version*)) + :database con))) (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key (recover nil) - (recover-fatal nil) + (recover-fatal nil) (thread t)) (declare (ignore recover recover-fatal thread)) (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) + (new-p (not (probe-file (cadr (second (controller-spec sc)))))) (con (clsql:connect (cdr (second (controller-spec sc))) :database-type dbtype :if-exists :old))) @@ -353,7 +353,9 @@ (unless (version-table-exists con) (with-transaction (:store-controller sc) (create-version-table con))) - (elephant::initialize-serializer sc) + ;; Set elephant version if new + (when new-p (set-database-version sc)) + (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-btree :sc sc :from-oid 1)) From ieslick at common-lisp.net Sun Feb 4 04:34:57 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 3 Feb 2007 23:34:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070204043457.2B7BA1701C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16382/src/elephant Modified Files: controller.lisp package.lisp serializer.lisp serializer1.lisp serializer2.lisp Log Message: char to unsigned char fix in BDB; cleaned up modular serializer initialization in BDB and SQL backends and main protocol --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/03 04:09:13 1.28 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/04 04:34:57 1.29 @@ -98,48 +98,6 @@ (asdf:operate 'asdf:load-op dep))) dep-list)) -;; ================================================ -;; -;; USER API TO CONTROLLER OPS -;; -;; ================================================ - - -;; -;; Open a Store -;; - -(defun open-store (spec &rest args) - "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)) - (let ((controller (get-controller spec))) - (unless *store-controller* - (setq *store-controller* controller)) - (load-user-configuration controller) - (initialize-serializer controller) - (apply #'open-controller controller args) - controller)) - -(defun close-store (&optional sc) - "Conveniently close the store controller." - (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, -unconditionally closing the controller on exit." - `(let ((*store-controller* nil)) - (declare (special *store-controller*)) - (open-store ,spec) - (unwind-protect - (progn , at body) - (close-store *store-controller*)))) - ;; ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; @@ -160,7 +118,6 @@ (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) (serialize :accessor controller-serialize :initform nil) (deserialize :accessor controller-deserialize :initform nil) @@ -170,25 +127,25 @@ handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera.")) -;; User configuration parameters for the controller - -(defun load-user-configuration (controller) - ;; Placeholder - (declare (ignorable controller)) - nil) - -(defun initialize-serializer (sc) - "Establish serializer version on controller startup" - (cond ((prior-version-p (database-version sc) '(0 6 0)) - (setf (controller-serializer-version sc) 1) - (setf (controller-serialize sc) 'elephant-serializer1::serialize) - (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) - (t - (setf (controller-serializer-version sc) 2) - (setf (controller-serialize sc) 'elephant-serializer2::serialize) - (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)))) - +;; +;; Database versioning +;; +(defgeneric database-version (sc) + (:documentation "Backends implement this to store the serializer version. + The protocol requires that backends report their database + version. On new database creation, the database is written with the + *elephant-code-version* so that is returned by database-version. + If a legacy database does not have a version according to the method + then it should return nil")) + +(defmethod database-version :around (sc) + "Default version assumption for unmarked databases is 0.6.0" +;; NOTE: It is possible to check for 0.5.0 databases, but it is not +;; implemented now due to the low (none?) number of users still on 0.5.0" + (let ((db-version (call-next-method))) + (if db-version db-version + '(0 6 0)))) (defun prior-version-p (v1 v2) "Is v1 an equal or earlier version than v2" @@ -197,42 +154,73 @@ ((and (not (null v1)) (null v2)) nil) ((< (car v1) (car v2)) t) ((> (car v1) (car v2)) nil) - ((= (car v1) (car v2)) + ((= (car v1) (car v2)) (prior-version-p (cdr v1) (cdr v2))) - (t (error "Version problem!")))) + (t (error "Version comparison problem: (prior-version-p ~A ~A)" v1 v2)))) ;; -;; OBJECT CACHE +;; Database upgrade paths ;; -(defun cache-instance (sc obj) - "Cache a persistent object with the controller." - (declare (type store-controller sc)) - (ele-with-lock ((instance-cache-lock sc)) - (setf (get-cache (oid obj) (instance-cache sc)) obj))) +(defparameter *elephant-upgrade-table* + '( ((0 6 0) (0 5 0)) + ((0 6 1) (0 6 0)) + )) -(defun get-cached-instance (sc oid class-name) - "Get a cached instance, or instantiate!" - (declare (type store-controller sc) - (type fixnum oid)) - (let ((obj (get-cache oid (instance-cache sc)))) - (if obj obj - ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name nil) - :from-oid oid :sc sc)))) +(defmethod up-to-date-p ((sc store-controller)) + (equal (database-version sc) *elephant-code-version*)) -(defmethod flush-instance-cache ((sc store-controller)) - "Reset the instance cache (flush object lookups). Useful - for testing. Does not reclaim existing objects so there - will be duplicate instances with identical functionality" - (ele-with-lock ((instance-cache-lock sc)) - (setf (instance-cache sc) - (make-cache-table :test 'eql)))) +(defmethod upgradable-p ((sc store-controller)) + "Determine if this store can be brought up to date using the upgrade function" + (unwind-protect + (let ((row (assoc *elephant-code-version* *elephant-upgrade-table* :test #'equal)) + (ver (database-version sc))) + (when (member ver (rest row) :test #'equal)) t) + nil)) + +(defmethod upgrade ((sc store-controller) target-spec) + (unless (upgradable-p sc) + (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" + (controller-spec sc) + (database-version sc) + *elephant-code-version* + *elephant-upgrade-table*)) + (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your + data does not require any unsupported features") + (let ((source sc) + (target (open-store target-spec))) + (migrate target source) + (close-store target))) + + +;; +;; Modular serializer support and default serializers for a version +;; + +(defmethod initialize-serializer ((sc store-controller)) + "Establish serializer version on controller startup. Backends call this before + they need the serializer to be valid and after they enable their database-version + call. If the backend shadows this, it has to keep track of serializer versions + associated with the database version that is opened." + (cond ((prior-version-p (database-version sc) '(0 6 0)) + (setf (controller-serializer-version sc) 1) + (setf (controller-serialize sc) 'elephant-serializer1::serialize) + (setf (controller-deserialize sc) 'elephant-serializer1::deserialize)) + (t + (setf (controller-serializer-version sc) 2) + (setf (controller-serialize sc) 'elephant-serializer2::serialize) + (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)))) + +;; +;; Handling package changes in legacy databases +;; (defparameter *legacy-conversions-db* - '((("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) + '(;; 0.5.0 support + (("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")) + ;; 0.6.0 support (("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree")) (("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree")) (("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index")))) @@ -252,19 +240,40 @@ (defun string-pair->symbol (name) (intern (string-upcase (cdr name)) (car name))) - - ;; -;; VERSIONING +;; Per-controller instance caching ;; -(defgeneric database-version (sc) - (:documentation "Backends implement this to store the serializer version") - ) +(defun cache-instance (sc obj) + "Cache a persistent object with the controller." + (declare (type store-controller sc)) + (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!" + (declare (type store-controller sc) + (type fixnum oid)) + (let ((obj (get-cache oid (instance-cache sc)))) + (if obj obj + ;; Should get cached since make-instance calls cache-instance + (make-instance (handle-legacy-classes class-name nil) + :from-oid oid :sc sc)))) +(defmethod flush-instance-cache ((sc store-controller)) + "Reset the instance cache (flush object lookups). Useful + for testing. Does not reclaim existing objects so there + will be duplicate instances with identical functionality" + (ele-with-lock ((instance-cache-lock sc)) + (setf (instance-cache sc) + (make-cache-table :test 'eql)))) + + +;; ================================================================================ ;; -;; STORE CONTROLLER PROTOCOL -;; +;; BACKEND STORE CONTROLLER PROTOCOL +;; +;; ================================================================================ (defgeneric open-controller (sc &key recover recover-fatal thread &allow-other-keys) (:documentation @@ -276,6 +285,11 @@ "Close the db handles and environment. Tries to wipe out references to the db handles.")) +(defmethod close-controller :after ((sc store-controller)) + "Delete connection spec so store-controller operations on cached + controller information fail" + (remhash (controller-spec sc) *dbconnection-spec*)) + (defgeneric connection-is-indeed-open (controller) (:documentation "Validate the controller and the db that it is connected to") (:method ((controller t)) t)) @@ -289,9 +303,70 @@ "Tell the backend to reclaim any storage caused by key deletion, if possible. This should default to return space to the filesystem rather than just to the free list.")) +;; +;; Low-level support for metaclass protocol +;; + +(defgeneric persistent-slot-reader (sc instance name) + (:documentation + "Backend specific slot reader function")) + +(defgeneric persistent-slot-writer (sc new-value instance name) + (:documentation + "Backend specific slot writer function")) +(defgeneric persistent-slot-boundp (sc instance name) + (:documentation + "Backend specific slot bound test function")) + +(defgeneric persistent-slot-makunbound (sc instance name) + (:documentation + "Backend specific slot makunbound handler")) + + +;; ================================================================================ ;; -;; Object Root Operations +;; CONTROLLER USER API +;; +;; ================================================================================ + + +;; +;; Opening and closing backend stores +;; + +(defun open-store (spec &rest args) + "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 or single-store per thread apps" + (assert (consp spec)) + (let ((controller (get-controller spec))) + (apply #'open-controller controller args) + (if *store-controller* + controller + (setq *store-controller* controller)))) + +(defun close-store (&optional sc) + "Conveniently close the store controller." + (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, + unconditionally closing the controller on exit." + `(let ((*store-controller* nil)) + (declare (special *store-controller*)) + (open-store ,spec) + (unwind-protect + (progn , at body) + (close-store *store-controller*)))) + + +;; +;; Operations on the root index ;; (defun add-to-root (key value &key (store-controller *store-controller*)) @@ -299,7 +374,7 @@ retrieve it in a later session. N.B. this means it (and everything it points to) won't get gc'd." (declare (type store-controller store-controller)) -;; (assert (not (eq key *elephant-properties-label*))) + (assert (not (eq key *elephant-properties-label*))) (setf (get-value key (controller-root store-controller)) value)) (defun get-from-root (key &key (store-controller *store-controller*)) @@ -324,15 +399,23 @@ (map-btree fn (controller-root store-controller))) ;; -;; Handling dbconnection specs +;; Explicit storage reclamation ;; -(defmethod close-controller :after ((sc store-controller)) - "Delete connection spec so object ops on cached db info fail" - (remhash (controller-spec sc) *dbconnection-spec*)) +(defmethod drop-pobject ((inst persistent-object)) + "Reclaim persistent object storage by unbinding slot values. + This does not delete the cached object instance or any + serialized references still in the db. + Need a migration or GC for that!" + (let ((pslots (persistent-slots (class-of inst)))) + (dolist (slot pslots) + (slot-makunbound inst slot)))) +;; (slot-makunbound-using-class (class-of inst) +;; inst +;; (find-effective-slot-def (class-of inst) slot))))) ;; -;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1) +;; DATABASE PROPERTY INTERFACE (Not used by system as of 0.6.1, but supported) ;; (defvar *restricted-properties* '() @@ -358,42 +441,6 @@ (when entry (cdr entry)))) - -;; -;; Upgrade paths -;; - -(defmethod up-to-date-p ((sc store-controller)) - (equal (database-version sc) *elephant-code-version*)) - -(defmethod upgrade ((sc store-controller) target-spec) - (unless (upgradable-p sc) - (error "Cannot upgrade ~A from version ~A to version ~A~%Valid upgrades are:~%~A" - (controller-spec sc) - (database-version sc) - *elephant-code-version* - *elephant-upgrade-table*)) - (warn "Please read the current limitations on migrate-based upgrade in migrate.lisp to ensure your - data does not require any unsupported features") - (let ((source sc) - (target (open-store target-spec))) - (migrate target source) - (close-store target))) - -(defparameter *elephant-upgrade-table* [57 lines skipped] --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/03 00:57:34 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/04 04:34:57 1.11 @@ -30,8 +30,6 @@ #:with-elephant-variables #:store-controller #:controller-root #:controller-class-root - #:controller-version #:controller-serializer-version - #:controller-serialize #:controller-deserialize #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:get-cached-instance #:flush-instance-cache @@ -39,6 +37,15 @@ #:controller-fast-symbols-p #:optimize-storage + #:controller-version #:controller-serializer-version + #:controller-serialize #:controller-deserialize + #:serialize-database-version-key + #:serialize-database-version-value + #:deserialize-database-version-value + #:serialize-database-serializer-version-value + #:deserialize-database-serializer-version-value + #:initialize-serializer + #:with-transaction #:ensure-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/02 23:51:58 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/04 04:34:57 1.21 @@ -64,7 +64,64 @@ target (cl-base64::base64-string-to-usb8-array string)) sc))) + +;; +;; Serializer independant system information +;; +;; We'll can this for now, can expose as API for backend later + +(defconstant +reserved-dbinfo+ #xF0) +(defconstant +elephant-version+ 1) +(defconstant +elephant-serializer-version+ 2) + +;; Database Version (a list of integers = [version major minor]) + +(defun serialize-database-version-key (bs) + (serialize-reserved-tag bs) + (serialize-system-tag +elephant-version+ bs)) + +(defun serialize-database-version-value (version bs) + "Simple serializes a list containing three integers" + (assert (consp version)) + (destructuring-bind (version major minor) version + (serialize-system-integer version bs) + (serialize-system-integer major bs) + (serialize-system-integer minor bs))) + +(defun deserialize-database-version-value (bs) + (let ((version (deserialize-system-integer bs)) + (major (deserialize-system-integer bs)) + (minor (deserialize-system-integer bs))) + (list version major minor))) + +;; +;; Serializer version (so you know what encoding is/was used in the db) +;; + +(defun serialize-database-serializer-version-key (bs) + (serialize-reserved-tag bs) + (serialize-system-tag +elephant-serializer-version+ bs)) + +(defun serialize-database-serializer-version-value (version bs) + (serialize-system-integer version bs)) + +(defun deserialize-database-serializer-version-value (bs) + (deserialize-system-integer bs)) + +;; Simple API for basic byte and integer operations + +(defun serialize-reserved-tag (bs) + (elephant-memutil::buffer-write-byte +reserved-dbinfo+ bs)) + +(defun serialize-system-tag (byte bs) + (elephant-memutil::buffer-write-byte byte bs)) + +(defun serialize-system-integer (int bs) + (elephant-memutil::buffer-write-int32 int bs)) +(defun deserialize-system-integer (bs) + (elephant-memutil::buffer-read-int32 bs)) + ;; (defclass blob () ;; ((slot1 :accessor slot1 :initarg :slot1) --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/01 04:03:27 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/04 04:34:57 1.4 @@ -71,6 +71,8 @@ (defconstant +object+ 18) (defconstant +array+ 19) +(defconstant +reserved-dbinfo+ #xF0) + (defconstant +fill-pointer-p+ #x40) (defconstant +adjustable-p+ #x80) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/03 00:57:34 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/04 04:34:57 1.12 @@ -77,6 +77,7 @@ (defconstant +class+ 21) (defconstant +nil+ #x3F) +(defconstant +reserved-dbinfo+ #xF0) ;; Arrays (defconstant +fill-pointer-p+ #x20) From ieslick at common-lisp.net Sun Feb 4 10:08:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:08:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070204100827.90BDF1010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv7647/src/db-bdb Modified Files: bdb-collections.lisp Log Message: Fixed all but one outstanding bug in test suite; cur-del2 on SBCL with SQL backend fails; duplicate sorting dependencies removed from test suite --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/04 04:34:56 1.15 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/04 10:08:27 1.16 @@ -318,13 +318,14 @@ (deserialize val sc))) (setf (cursor-initialized-p cursor) nil)))))) -;;A bit of a hack..... (defmethod cursor-last ((cursor bdb-cursor)) + "A fast cursor last, but a bit 'hackish' by exploiting oid ordering" (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) + ;; Go to the first element of the next btree (buffer-write-oid (+ (cursor-oid cursor) 1) key-buf) - (if (db-cursor-set-buffered (cursor-handle cursor) - key-buf value-buf :set-range t) + (if (db-cursor-set-buffered (cursor-handle cursor) + key-buf value-buf :set-range t) (progn (reset-buffer-stream key-buf) (reset-buffer-stream value-buf) (multiple-value-bind (key val) From ieslick at common-lisp.net Sun Feb 4 10:08:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:08:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070204100827.87FDC16@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv7647 Modified Files: TODO Log Message: Fixed all but one outstanding bug in test suite; cur-del2 on SBCL with SQL backend fails; duplicate sorting dependencies removed from test suite --- /project/elephant/cvsroot/elephant/TODO 2007/02/04 04:34:56 1.42 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/04 10:08:27 1.43 @@ -7,21 +7,21 @@ -------------------------------------------- Active tasks: -- Fix (cursor-last) bug to Robert's new test -- Fix indexing-timing, delete-instances bug reported by Robert - +- Resolve duplicate sorting guarantee in btree interface; currently supported + by BDB but not SQL and it is not tested in the regression suite - 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] - Fix *dbconnection-spec* to support multiple controllers for multiple threads for CLSQL backend +- Validate migration 0.6.0->0.6.1 BDB Features: -? Determine how to detect deadlock conditions as an optional run-safe mode? -? Automatically run db_deadlock when opening a bdb backend? Requires path to +- Determine how to detect deadlock conditions as an optional run-safe mode? +- Automatically run db_deadlock when opening a bdb backend? Requires path to functions and ability to launch shell command. Closing the store stops the sub-process. -? Always support locks that timeout? Tradeoffs? +- Always support locks that timeout? Tradeoffs? - Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API @@ -38,7 +38,6 @@ - Review and address all NOTE comments in the code 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 From ieslick at common-lisp.net Sun Feb 4 10:08:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:08:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070204100827.00BAB140B1@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv7647/src/elephant Modified Files: backend.lisp classes.lisp Log Message: Fixed all but one outstanding bug in test suite; cur-del2 on SBCL with SQL backend fails; duplicate sorting dependencies removed from test suite --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/03 14:07:01 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/04 10:08:27 1.10 @@ -77,6 +77,9 @@ #:remove-indexed-element-and-adjust #:register-backend-con-init #:lookup-backend-con-init + + ;; Lisp specific + #+(or sbcl cmu) #:%bignum-ref ) (:export ;; Variables --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/02 23:51:58 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/04 10:08:27 1.11 @@ -268,8 +268,8 @@ "Deletes the slot from the database." (declare (optimize (speed 3))) ;; NOTE: call remove-indexed-slot here instead? - (when (indexed slot-def) - (unregister-indexed-slot class (slot-definition-name slot-def))) +;; (when (indexed slot-def) +;; (unregister-indexed-slot class (slot-definition-name slot-def))) (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) ;; ====================================================== From ieslick at common-lisp.net Sun Feb 4 10:08:28 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:08:28 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070204100828.72E7316035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv7647/tests Modified Files: elephant-tests.lisp testcollections.lisp testserializer.lisp Log Message: Fixed all but one outstanding bug in test suite; cur-del2 on SBCL with SQL backend fails; duplicate sorting dependencies removed from test suite --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/01/25 18:18:00 1.22 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/04 10:08:28 1.23 @@ -80,11 +80,19 @@ '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) (defvar *testsqlite3-spec* - '(:clsql (:sqlite3 "sqlite3-test.db")) + `(:clsql (:sqlite3 + ,(namestring + (merge-pathnames + #p"tests/sqlite3-test.db" + (asdf:component-pathname (asdf:find-system 'elephant-tests)))))) "This is of the form '(filename &optional init-function),") (defvar *testsqlite3-spec2* - '(:clsql (:sqlite3 "sqlite3-test2.db")) + `(:clsql (:sqlite3 + ,(namestring + (merge-pathnames + #p"tests/sqlite3-test2.db" + (asdf:component-pathname (asdf:find-system 'elephant-tests)))))) "This is of the form '(filename &optional init-function),") (defvar *testsqlite3-memory-spec* --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/04 00:07:45 1.15 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/04 10:08:28 1.16 @@ -337,6 +337,14 @@ (values t (mod v 2) )) +(defun twice (s k v) + (declare (ignore s k)) + (values t (* v 2))) + +(defun half-floor (s k v) + (declare (ignore s v)) + (values t (floor (/ k 2)))) + (deftest rem-idexkv (with-transaction (:store-controller *store-controller*) (let* ((ibt (make-indexed-btree *store-controller*)) @@ -425,21 +433,12 @@ (deftest dup-test (with-transaction (:store-controller *store-controller*) - (unwind-protect - (progn -;; (trace cursor-first) -;; (trace cursor-next-dup) -;; (trace db-clsql::sql-get-from-clcn-nth) -;; (trace db-clsql::has-key-value-scnd) - (with-btree-cursor (curs index3) - (loop for (more k v) = (multiple-value-list - (cursor-first curs)) - then (multiple-value-list (cursor-next-dup curs)) - while more - collect v))) - (untrace) - ) - ) + (with-btree-cursor (curs index3) + (loop for (more k v) = (multiple-value-list + (cursor-first curs)) + then (multiple-value-list (cursor-next-dup curs)) + while more + collect v))) (0 -1 -2 -3 -4 -5 -6 -7 -8 -9)) @@ -483,44 +482,22 @@ t) (deftest cur-del1 - ;; Note: If this is not done inside a transaction, - ;; it HANGS BDB! (with-transaction (:store-controller *store-controller*) - (unwind-protect - (progn -;; (trace cursor-first) -;; (trace cursor-next-dup) -;; (trace cursor-last) -;; (trace cursor-delete) -;; (trace get-value) -;; (trace has-key-value) (let* ((ibt (make-indexed-btree *store-controller*)) (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) -;; This appears to delete the SINGLE value pointed two by -;; the cursor at that time. (the way it is written now, the second-to-last element 9 = 81; -;; If you want to delete more, you have to iterate through the cursor, I suppose. - (with-btree-cursor (c id1) - (cursor-last c) - (cursor-delete c) - ) - (let ((res - (equal - (list - (get-value 4 ibt) - (get-value 5 ibt) - (get-value 9 ibt) - (get-value 10 ibt) - ) - '(16 25 81 nil)))) - (untrace) - res - ) - )) - ) - ) + (labels ((deleted (key others) + (and (null (get-value key ibt)) + (every #'(lambda (k2) + (= (get-value k2 ibt) (* k2 k2))) + others)))) + (loop for i from 0 to 5 do + (setf (get-value i ibt) (* i i))) + (with-btree-cursor (c id1) + (cursor-last c) + (cursor-delete c)) + (or (deleted 5 '(3 1)) + (deleted 3 '(5 1)) + (deleted 1 '(5 3)))))) t) (deftest indexed-delete @@ -559,45 +536,21 @@ (deftest cur-del2 - (unwind-protect - (with-transaction (:store-controller *store-controller*) - (let* ((ibt (make-indexed-btree *store-controller*)) - (id1 (add-index ibt :index-name 'idx1 :key-form 'odd))) - (progn - (untrace) -;; (trace cursor-first) -;; (trace cursor-next-dup) -;; (trace cursor-last) -;; (trace cursor-delete) -;; (trace get-value) -;; (trace cursor-current) -;; (trace db-clsql::cursor-initialized-p) -;; (trace remove-kv) -;; (trace db-clsql::cursor-next-dup-x) -;; (trace db-clsql::has-key-value-scnd) -;; (trace db-clsql::sql-from-clcn-key-and-value-existsp) -;; (trace db-clsql::sql-add-to-clcn) -;; (trace odd) -;; (trace crunch) - (loop for i from 0 to 10 - do - (setf (get-value i ibt) (* i i))) - (with-btree-cursor (c id1) - (cursor-first c) - (cursor-next-dup c) - (cursor-delete c) - ) - (let ((res - (equal (list - (get-value 1 id1) ;; - (get-value 0 id1) ;; This should be 0, but is returning nil! - ) - '(1 0)))) - (untrace) - res) - ) - )) - (untrace)) + (with-transaction (:store-controller *store-controller*) + (let* ((ibt (make-indexed-btree *store-controller*)) + (id1 (add-index ibt :index-name 'idx1 :key-form 'half-floor))) + (loop for i from 0 to 10 + do + (setf (get-value i ibt) (* i i))) + (with-btree-cursor (c id1) + (cursor-first c) + (cursor-next-dup c) + (cursor-delete c) + ) + (or (and (null (get-value 1 ibt)) + (eq (get-value 0 ibt) 0)) + (and (null (get-value 0 ibt)) + (eq (get-value 1 ibt) 1))))) t) --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/03 14:07:01 1.16 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/04 10:08:28 1.17 @@ -255,9 +255,9 @@ (setf (gethash 'symbolsymbol ht) "three") (let ((out (in-out-value ht))) (are-not-null - (string= (gethash (cons nil nil) ht) "one") - (= (gethash 2 ht) 2.0d0) - (string= (gethash 'symbolsymbol ht) "three")))) + (string= (gethash (cons nil nil) out) "one") + (= (gethash 2 out) 2.0d0) + (string= (gethash 'symbolsymbol out) "three")))) t t t) (defun type= (t1 t2) From ieslick at common-lisp.net Sun Feb 4 10:12:43 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:12:43 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070204101243.83E914D050@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv8191/db-lisp Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp added to the repository From ieslick at common-lisp.net Sun Feb 4 10:12:50 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:12:50 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-rucksack Message-ID: <20070204101250.5EA074D050@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack In directory clnet:/tmp/cvs-serv8222/db-rucksack Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack added to the repository From ieslick at common-lisp.net Sun Feb 4 10:16:41 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:16:41 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-acache Message-ID: <20070204101641.DA03A55352@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache In directory clnet:/tmp/cvs-serv8584/db-acache Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache added to the repository From ieslick at common-lisp.net Sun Feb 4 10:17:20 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:17:20 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-acache Message-ID: <20070204101720.808B75B068@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache In directory clnet:/tmp/cvs-serv8664/src/contrib/eslick/db-acache Added Files: README acache-collections.lisp acache-controller.lisp acache-transactions.lisp package.lisp Log Message: Cleaning up source directory, moving partial projects to contrib --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/README 2007/02/04 10:17:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/README 2007/02/04 10:17:20 1.1 This directory contains a quick and dirty sketch of an allegrocache backend, mostly to test out the new backend abstraction. Basic btrees work fine but iteration (cursors) are very limited. I think the best way to go is reverse engineer the db.btree API and just implement the elephant backend on top of that API. I may do this at some point, but not today... Or better yet, find someone willing to write a btree library in lisp. John Fedaro said it wasn't a huge amount of work and can be done with very high performance in all Common Lisp. Ian --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-collections.lisp 2007/02/04 10:17:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-collections.lisp 2007/02/04 10:17:20 1.1 (in-package :elephant-acache) ;; BTREE (defclass acache-btree (btree) ()) (defmethod build-btree ((sc acache-store-controller)) (make-instance 'acache-btree :sc sc)) (defmethod get-value (key (bt acache-btree)) (map-value (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod (setf get-value) (value key (bt acache-btree)) (setf (map-value (controller-btrees (get-con bt)) (cons (oid bt) key)) value)) (defmethod existsp (key (bt acache-btree)) (when (get-value key bt) t)) (defmethod remove-kv (key (bt acache-btree)) (remove-from-map (controller-btrees (get-con bt)) (cons (oid bt) key))) (defmethod map-btree (fn (bt acache-btree)) (map-map fn bt)) ;; INDEXED BTREE (defclass acache-indexed-btree (indexed-btree acache-btree) ((indices :accessor indices :initarg :indices :initform (make-hash-table)) (indices-cache :accessor indices-cache :initarg :indicies-cache :initform nil :transient t)) (:metaclass persistent-metaclass)) (defmethod build-indexed-btree ((sc acache-store-controller)) (make-instance 'acache-indexed-btree :sc sc)) (defclass acache-btree-index (btree-index acache-btree) () (:metaclass persistent-metaclass)) (defmethod build-btree-index ((sc acache-store-controller) &key primary key-form) (make-instance 'acache-btree-index :primary primary :key-form :sc sc)) ;; ;; CURSORS ;; (defclass acache-cursor (cursor) ()) (defmethod make-cursor ((bt acache-btree)) (make-instance 'acache-cursor)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-controller.lisp 2007/02/04 10:17:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-controller.lisp 2007/02/04 10:17:20 1.1 (in-package :elephant-acache) (defclass acache-store-controller (store-controller) ((db :accessor controller-db :initform nil) (slots :accessor controller-slots :initform nil) (btrees :accessor controller-btrees :initform nil) (oidrec :accessor controller-oidrec :initform nil))) (defun acache-constructor (spec) (make-instance 'acache-store-controller :spec spec)) (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :acache 'acache-constructor)) (defclass oid-record () ((counter :accessor oid-record-counter :initform 0)) (:metaclass db.allegrocache:persistent-class)) (defmethod open-controller ((sc acache-store-controller) &key (recover t) (recover-fatal nil) (thread nil)) (declare (ignore recover thread recover-fatal)) (let ((db (db.allegrocache:open-file-database (second (controller-spec sc)) :if-does-not-exist :create :if-exists :open :use :memory))) (when (not db) (error "Unable to open astore database for ~A" (controller-spec sc))) ;; Main DB ref (setf (controller-db sc) db) ;; Slots and Btree storage (let ((slotmap (retrieve-from-index 'ac-map 'ac-map-name "slots"))) (setf (controller-slots sc) (if slotmap slotmap (make-instance 'db.allegrocache:ac-map :ac-map-name "slots")))) (let ((btreemap (retrieve-from-index 'ac-map 'ac-map-name "btrees"))) (setf (controller-btrees sc) (if btreemap btreemap (make-instance 'db.allegrocache:ac-map :ac-map-name "btrees")))) ;; OIDS (let ((oidrec (doclass (inst (find-class 'oid-record) :db db) (when inst (return inst))))) (setf (controller-oidrec sc) (if oidrec oidrec (make-instance 'oid-record)))) ;; Construct the roots (setf (slot-value sc 'root) (make-instance 'acache-btree :from-oid -1)) (setf (slot-value sc 'class-root) (make-instance 'acache-btree :from-oid -2)) sc)) (defmethod next-oid ((sc acache-store-controller)) (incf (oid-record-counter (controller-oidrec sc)))) (defmethod close-controller ((sc acache-store-controller)) ;; Ensure deletion of common (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) (db.allegrocache:close-database :db (controller-db sc))) (defmethod connection-is-indeed-open ((sc acache-store-controller)) (db.allegrocache::database-open-p (controller-db sc))) ;; Slot writing ;; This is not thread-safe, but could be a thread-local when we fix that... ;; to avoid extra consing. Is consing less/more expensive than dynamic ;; var lookups? (defvar *index-cons* (cons nil nil)) (defmacro fast-key (oid name) `(rplacd (rplaca *index-cons* ,oid) ,name)) (defmethod persistent-slot-reader ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (multiple-value-bind (val valid?) (map-value (controller-slots sc) (fast-key (oid instance) name)) (if valid? val (error "Slot ~A unbound in ~A" name instance)))) (defmethod persistent-slot-writer ((sc acache-store-controller) value instance name) (declare (optimize (speed 3) (safety 1))) (setf (map-value (controller-slots sc) (fast-key (oid instance) name)) value)) (defmethod persistent-slot-boundp ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (when (map-value (controller-slots sc) (fast-key (oid instance) name)) t)) (defmethod persistent-slot-makunbound ((sc acache-store-controller) instance name) (declare (optimize (speed 3) (safety 1))) (remove-from-map (controller-slots sc) (fast-key (oid instance) name))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-transactions.lisp 2007/02/04 10:17:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/acache-transactions.lisp 2007/02/04 10:17:20 1.1 (in-package :elephant-acache) (defmethod controller-start-transaction ((sc acache-store-controller) &key parent &allow-other-keys) "Allegrocache has implicit transactions whenever there's a write" (when parent (error "ACache backend does not allow nested transactions...a commit will commit everything since the last commit")) t) (defmethod controller-commit-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:commit :db (controller-db sc))) (defmethod controller-abort-transaction ((sc acache-store-controller) &key &allow-other-keys) (db.allegrocache:rollback :db (controller-db sc))) (defmethod execute-transaction ((sc acache-store-controller) closure &key parent retries &allow-other-keys) (db.allegrocache:with-transaction-restart (:count retries) (funcall closure) (db.allegrocache:commit :db sc)))--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/package.lisp 2007/02/04 10:17:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/package.lisp 2007/02/04 10:17:20 1.1 (in-package :cl-user) (eval-when (:load-toplevel :compile-toplevel) (require :acache)) (eval-when (:load-toplevel) (warn "Allegrocache support is incomplete and should be considered as an example only")) (defpackage elephant-acache (:documentation "A low-level UFFI-based interface to Berkeley DB / Sleepycat to implement the elephant front-end framework. Uses the libsleepycat.c wrapper. Partly intended to be usable outside Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Sleepycat, so refer to their documentation for details.") (:use common-lisp elephant elephant-backend) (:import-from #:db.allegrocache #:ac-map #:ac-map-name #:doclass #:commit #:retrieve-from-index #:map-map #:map-value #:remove-from-map)) From ieslick at common-lisp.net Sun Feb 4 10:17:21 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:17:21 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070204101721.16A665B062@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv8664/src/contrib/eslick/db-lisp Added Files: TODO binary-data.lisp binary-types.lisp btree.lisp buffers.lisp file.lisp lisp-types.lisp octet-stream.lisp package.lisp Log Message: Cleaning up source directory, moving partial projects to contrib --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:21 1.1 A lisp backend will need: - read/write binary sequences - move/cache binary pages to/from disk - locking of structures/pages for multi-threaded use - transaction logging (context + primitives) - checkpointing, backup and log removal Want to build other data structures on this basic substrate: - large sets / persistent arrays - linear records - inverse index Can we store odd types? - Classes? - Closures? - Functions? (probably only with source access) Some constraints: - A binary file will allow for multiple internal btrees, will lock the root indices - Want to enable multiple possible allocation, layout and update algorithms; so each file should describe its type? - Would like to allow multiple processes to have open file handles Perhaps have a per-thread file handle? - Mixing types is possible if based on underlying page size, but performance will suffer ;; read/write fields in an array ;; parse/unparse from a stream or array ;; instantiate a lisp version of the binary type ;; associate a type with an array ;; need binary versions of native lisp types ;; (defgeneric parse-binary-value (type in &key) ;; (:documentation "Read a binary value from an array or stream")) ;; (defmethod parse-binary-value ((type (eql 'u8)) (in stream) &key) ;; (read-byte in)) ;; (defmethod parse-binary-value ((type (eql 'u8)) (in array) &key (offset 0)) ;; (declare (type fixnum offset)) ;; (assert (subtypep (type-of in) '(array (unsigned 8) *))) ;; (aref in offset)) ;; (defmethod unparse-binary-value ((type (eql 'u8)) (out stream) (value (unsigned 8)) &key) ;; (write-byte value out)) ;; (defmethod unparse-binary-value ((type (eql 'u8)) (out array) (value (unsigned 8)) &key (offset 0)) ;; (--- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-data.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-data.lisp 2007/02/04 10:17:21 1.1 (in-package :db-lisp) ;; ;; Macros ;; (defmacro with-gensyms ((&rest names) &body body) `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) , at body)) ;; ;; Binary types ;; ;; NOTE: Needs to be made MP safe (defvar *in-progress-objects* nil) (defconstant +null+ (code-char 0)) (defgeneric read-value (type stream &key) (:documentation "Read a value of the given type from the stream.")) (defgeneric write-value (type stream value &key) (:documentation "Write a value as the given type to the stream.")) (defgeneric read-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Fill in the slots of object from stream.")) (defgeneric write-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Write out the slots of object to the stream.")) ;; These may not be needed; design your compound objects so that ;; you can read offsets and parse compound objects ;;(defgeneric read-field-value (type stream &optional base-pos) ;; (:documentation "Index directly to a subfield of a complex type to read ;; from a random underlying stream")) ;; ;;(defgeneric write-field-value (type stream value &optional base-pos) ;; (:documentation "Write an object directly to the subfield of a complex ;; type in the provided field")) ;; ;; Defaults for read-value of binary-object types (defmethod read-value ((type symbol) stream &key) (let ((object (make-instance type))) (read-object object stream) object)) (defmethod write-value ((type symbol) stream value &key) (assert (typep value type)) (write-object value stream)) (defun read-value-at (type stream pos) "Ensure a stream is at a particular offset before reading" (file-position stream pos) (read-value type stream)) (defun write-value-at (type stream pos value) "Ensure a stream is at a particular offset before writing" (file-position stream pos) (write-value type stream value)) ;;; Binary types (defmacro define-binary-type (name (&rest args) &body spec) (with-gensyms (type stream value) `(progn (defmethod read-value ((,type (eql ',name)) ,stream &key , at args) (declare (ignorable , at args)) ,(type-reader-body spec stream)) (defmethod write-value ((,type (eql ',name)) ,stream ,value &key , at args) (declare (ignorable , at args)) ,(type-writer-body spec stream value))))) (defun type-reader-body (spec stream) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(read-value ',type ,stream , at args))) (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) `(let ((,in ,stream)) , at body))))) (defun type-writer-body (spec stream value) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(write-value ',type ,stream ,value , at args))) (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) `(let ((,out ,stream) (,v ,value)) , at body))))) ;;; Binary classes (defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) (with-gensyms (objectvar streamvar) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'slots) ',(mapcar #'first slots)) (setf (get ',name 'superclasses) ',superclasses)) (defclass ,name ,superclasses ,(mapcar #'slot->defclass-slot slots)) ,read-method (defmethod write-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) (defmacro define-binary-class (name (&rest superclasses) slots) (with-gensyms (objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) (defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) (with-gensyms (typevar objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) (let ((,objectvar (make-instance ,@(or (cdr (assoc :dispatch options)) (error "Must supply :disptach form.")) ,@(mapcan #'slot->keyword-arg slots)))) (read-object ,objectvar ,streamvar) ,objectvar)))))) (defun as-keyword (sym) (intern (string sym) :keyword)) (defun normalize-slot-spec (spec) (list (first spec) (mklist (second spec)))) (defun mklist (x) (if (listp x) x (list x))) (defun slot->defclass-slot (spec) (let ((name (first spec))) `(,name :initarg ,(as-keyword name) :accessor ,name))) (defun slot->read-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(setf ,name (read-value ',type ,stream , at args)))) (defun slot->write-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(write-value ',type ,stream ,name , at args))) (defun slot->binding (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(,name (read-value ',type ,stream , at args)))) (defun slot->keyword-arg (spec) (let ((name (first spec))) `(,(as-keyword name) ,name))) ;;; Keeping track of inherited slots (defun direct-slots (name) (copy-list (get name 'slots))) (defun inherited-slots (name) (loop for super in (get name 'superclasses) nconc (direct-slots super) nconc (inherited-slots super))) (defun all-slots (name) (nconc (direct-slots name) (inherited-slots name))) (defun new-class-all-slots (slots superclasses) "Like all slots but works while compiling a new class before slots and superclasses have been saved." (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) ;;; In progress Object stack (defun current-binary-object () (first *in-progress-objects*)) (defun parent-of-type (type) (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) (defmethod read-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) (defmethod write-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) ;; Copyright (c) 2005, Peter Seibel All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * Redistributions in binary form must reproduce the above ;; copyright notice, this list of conditions and the following ;; disclaimer in the documentation and/or other materials provided ;; with the distribution. ;; * Neither the name of the Peter Seibel nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-types.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/binary-types.lisp 2007/02/04 10:17:21 1.1 (in-package :db-lisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A few basic types (define-binary-type unsigned-integer (bytes) (:reader (in) (loop with value = 0 for shift downfrom (* bytes 8) to 0 by 8 do (setf value (logior (ash (read-byte in) shift) value)) finally (return value))) (:writer (out value) (loop for shift downfrom (* bytes 8) to 0 by 8 do (write-byte (logand (ash value (- shift)) #xFF) out)))) (define-binary-type unsigned-integer-cplx (bytes bits-per-byte) (:reader (in) (loop with value = 0 for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) finally (return value))) (:writer (out value) (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) (define-binary-type u8 () (unsigned-integer :bytes 1)) (define-binary-type u16 () (unsigned-integer :bytes 2)) (define-binary-type u24 () (unsigned-integer :bytes 3)) (define-binary-type u32 () (unsigned-integer :bytes 4)) (define-binary-type u64 () (unsigned-integer :bytes 8)) ;;; Strings (define-binary-type generic-string (length character-type) (:reader (in) (let ((string (make-string length))) (dotimes (i length) (setf (char string i) (read-value character-type in))) string)) (:writer (out string) (dotimes (i length) (write-value character-type out (char string i))))) (define-binary-type generic-terminated-string (terminator character-type) (:reader (in) (with-output-to-string (s) (loop for char = (read-value character-type in) until (char= char terminator) do (write-char char s)))) (:writer (out string) (loop for char across string do (write-value character-type out char) finally (write-value character-type out terminator)))) ;;; ISO-8859-1 strings (define-binary-type iso-8859-1-char () (:reader (in) (let ((code (read-byte in))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (if (<= 0 code #xff) (write-byte code out) (error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code))))) (define-binary-type iso-8859-1-string (length) (generic-string :length length :character-type 'iso-8859-1-char)) (define-binary-type iso-8859-1-terminated-string (terminator) (generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char)) ;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.) ;;; Define a binary type for reading a UCS-2 character relative to a ;;; particular byte ordering as indicated by the BOM value. ;; v2.3 specifies that the BOM should be present. v2.2 is silent ;; though it is arguably inherent in the definition of UCS-2) Length ;; is in bytes. On the write side, since we don't have any way of ;; knowing what BOM was used to read the string we just pick one. ;; This does mean roundtrip transparency could be broken. (define-binary-type ucs-2-char (swap) (:reader (in) (let ((code (read-value 'u2 in))) (when swap (setf code (swap-bytes code))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (unless (<= 0 code #xffff) (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code)) (when swap (setf code (swap-bytes code))) (write-value 'u2 out code)))) (defun swap-bytes (code) (assert (<= code #xffff)) (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code)) code) (define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil)) (define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t)) (defun ucs-2-char-type (byte-order-mark) (ecase byte-order-mark (#xfeff 'ucs-2-char-big-endian) (#xfffe 'ucs-2-char-little-endian))) (define-binary-type ucs-2-string (length) (:reader (in) (let ((byte-order-mark (read-value 'u2 in)) (characters (1- (/ length 2)))) (read-value 'generic-string in :length characters :character-type (ucs-2-char-type byte-order-mark)))) (:writer (out string) (write-value 'u2 out #xfeff) (write-value 'generic-string out string :length (length string) :character-type (ucs-2-char-type #xfeff)))) [43 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:21 1.1 [45 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/buffers.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/buffers.lisp 2007/02/04 10:17:21 1.1 [209 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:21 1.1 [227 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/lisp-types.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/lisp-types.lisp 2007/02/04 10:17:21 1.1 [242 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:21 1.1 [483 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:21 1.1 [555 lines skipped] From ieslick at common-lisp.net Sun Feb 4 10:17:21 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:17:21 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-rucksack Message-ID: <20070204101721.549125B068@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack In directory clnet:/tmp/cvs-serv8664/src/contrib/eslick/db-rucksack Added Files: notes.txt package.lisp rs-collections.lisp rs-controller.lisp Log Message: Cleaning up source directory, moving partial projects to contrib --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/notes.txt 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/notes.txt 2007/02/04 10:17:21 1.1 Three main approaches: 1) Adapt elephant to support either RS or existing metaobject models (hard to migrate?) 2) Create a single RS persistent-class to store slot values for an elephant p-obj, borrow the rest of the mechanism (PROPOSAL) 3) Write our own lisp backend using the heap, cache and btree code? Depends on how deeply the cache is integrated with serializer, etc. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/package.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/package.lisp 2007/02/04 10:17:21 1.1 (in-package :cl-user) (defpackage :rucksack-elephant (:use :cl :rucksack) (:export ;; controller #:open-rucksack #:close-rucksack #:with-rucksack #:current-rucksack #:rucksack #:standard-rucksack #:rucksack-cache #:rucksack-directory #:rucksack-commit #:rucksack-rollback #:add-rucksack-root #:map-rucksack-roots #:rucksack-roots #:commit #:rollback ;; class indexing ;; #:add-class-index #:add-slot-index ;; #:remove-class-index #:remove-slot-index ;; #:map-class-indexes #:map-slot-indexes #:rucksack-add-class-index #:rucksack-add-slot-index #:rucksack-make-class-index #:rucksack-remove-class-index #:rucksack-remove-slot-index #:rucksack-class-index #:rucksack-slot-index #:rucksack-map-class-indexes #:rucksack-map-slot-indexes #:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object #:rucksack-map-class #:rucksack-map-slot ;; Transactions ;; #:current-transaction ;; #:transaction-start #:transaction-commit #:transaction-rollback ;; #:with-transaction ;; #:transaction #:standard-transaction ;; #:transaction-start-1 #:transaction-commit-1 ;; #:transaction-id ;; Cache #:cache #:standard-cache #:open-cache #:close-cache #:with-cache #:cache-size #:cache-count #:cache-create-object #:cache-get-object #:cache-touch-object #:cache-commit #:cache-rollback #:cache-recover #:open-transaction #:close-transaction #:map-transactions ;; Conditions #:rucksack-error #:simple-rucksack-error #:transaction-conflict #:btree-error #:btree-search-error #:btree-insertion-error #:btree-key-already-present-error #:btree-type-error #:btree-error-btree #:btree-error-key #:btree-error-value ;; Heaps #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap #:open-heap #:close-heap #:heap-stream #:heap-end ;; BTree IF ;; #:btree #:btree-key< #:btree-key= #:btree-value= #:btree-max-node-size #:btree-unique-keys-p #:btree-key-type #:btree-value-type #:btree-node-class #:btree-node ;; Indexes #:map-index #:index-insert #:index-delete #:make-index ;; BTrees #:btree-search #:btree-insert ;; #:map-btree ;; Objects ;; #:persistent-object #:persistent-data #:persistent-array #:persistent-cons #:object-id #:p-cons #:p-array #:p-eql #:p-car #:p-cdr #:p-list #:p-make-array #:p-aref #:p-array-dimensions #:p-length #:p-find #:p-replace #:p-position )) (defpackage :db-lisp (:use :cl :elephant :elephant-backend :rucksack-elephant)) ;; file ;; octet-stream ;; binary-data ;; binary-types ;; buffers ;; btree --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/rs-collections.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/rs-collections.lisp 2007/02/04 10:17:21 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; rs-collections.lisp -- view Berkeley DBs as Lisp collections ;;; ;;; Initial version 6/4/2006 Ian Eslick ;;; ;;; ;;; Copyright (c) 2006 by Ian Eslick ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package #:db-rucksack) (defclass rs-btree (btree) () (:documentation "A Rucksack BTree")) (defmethod build-btree ((sc rs-store-controller)) (make-instance 'rs-btree :sc sc)) (defmethod --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/rs-controller.lisp 2007/02/04 10:17:21 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-rucksack/rs-controller.lisp 2007/02/04 10:17:21 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; rs-controller.lisp -- Lisp interface to a Berkeley DB store ;;; ;;; Initial version 6/4/2006 Ian Eslick ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package #:db-rucksack) (defclass rs-store-controller (store-controller) ((rucksack :accessor rs-store-db :initform nil) (slot-btree :accessor (defun rs-test-and-construct (spec) (if (rs-store-spec-p spec) (make-instance 'rs-store-controller :spec spec) (error (format nil "Unrecognized spec: ~A" spec)))) (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :rs 'rs-test-and-construct)) (defun rs-store-spec-p (spec) (and (eq (first spec) :rucksack) (typecase (second spec) (pathname t) (string t) (otherwise nil)))) (defmethod open-controller ((sc rs-store-controller) &rest args &key &allow-other-keys) (setf (rs-store-db sc) (apply #'open-rucksack (second (controller-spec sc)) args))) (defmethod close-controller ((sc rs-store-controller)) (rucksack-commit) (close-rucksack (rs-store-db sc))) (defmethod next-oid ((sc rs-store-controller)) "TODO" ;; create a proxy object using elephant's persistent-slot list ;; so we can store slots in it ) ;;; Persistent slot protocol (defmethod persistent-slot-reader ((sc rs-store-controller) instance name) "It would be nice to reuse the object interface that rucksack provides, but this is a cheap hack to get it running" ;; create comparison function in lisp ;; store slot values in btrees ) From ieslick at common-lisp.net Sun Feb 4 10:17:21 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:17:21 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-acache Message-ID: <20070204101721.904E55B062@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-acache In directory clnet:/tmp/cvs-serv8664/src/db-acache Removed Files: acache-collections.lisp acache-controller.lisp acache-transactions.lisp package.lisp Log Message: Cleaning up source directory, moving partial projects to contrib From ieslick at common-lisp.net Sun Feb 4 10:18:22 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:18:22 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-acache Message-ID: <20070204101822.2191B1B008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-acache In directory clnet:/tmp/cvs-serv8849/db-acache Removed Files: README Log Message: Final src cleanup From ieslick at common-lisp.net Sun Feb 4 10:23:22 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:23:22 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick Message-ID: <20070204102322.5F76324007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick In directory clnet:/tmp/cvs-serv10743/eslick Added Files: metaclasses-new.lisp package-new.lisp Log Message: Some working files for a lisp backend and a port to close-to-mop to cleanup the MOP implementation --- /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/metaclasses-new.lisp 2007/02/04 10:23:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; metaclasses.lisp -- persistent objects via metaobjects ;;; ;;; Initial version 8/26/2004 by Andrew Blumberg ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; (Some changes by Robert L. Read, 2006) ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (defclass persistent () ((%oid :accessor oid :initarg :from-oid) (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst)) (:documentation "Abstract superclass for all persistent classes (common to user-defined classes and collections.)")) (defclass persistent-metaclass (standard-class) ((%persistent-slots :accessor %persistent-slots) (%indexed-slots :accessor %indexed-slots) (%index-cache :accessor %index-cache)) (:documentation "Metaclass for persistent classes. Use this metaclass to define persistent classes. All slots are persistent by default; use the :transient flag otherwise. Slots can also be indexed for by-value retrieval.")) ;; ;; Top level defclass form - hide metaclass option ;; (defmacro defpclass (cname parents slot-defs &rest class-opts) `(defclass ,cname ,parents ,slot-defs ,@(add-persistent-metaclass-argument class-opts))) (defun add-persistent-metaclass-argument (class-opts) (when (assoc :metaclass class-opts) (error "User metaclass specification not allowed in defpclass")) (append class-opts (list (list :metaclass 'persistent-metaclass)))) ;; ;; Persistent slot maintenance ;; (defmethod persistent-slots ((class persistent-metaclass)) (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) nil)) (defmethod persistent-slots ((class standard-class)) nil) (defmethod old-persistent-slots ((class persistent-metaclass)) (cdr (%persistent-slots class))) (defmethod update-persistent-slots ((class persistent-metaclass) new-slot-list) ;; (setf (%persistent-slots class) (cons new-slot-list (car (%persistent-slots class))))) (setf (%persistent-slots class) (cons new-slot-list (if (slot-boundp class '%persistent-slots) (car (%persistent-slots class)) nil) ))) (defclass persistent-slot-definition (standard-slot-definition) ((indexed :accessor indexed :initarg :index :initform nil :allocation :instance))) (defclass persistent-direct-slot-definition (standard-direct-slot-definition persistent-slot-definition) ()) (defclass persistent-effective-slot-definition (standard-effective-slot-definition persistent-slot-definition) ()) (defclass transient-slot-definition (standard-slot-definition) ((transient :initform t :initarg :transient :allocation :class))) (defclass transient-direct-slot-definition (standard-direct-slot-definition transient-slot-definition) ()) (defclass transient-effective-slot-definition (standard-effective-slot-definition transient-slot-definition) ()) (defgeneric transient (slot)) (defmethod transient ((slot standard-direct-slot-definition)) t) (defmethod transient ((slot persistent-direct-slot-definition)) nil) ;; ;; Indexed slots maintenance ;; ;; This just encapsulates record keeping a bit (defclass indexing-record () ((class :accessor indexing-record-class :initarg :class :initform nil) (slots :accessor indexing-record-slots :initarg :slots :initform nil) (derived-count :accessor indexing-record-derived :initarg :derived :initform 0))) (defmethod print-object ((obj indexing-record) stream) (format stream "#INDEXING-RECORD" (length (indexing-record-slots obj)) (length (indexing-record-derived obj)))) (defmethod indexed-record ((class standard-class)) nil) (defmethod indexed-record ((class persistent-metaclass)) (when (slot-boundp class '%indexed-slots) (car (%indexed-slots class)))) (defmethod old-indexed-record ((class persistent-metaclass)) (when (slot-boundp class '%indexed-slots) (cdr (%indexed-slots class)))) (defmethod update-indexed-record ((class persistent-metaclass) new-slot-list &key class-indexed) (let ((oldrec (if (slot-boundp class '%indexed-slots) (indexed-record class) nil))) (setf (%indexed-slots class) (cons (make-new-indexed-record new-slot-list oldrec class-indexed) (if oldrec oldrec nil))))) (defmethod make-new-indexed-record (new-slot-list oldrec class-indexed) (make-instance 'indexing-record :class (or class-indexed (when oldrec (indexing-record-class oldrec))) :slots new-slot-list :derived (when oldrec (indexing-record-derived oldrec)))) (defmethod removed-indexing? ((class persistent-metaclass)) (and (not (indexed class)) (previously-indexed class))) (defun indexed-slot-names-from-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-definition in slot-definitions when (and (subtypep (type-of slot-definition) 'persistent-slot-definition) (indexed slot-definition)) collect (slot-definition-name slot-definition)))) (defmethod register-indexed-slot ((class persistent-metaclass) slot) "This method allows for post-definition update of indexed status of class slots. It changes the effective method so we can rely on generic function dispatch for differentated behavior" ;; update record (let ((record (indexed-record class))) (unless (member slot (car (%persistent-slots class))) (error "Tried to register slot ~A as index which isn't a persistent slot" slot)) (unless (member slot (indexing-record-slots record)) ;; This is a normal startup case, but during other cases we'd like ;; the duplicate warning ;; (warn "Tried to index slot ~A which is already indexed" slot)) (push slot (indexing-record-slots record)))) ;; change effective slot def (let ((slot-def (find-slot-def-by-name class slot))) (unless slot-def (error "Slot definition for slot ~A not found, inconsistent state in class ~A" slot (class-name class))) (setf (slot-value slot-def 'indexed) t))) (defmethod unregister-indexed-slot (class slot) "Revert an indexed slot to it's original state" ;; update record (let ((record (indexed-record class))) (unless (member slot (indexing-record-slots record)) (error "Tried to unregister slot ~A which is not indexed" slot)) (setf (indexing-record-slots record) (remove slot (indexing-record-slots record)))) ;; change effective slot def status (let ((slot-def (find-slot-def-by-name class slot))) (unless slot-def (error "Slot definition for slot ~A not found, inconsistent state in class ~A" slot (class-name class))) (setf (slot-value slot-def 'indexed) nil))) (defmethod register-derived-index (class name) "Tell the class that it has derived indices defined against it and keep a reference count" (let ((record (indexed-record class))) (push name (indexing-record-derived record)))) (defmethod unregister-derived-index (class name) (let ((record (indexed-record class))) (setf (indexing-record-derived record) (remove name (indexing-record-derived record))))) (defmethod indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots) (not (null (%indexed-slots class))) (or (indexing-record-class (indexed-record class)) (indexing-record-slots (indexed-record class)) (indexing-record-derived (indexed-record class))))) (defmethod previously-indexed ((class persistent-metaclass)) (and (slot-boundp class '%indexed-slots) (not (null (%indexed-slots class))) (let ((old (old-indexed-record class))) (when (not (null old)) (or (indexing-record-class old) (indexing-record-slots old) (indexing-record-derived old)))))) (defmethod indexed ((slot standard-slot-definition)) nil) (defmethod indexed ((class standard-class)) nil) (defvar *inhibit-indexing-list* nil "Use this to avoid updating an index inside low-level functions that update groups of slots at once. We may need to rethink this if we go to a cheaper form of update that doesn't batch update all indices") (defun inhibit-indexing (uid) (pushnew uid *inhibit-indexing-list*)) (defun uninhibit-indexing (uid) (setf *inhibit-indexing-list* (delete uid *inhibit-indexing-list*))) ;; ;; Original support for persistent slot protocol ;; (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) :database) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) and chooses persistent or transient slot definitions." (let ((allocation-key (getf initargs :allocation)) (transient-p (getf initargs :transient)) (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and (eq allocation-key :class) transient-p) (find-class 'transient-direct-slot-definition)) ((and (eq allocation-key :class) (not transient-p)) (error "Persistent class slots are not supported, try :transient t.")) ((and indexed-p transient-p) (error "Cannot declare slots to be both transient and indexed")) (transient-p (find-class 'transient-direct-slot-definition)) (t (find-class 'persistent-direct-slot-definition))))) (defmethod validate-superclass ((class persistent-metaclass) (super standard-class)) "Persistent classes may inherit from ordinary classes." t) (defmethod validate-superclass ((class standard-class) (super persistent-metaclass)) "Ordinary classes may NOT inherit from persistent classes." nil) (defgeneric persistent-p (class)) (defmethod persistent-p ((class t)) nil) (defmethod persistent-p ((class persistent-metaclass)) t) (defmethod persistent-p ((class persistent-slot-definition)) t) (defmethod effective-slot-definition-class ((class persistent-metaclass) &rest initargs) "Chooses the persistent or transient effective slot definition class depending on the keyword." (let ((transient-p (getf initargs :transient)) (indexed-p (getf initargs :index))) (when (consp transient-p) (setq transient-p (car transient-p))) (when (consp indexed-p) (setq indexed-p (car indexed-p))) (cond ((and indexed-p transient-p) (error "Cannot declare a slot to be both indexed and transient")) (transient-p (find-class 'transient-effective-slot-definition)) (t (find-class 'persistent-effective-slot-definition))))) (defun ensure-transient-chain (slot-definitions initargs) (declare (ignore initargs)) (loop for slot-definition in slot-definitions always (transient slot-definition))) (defmethod compute-effective-slot-definition-initargs ((class persistent-metaclass) slot-definitions) (let ((initargs (call-next-method))) (if (ensure-transient-chain slot-definitions initargs) (setf initargs (append initargs '(:transient t))) (setf (getf initargs :allocation) :database)) ;; Effective slots are indexed only if the most recent slot definition ;; is indexed. NOTE: Need to think more about inherited indexed slots (if (indexed (first slot-definitions)) (append initargs '(:index t)) initargs))) (defun find-slot-def-by-name (class slot-name) (loop for slot-def in (class-slots class) when (eq (slot-definition-name slot-def) slot-name) do (return slot-def))) (defun persistent-slot-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-def in slot-definitions when (subtypep (type-of slot-def) 'persistent-effective-slot-definition) collect slot-def))) (defun transient-slot-defs (class) (let ((slot-definitions (class-slots class))) (loop for slot-def in slot-definitions unless (persistent-p slot-def) collect slot-def))) (defun persistent-slot-names (class) (mapcar #'slot-definition-name (persistent-slot-defs class))) (defun transient-slot-names (class) (mapcar #'slot-definition-name (transient-slot-defs class))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/package-new.lisp 2007/02/04 10:23:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; package.lisp -- package definition ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package :cl-user) (defpackage elephant-btrees (:use :closer-common-lisp) (:export #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup #:cursor-set #:cursor-set-range #:cursor-get-both #:cursor-get-both-range #:cursor-delete #:cursor-put #:cursor-pcurrent #:cursor-pfirst #:cursor-plast #:cursor-pnext #:cursor-pnext-dup #:cursor-pnext-nodup #:cursor-pprev #:cursor-pprev-nodup #:cursor-pset #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range)) (defpackage elephant (:use :closer-common-lisp :elephant-memutil :elephant-btrees) (:nicknames ele :ele) (: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* #:store-controller #:open-store #:close-store #:with-open-store #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:flush-instance-cache #:optimize-storage #:with-transaction #:start-ele-transaction #:commit-transaction #:abort-transaction #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key #:primary #:key-form #:key-fn #:btree-differ #:migrate #:*inhibit-slot-copy* #:run-elephant-thread ;; Class indexing management API [28 lines skipped] From ieslick at common-lisp.net Sun Feb 4 10:23:22 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 05:23:22 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070204102322.928337B01B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv10743/eslick/db-lisp Added Files: serializer3.lisp Log Message: Some working files for a lisp backend and a port to close-to-mop to cleanup the MOP implementation --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/serializer3.lisp 2007/02/04 10:23:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/serializer3.lisp 2007/02/04 10:23:22 1.1 (in-package :elephant-serializer2) ;; Protocol for backend ;; ;; What is a serializer? ;; - Determines a common serial format for objects; custom to common-lisp by helping to ;; bridge two environments and help folks not shoot themselves in the foot. ;; - For example, the class signature can be shot across on the first instance of a class ;; to validate against a remote class signature or we can use the local cached signature. ;; - Functions can be extracted and sent over in s-exp form. How about closures? (defun serialize (obj bs &aux cache obj-id) (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (labels (;; Circularity cache (reset-circularity-cache () (if (> (hash-table-size cache) 100) (setf cache (make-hash-table :test 'eq :size 50)) (clrhash cache)) (setf obj-id 0)) (caching-serializer (obj) (aif (gethash obj cache) (int sid bs) (progn (int (incf obj-id bs)) (setf (gethash obj cache) obj-id) (%serialize-cached obj)))) ;; Helper functions (byte (obj) (buffer-write-byte obj bs)) (int (obj) (buffer-write-int obj bs)) (float (obj) (buffer-write-float obj bs)) (double (obj) (buffer-write-double obj bs)) (string (obj) (buffer-write-string obj bs)) (uint (obj) (buffer-write-uint obj bs)) ;; Main dispatch (%serialize (obj) (etypecase obj (null (byte +nil+)) (character (byte +char+) (uint (char-code obj))) (fixnum (byte +fixnum+) int) (single-float (byte +single-float+) (float obj)) (double-float (byte +double-float+) (double obj)) (integer (mvbind (val size words) (bignum-features obj) (int words) (loop for i fixnum from 0 below size do #+(or cmu sbcl) (uint (%bignum-ref val i)) #+(or allegro lispworks openmcl) (uint (ldb (int-byte-spec i) val))))) (rational (byte +rational+) (%serialize (numerator obj)) (%serialize (denominator obj))) (string (byte (string-type obj)) (int (string-length obj)) (string obj)) (symbol (byte +symbol+) (serialize (symbol-name obj)) (aif (symbol-package obj) (%serialize (package-name obj)) (%serialize nil))) (pathname (byte +pathname+) (%serialize (namestring obj))) (cons (byte +cons+) (caching-serializer obj)) (hash-table (byte +hash-table+) (caching-serializer obj)) (array (byte +array+) (caching-serializer obj)) (standard-object (byte +object+) (caching-serializer obj)) ;; (structure-object (byte +struct+) ;; (caching-serializer obj)) ;; (standard-class (byte +class+) ;; name:symbol ;; superclasses ;; metaclasses? ;; direct slots (as defs) ;; (direct-slot (byte +class-slot+) ;; name:symbol ;; documentation ;; type ;; initform ;; initfunction ;; initargs ;; allocation ;; readers ;; writers ;; fixed-index? (persistent (byte +persistent+) (int (oid obj))))) ;; Compound objects that need circularity cache detection (%serialize-cached (obj) (etypecase (obj) (cons (%serialize (car obj)) (%serialize (cdr obj))) (hash-table (%serialize (hash-table-test obj)) (%serialize (hash-table-rehash-size obj)) (%serialize (hash-table-rehash-threshold obj)) (%serialize (hash-table-count obj)) (loop for key being the hash-key of obj using (hash-value value) do (%serialize key) (%serialize value))) (array (mvbind (type-byte fill adjust rank size) (array-properties obj) (byte (logior type-byte (if fill +fill-pointer-p+ 0) (if adjust +adjustable-p+ 0))) (int rank) (loop for i fixnum from 0 below rank do (int (array-dimension obj i))) (when fill (int (fill-pointer obj))) (loop for i fixnum from 0 below (array-total-size obj) do (%serialize (row-major-aref obj i))))) (standard-object (let ((rec (get-class-record obj))) (int (record-id rec)) (loop for slot in (record-slots rec) do (%serialize (slot-value obj slot)))))))) (reset-circularity-cache) (%serialize obj) bs)) From ieslick at common-lisp.net Mon Feb 5 00:32:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 19:32:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070205003227.2CDE65D009@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv20360 Modified Files: TODO Removed Files: ele-acache.asd Log Message: Enable use of %bignum-ref under sbcl; update TODO list and roadmap --- /project/elephant/cvsroot/elephant/TODO 2007/02/04 10:08:27 1.43 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/05 00:32:27 1.44 @@ -1,5 +1,5 @@ -Last updated: January 20, 2007 +Last updated: February 4, 2007 Ongoing release plan notes: @@ -7,14 +7,15 @@ -------------------------------------------- Active tasks: -- Resolve duplicate sorting guarantee in btree interface; currently supported - by BDB but not SQL and it is not tested in the regression suite +~ Resolve duplicate sorting guarantee in btree interface; currently supported + by BDB but not SQL and it is not tested in the regression suite (Robert) - 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] - Fix *dbconnection-spec* to support multiple controllers for multiple threads for CLSQL backend - Validate migration 0.6.0->0.6.1 +- Improve SQL serializer performance (Robert) BDB Features: - Determine how to detect deadlock conditions as an optional run-safe mode? @@ -141,13 +142,13 @@ - 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? + - Use SWIG and CFFI to better track changes in defconstant? (too expensive to be useful) - 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 + metaclasses.lisp and classes.lisp protocols (no love on first attempt) + (log these in Track) Features: - Persistent variables (abstraction that allows compound lisp objects at the cost of @@ -166,12 +167,10 @@ - A guide to performance - An overview of licensing issues... -0.7.0: Fast In-Memory Database (Not backwards compatible) --------------------------------------------------- +0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations +------------------------------------------------------------ - Full support for DCM or integration of DCM functionality - Integrate prevalence-like in-memory database system for single image, multiple-thread operation - - Fast serializer port w/ upgrade strategy and prevalence like storage solution - - Further improve SQL 64-bit serialization performance (if possible) - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be stored only as OIDs, and we should have a separate OID->class table. This way change-class can be handled correctly. This also non-trivially compresses storage @@ -194,25 +193,22 @@ -------------------------------------------------- - More work on testing, examples and documentation - Intent is for this to be a major, long-term supported release prior - to work on the new backend + to work on the new backend (i.e. patches against this release for + bugs rather than only available in latest development tree) -0.8.0 - Native Backend +0.8.0 - Supporting Tools Release -------------------------------------------------- - - A native lisp backend controller (Ian) - - Native persistent hashes (easy for BDB; can do on SQL backends?) + - Add special support (if any) for persistent graph structures & queries + (ala AllegroCache) - Support for cheap persistent sets (medium? can do on SQL?) - -0.9.0 - Supporting Tools Release --------------------------------------------------- + - Native persistent hashes (easy for BDB; can do on SQL backends?) - Support a simple object query language over the database - - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful for long-lived repositories or if you've forgotten a variable name -1.0 - Production release (1st fully supported version since 0.7.1) --------------------------------------------------- - - Finalize supported platforms (LispWorks? OpenMCL?) +1.0 - Final Production release (1st long-term version since 0.7.1) +------------------------------------------------------------------------ - Significant work on test cases & testing framework - Final pass of performance enhancements - Invite community review and testing From ieslick at common-lisp.net Mon Feb 5 00:32:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 19:32:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070205003227.621685F01E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv20360/src/db-clsql Modified Files: sql-controller.lisp Log Message: Enable use of %bignum-ref under sbcl; update TODO list and roadmap --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/04 04:34:56 1.15 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/05 00:32:27 1.16 @@ -340,7 +340,9 @@ (declare (ignore recover recover-fatal thread)) (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) - (new-p (not (probe-file (cadr (second (controller-spec sc)))))) + (path (cadr (second (controller-spec sc)))) + (new-p (or (eq :memory path) + (not (probe-file path)))) (con (clsql:connect (cdr (second (controller-spec sc))) :database-type dbtype :if-exists :old))) From ieslick at common-lisp.net Mon Feb 5 00:32:27 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 19:32:27 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205003227.99FF661025@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv20360/src/elephant Modified Files: serializer2.lisp Log Message: Enable use of %bignum-ref under sbcl; update TODO list and roadmap --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/04 04:34:57 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 00:32:27 1.13 @@ -328,9 +328,11 @@ do #+(or cmu sbcl allegro) (progn (setf (cdr byte-spec) (* 32 i)) - (buffer-write-uint (ldb byte-spec num) bs)) ;; (%bignum-ref num i) bs) + (%bignum-ref num i) bs) +;; (buffer-write-uint (ldb byte-spec num) bs)) #+(or lispworks openmcl) - (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs)))) + (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) + ))) ;;; ;;; DESERIALIZER From rread at common-lisp.net Mon Feb 5 00:40:31 2007 From: rread at common-lisp.net (rread) Date: Sun, 4 Feb 2007 19:40:31 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205004031.EE9B31C008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv20658 Modified Files: serializer1.lisp Log Message: Import the bignum-ref symbol --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/04 04:34:57 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 00:40:31 1.5 @@ -18,6 +18,9 @@ (defpackage :elephant-serializer1 (:use :cl :elephant :elephant-memutil) + #+(or cmu sbcl) + (:import-from :sb-bignum + %bignum-ref) (:import-from :elephant *resourced-byte-spec* get-cached-instance From rread at common-lisp.net Mon Feb 5 01:01:26 2007 From: rread at common-lisp.net (rread) Date: Sun, 4 Feb 2007 20:01:26 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205010126.8299C36018@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv24645/src/elephant Modified Files: serializer2.lisp Log Message: importing bignum reference --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 00:32:27 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 01:01:26 1.14 @@ -18,6 +18,9 @@ (defpackage :elephant-serializer2 (:use :cl :elephant :elephant-memutil :elephant-utils) + #+(or cmu sbcl) + (:import-from :sb-bignum + %bignum-ref) (:import-from :elephant *circularity-initial-hash-size* #+(or cmu sbcl allegro) @@ -499,4 +502,4 @@ do (setq num (dpb (buffer-read-uint bs) byte-spec num)) finally - (return (if positive num (- num)))))) \ No newline at end of file + (return (if positive num (- num)))))) From ieslick at common-lisp.net Mon Feb 5 03:18:22 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 4 Feb 2007 22:18:22 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205031822.7A83F5F042@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv8038/src/elephant Modified Files: serializer1.lisp serializer2.lisp Log Message: Small fix and a renaming to avoid warnings in SBCL --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 00:40:31 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 03:18:22 1.6 @@ -18,7 +18,10 @@ (defpackage :elephant-serializer1 (:use :cl :elephant :elephant-memutil) - #+(or cmu sbcl) + #+cmu + (:import-from :bignum + %bignum-ref) + #+sbcl (:import-from :sb-bignum %bignum-ref) (:import-from :elephant --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 01:01:26 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 03:18:22 1.15 @@ -18,12 +18,14 @@ (defpackage :elephant-serializer2 (:use :cl :elephant :elephant-memutil :elephant-utils) - #+(or cmu sbcl) + #+cmu + (:import-from :bignum + %bignum-ref) + #+sbcl (:import-from :sb-bignum %bignum-ref) (:import-from :elephant *circularity-initial-hash-size* - #+(or cmu sbcl allegro) get-cached-instance controller-symbol-cache controller-symbol-id-cache @@ -37,11 +39,12 @@ (in-package :elephant-serializer2) -(eval-when (compile) +(eval-when (:compile-toplevel) (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (inline serialize deserialize slots-and-values - deserialize-bignum))) + deserialize-bignum + %bignum-ref))) (uffi:def-type foreign-char :char) @@ -156,11 +159,11 @@ "Serialize a lisp value into a buffer-stream." (declare (type buffer-stream bs) (ignorable sc)) - (let ((*lisp-obj-id* -1) - (*circularity-hash* (get-circularity-hash))) + (let ((lisp-obj-id -1) + (circularity-hash (get-circularity-hash))) (labels ((%next-object-id () - (incf *lisp-obj-id*)) + (incf lisp-obj-id)) (%serialize (frob) (etypecase frob (fixnum @@ -214,12 +217,12 @@ (buffer-write-double frob bs)) (standard-object (buffer-write-byte +object+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) (declare (dynamic-extent svs)) @@ -238,12 +241,12 @@ (buffer-write-uint (char-code frob) bs)) (cons (buffer-write-byte +cons+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (car frob)) (%serialize (cdr frob)))))) (pathname @@ -252,12 +255,12 @@ (serialize-string pstring bs))) (hash-table (buffer-write-byte +hash-table+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (%serialize (hash-table-test frob)) (%serialize (hash-table-rehash-size frob)) (%serialize (hash-table-rehash-threshold frob)) @@ -269,11 +272,11 @@ (%serialize value)))))) ;; (structure-object ;; (buffer-write-byte +struct+ bs) - ;; (let ((idp (gethash frob *circularity-hash*))) + ;; (let ((idp (gethash frob circularity-hash))) ;; (if idp (buffer-write-int32 idp bs) ;; (progn - ;; (buffer-write-int32 (incf *lisp-obj-id*) bs) - ;; (setf (gethash frbo *circularity-hash*) *lisp-obj-id*) + ;; (buffer-write-int32 (incf lisp-obj-id) bs) + ;; (setf (gethash frbo circularity-hash) lisp-obj-id) ;; (%serialize (type-of frob)) ;; (let ((svs (slots-and-values frob))) ;; (declare (dynamic-extent svs)) @@ -282,12 +285,12 @@ ;; do (%serialize item))))))) (array (buffer-write-byte +array+ bs) - (let ((idp (gethash frob *circularity-hash*))) + (let ((idp (gethash frob circularity-hash))) (if idp (buffer-write-int32 idp bs) (progn (let ((id (%next-object-id))) (buffer-write-int32 id bs) - (setf (gethash frob *circularity-hash*) id)) + (setf (gethash frob circularity-hash) id)) (buffer-write-byte (logior (byte-from-array-type (array-element-type frob)) (if (array-has-fill-pointer-p frob) @@ -306,7 +309,7 @@ (%serialize (row-major-aref frob i))))))) ))) (%serialize frob) - (release-circularity-hash *circularity-hash*) + (release-circularity-hash circularity-hash) bs))) (defun serialize-bignum (frob bs) @@ -330,9 +333,7 @@ ;; and non-cons do #+(or cmu sbcl allegro) - (progn (setf (cdr byte-spec) (* 32 i)) - (%bignum-ref num i) bs) -;; (buffer-write-uint (ldb byte-spec num) bs)) + (buffer-write-uint (%bignum-ref num i) bs) #+(or lispworks openmcl) (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) ))) @@ -344,14 +345,14 @@ (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." (declare (type (or null buffer-stream) buf-str)) - (let ((*circularity-vector* (get-circularity-vector))) + (let ((circularity-vector (get-circularity-vector))) (labels ((lookup-id (id) - (if (>= id (fill-pointer *circularity-vector*)) nil - (aref *circularity-vector* id))) + (if (>= id (fill-pointer circularity-vector)) nil + (aref circularity-vector id))) (add-object (object) - (vector-push-extend object *circularity-vector* 50) - (1- (fill-pointer *circularity-vector*))) + (vector-push-extend object circularity-vector 50) + (1- (fill-pointer circularity-vector))) (%deserialize (bs) (declare (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) @@ -484,7 +485,7 @@ (null (return-from deserialize nil)) (buffer-stream (let ((result (%deserialize buf-str))) - (release-circularity-vector *circularity-vector*) + (release-circularity-vector circularity-vector) result)))))) (defun deserialize-bignum (bs length positive) From rread at common-lisp.net Mon Feb 5 16:09:25 2007 From: rread at common-lisp.net (rread) Date: Mon, 5 Feb 2007 11:09:25 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205160925.9F9FEA106@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv15946/src/elephant Modified Files: serializer2.lisp Log Message: Changing misspelled maybe-cons symbol. --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 03:18:22 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 16:09:25 1.16 @@ -410,7 +410,7 @@ ((= tag +hash-table+) (let* ((id (buffer-read-fixnum bs)) (maybe-hash (lookup-id id))) - (declare (dynamic-extent id maybe-cons) + (declare (dynamic-extent id maybe-hash) (type fixnum id)) (if maybe-hash maybe-hash (let* ((test (%deserialize bs)) From ieslick at common-lisp.net Mon Feb 5 17:22:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 12:22:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205172258.1208371119@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv29823/src/elephant Modified Files: serializer2.lisp Log Message: Support sqlite3 in delete script; fix allegro %bignum conditional bug --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 16:09:25 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 17:22:57 1.17 @@ -44,7 +44,7 @@ (inline serialize deserialize slots-and-values deserialize-bignum - %bignum-ref))) + #+(or sbcl cmu) %bignum-ref))) (uffi:def-type foreign-char :char) @@ -332,9 +332,9 @@ ;; there is an OpenMCL function which should work ;; and non-cons do - #+(or cmu sbcl allegro) + #+(or cmu sbcl) (buffer-write-uint (%bignum-ref num i) bs) - #+(or lispworks openmcl) + #+(or lispworks openmcl allegro) (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) ))) From ieslick at common-lisp.net Mon Feb 5 17:22:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 12:22:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070205172258.31DC771135@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv29823/tests Modified Files: delscript.sh Log Message: Support sqlite3 in delete script; fix allegro %bignum conditional bug --- /project/elephant/cvsroot/elephant/tests/delscript.sh 2007/01/22 16:17:44 1.3 +++ /project/elephant/cvsroot/elephant/tests/delscript.sh 2007/02/05 17:22:58 1.4 @@ -9,4 +9,6 @@ rm testbdb/testsbdb rm testbdb/__* rm testbdb/log* -rm testbdb/VERSION \ No newline at end of file +rm testbdb/VERSION +rm sqlite3-test.db +rm sqlite3-test2.db \ No newline at end of file From ieslick at common-lisp.net Mon Feb 5 19:32:03 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 14:32:03 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/henrik Message-ID: <20070205193203.B1EB734000@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/henrik In directory clnet:/tmp/cvs-serv18943/henrik Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/henrik added to the repository From ieslick at common-lisp.net Mon Feb 5 19:33:11 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 14:33:11 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070205193311.137D27D002@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv19051 Modified Files: INSTALL TODO elephant.asd Log Message: Integrated Henrik's changes, except for the sbcl/%bignum-ref in serializer2.lisp which I believed we fixed by importing it from :sb-bignum --- /project/elephant/cvsroot/elephant/INSTALL 2007/01/25 18:17:59 1.20 +++ /project/elephant/cvsroot/elephant/INSTALL 2007/02/05 19:33:10 1.21 @@ -15,7 +15,7 @@ UFFI 1.5.4+ - http://uffi.b9.com/ A Backend Database: -1) Oracle Berkeley DB 4.4 or 4.5 - http://www.oracle.com/database/berkeley-db.html +1) Oracle Berkeley DB 4.5 - http://www.oracle.com/database/berkeley-db.html 2) CLSQL - http://clsql.b9.com/ with an appropriate SQL installation. Tested with SQlite3 and Postgresql so far @@ -57,7 +57,7 @@ 2) Install UFFI -3) Install a backend: Either Berkeley DB 4.4, PostGresql, or SQLite 3. +3) Install a backend: Either Berkeley DB 4.5, PostGresql, or SQLite 3. ------- SQL @@ -67,11 +67,13 @@ other the heading "SQL-BACK-END". ------------- -Berkeley 4.4: +Berkeley 4.5: ------------- -(Note: 0.6.0 users used 4.3; upgrade to 4.4 and run 0.6.1+ and - your existing DB will automatically upgrade when the DB is opened) +(Note: 0.6.0 required BDB 4.3; to upgrade 0.6.0 to 0.6.1, upgrade BDB to 4.5, + modify my-config.sexp appropriately then run 0.6.1+; your underlying Berekely DB + files will automatically upgrade when the DB is opened. To use 0.6.1, you will + have to manually migrate your 0.6.0 database to a fresh database created in 0.6.1) Under Un*x, you may actually already have this installed, though it may be compiled with funny options, so if things don't work @@ -79,11 +81,11 @@ for this, as I'm sure do other BSDs (including DarwinPorts/Fink.) Take note of where libdb.so and db.h are installed, usually: - /usr/local/BerkeleyDB.4.4/lib/libdb.so and - /usr/local/BerkeleyDB.4.4/include/db.h, or + /usr/local/BerkeleyDB.4.5/lib/libdb.so and + /usr/local/BerkeleyDB.4.5/include/db.h, or - /usr/local/lib/db44/libdb.so and - /usr/local/include/db44/db.h.) + /usr/local/lib/db45/libdb.so and + /usr/local/include/db45/db.h.) a) Site specific configuration --- /project/elephant/cvsroot/elephant/TODO 2007/02/05 00:32:27 1.44 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/05 19:33:10 1.45 @@ -6,18 +6,20 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -Active tasks: +ALPHA RELEASE TASKS + +Bug and feature fixes: ~ Resolve duplicate sorting guarantee in btree interface; currently supported by BDB but not SQL and it is not tested in the regression suite (Robert) -- 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] - Fix *dbconnection-spec* to support multiple controllers for multiple threads for CLSQL backend - Validate migration 0.6.0->0.6.1 -- Improve SQL serializer performance (Robert) +- Fix cur-del2 failure under SBCL -BDB Features: +BDB Features/Cleanup: +- 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] - Determine how to detect deadlock conditions as an optional run-safe mode? - Automatically run db_deadlock when opening a bdb backend? Requires path to functions and ability to launch shell command. Closing the store stops the @@ -26,22 +28,25 @@ - Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API -ALPHA RELEASE ITEMS +BETA RELEASE TASKS 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 +- Validate OpenMCL 1.1 on Mac OS X +- Validate Lispworks +- 64-bit lisp verification -Stability: +Stability and Performance: - Review and address all NOTE comments in the code +- Review SBCL string serialization performance +- Improve SQL base-64 serializer performance? +- Improve SQL secondary cursor performance (Robert) Migration: - Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs -BETA RELEASE ITEMS +FINAL RELEASE TASKS Test coverage: - Test for optimize storage method (just add probe-file methods to get file size) --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/03 00:57:33 1.26 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/05 19:33:10 1.27 @@ -109,7 +109,7 @@ (list #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" - #+(or x8664-target) "-arch x86_64" + #+(or :X86-64) "-arch x86_64" "-Wall" "-fPIC" "-O3" From ieslick at common-lisp.net Mon Feb 5 19:33:11 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 14:33:11 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/henrik Message-ID: <20070205193311.4355C7D164@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/henrik In directory clnet:/tmp/cvs-serv19051/src/contrib/henrik Added Files: install-bdb.sh Log Message: Integrated Henrik's changes, except for the sbcl/%bignum-ref in serializer2.lisp which I believed we fixed by importing it from :sb-bignum --- /project/elephant/cvsroot/elephant/src/contrib/henrik/install-bdb.sh 2007/02/05 19:33:11 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/henrik/install-bdb.sh 2007/02/05 19:33:11 1.1 #!/bin/sh # Latest 4.5 release from http://www.oracle.com/technology/software/products/berkeley-db/db/index.html OLDDIR=`pwd` VERSION="4.5.20" echo Downloading $VERSION if [ -d db-$VERSION ]; then echo "Berkeley DB $VERSION already downloaded, will not install it" else wget http://download.oracle.com/berkeley-db/db-$VERSION.tar.gz tar -xvf db-$VERSION.tar.gz cd db-$VERSION/build_unix/ ../dist/configure make #Check for sufficient write privileges if [ -w /usr/local/BerkeleyDB.4.5 ] ; then make install else #Install as super user echo "Elephant install-bdb" echo "Make install needs write permissions to /usr/local, running:" echo "sudo make install" sudo make install fi fi cd $OLDDIR echo "Create my-config.sexp" if [ -e /usr/local/BerkeleyDB.4.5/lib/ ] ; then if [ -e my-config.sexp ] ; then echo "my-config.sexp already exists, will not overwrite it" else echo '' > my-config.sexp echo '((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.5/include/")' >> my-config.sexp echo ' (:berkeley-db-lib-dir . "/usr/local/BerkeleyDB.4.5/lib/")' >> my-config.sexp echo ' (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.5/lib/libdb-4.5.so")' >> my-config.sexp echo ' (:pthread-lib . nil)' >> my-config.sexp echo ' (:clsql-lib . nil))' >> my-config.sexp fi fi From ieslick at common-lisp.net Mon Feb 5 19:33:11 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 5 Feb 2007 14:33:11 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070205193311.758457D002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv19051/src/elephant Modified Files: serializer2.lisp Log Message: Integrated Henrik's changes, except for the sbcl/%bignum-ref in serializer2.lisp which I believed we fixed by importing it from :sb-bignum --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 17:22:57 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 19:33:11 1.18 @@ -152,8 +152,9 @@ ;; SERIALIZER ;; -(defconstant +2^32+ 4294967296) -(defconstant +2^64+ 18446744073709551616) +(defconstant +2^31+ (expt 2 31)) +(defconstant +2^32+ (expt 2 32)) +(defconstant +2^64+ (expt 2 64)) (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." @@ -173,7 +174,7 @@ (buffer-write-int32 frob bs)) (progn (assert (< #.most-positive-fixnum +2^64+)) - (if (< frob +2^32+) + (if (< (abs frob) +2^32+) (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) From rread at common-lisp.net Mon Feb 5 19:33:46 2007 From: rread at common-lisp.net (rread) Date: Mon, 5 Feb 2007 14:33:46 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070205193346.00A8E5D009@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv19168 Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Some things to test just pieces --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/04 10:08:28 1.23 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/05 19:33:46 1.24 @@ -161,6 +161,7 @@ (defun do-indexing-tests (&optional (spec *default-spec*)) "Just test indexing" (with-open-store (spec) + (make-stress-classes) (print (do-test 'indexing-basic)) (print (do-test 'indexing-inherit)) (print (do-test 'indexing-range)) @@ -169,6 +170,76 @@ (print (do-test 'indexing-redef-class)) (print (do-test 'indexing-timing)))) +(defun do-collection-tests (&optional (spec *default-spec*)) + "Just test indexing" + (with-open-store (spec) + (print (do-test 'basicpersistence)) + (print (do-test 'testoid)) + (print (do-test 'btree-make)) + (print (do-test 'btree-put)) + (print (do-test 'btree-get)) + (print (do-test 'remove-kv)) + (print (do-test 'removed)) + (print (do-test 'map-btree)) + (print (do-test 'indexed-btree-make)) + (print (do-test 'indexed-btree-make)) + (print (do-test 'add-indices)) + (print (do-test 'test-indices)) + (print (do-test 'indexed-put)) + (print (do-test 'indexed-get)) + (print (do-test 'simple-slot-get)) + (print (do-test 'indexed-get-from-slot1)) + (print (do-test 'indexed-get-from-slot2)) + (print (do-test 'remove-kv-indexed)) + (print (do-test 'no-key-nor-indices)) + (print (do-test 'remove-kv-from-slot1)) + (print (do-test 'no-key-nor-indices-slot1)) + (print (do-test 'remove-kv-from-slot2)) + (print (do-test 'no-key-nor-indices-slot2)) + (print (do-test 'map-indexed)) + (print (do-test 'get-first)) + (print (do-test 'get-first2)) + (print (do-test 'get-last)) + (print (do-test 'get-last2)) + (print (do-test 'set)) + (print (do-test 'set2)) + (print (do-test 'set-range)) + (print (do-test 'set-range2)) + (print (do-test 'rem-kv)) + (print (do-test 'rem-idexkv)) + (print (do-test 'make-indexed2)) + (print (do-test 'add-indices2)) + (print (do-test 'put-indexed2)) + (print (do-test 'get-indexed2)) + (print (do-test 'get-from-index3)) + (print (do-test 'dup-test)) + (print (do-test 'nodup-test)) + (print (do-test 'prev-nodup-test)) + (print (do-test 'pnodup-test)) + (print (do-test 'pprev-nodup-test)) + (print (do-test 'cur-del1)) + (print (do-test 'indexed-delete)) + (print (do-test 'test-deleted)) + (print (do-test 'indexed-delete2)) + (print (do-test 'test-deleted2)) + (print (do-test 'cur-del2)) + (print (do-test 'get-both)) + (print (do-test 'pget-both)) + (print (do-test 'pget-both-range)) + (print (do-test 'pcursor)) + (print (do-test 'newindex)) + (print (do-test 'pcursor2)) + (print (do-test 'add-get-remove)) + (print (do-test 'add-get-remove-symbol)) + (print (do-test 'existsp)) + )) + +(defun do-cur-del2-test (&optional (spec *default-spec*)) + "Just test indexing" + (with-open-store (spec) + (print (do-test 'cur-del2)) + )) + (defun do-crazy-pg-tests() "Specific problematic pg tests" (open-store *testpg-spec*) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/03 04:09:14 1.22 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/05 19:33:46 1.23 @@ -321,7 +321,6 @@ (:metaclass persistent-metaclass)) (disable-class-indexing 'idx-eight :errorp nil) (setf (find-class 'idx-eight nil) nil)) - ;; (format t "sc: ~A ct: ~A~%" *store-controller* *current-transaction*) (defclass idx-eight () ((slot1 :accessor slot1 :initarg :slot1 :index t) @@ -330,13 +329,11 @@ (slot4 :accessor slot4 :initarg :slot4 :index t) (slot5 :accessor slot5 :initarg :slot5)) (:metaclass persistent-metaclass)) - (let ((o1 nil) (o2 nil)) (with-transaction () (setf o1 (make-instance 'idx-eight :slot1 1 :slot2 2 :slot3 3 :slot4 4 :slot5 5)) (setf o2 (make-instance 'idx-eight :slot1 10 :slot2 20 :slot3 30 :slot4 40 :slot5 50))) - (defclass idx-eight () ((slot1 :accessor slot1 :initarg :slot1 :initform 11) (slot2 :accessor slot2 :initarg :slot2 :initform 12 :index t) @@ -344,23 +341,35 @@ (slot6 :accessor slot6 :initarg :slot6 :initform 14 :index t) (slot7 :accessor slot7 :initarg :slot7)) (:metaclass persistent-metaclass)) - - (values - (and (eq (slot1 o1) 1) - (signals-error (get-instances-by-value 'idx-eight 'slot1 1))) - (and (eq (slot2 o1) 2) - (eq (length (get-instances-by-value 'idx-eight 'slot2 2)) 1)) - (eq (slot3 o1) 13) ;; transient values not preserved (would be inconsistent) - (and (not (slot-exists-p o1 'slot4)) - (not (slot-exists-p o1 'slot5)) - (signals-error (get-instances-by-value 'idx-eight 'slot4 4))) - (eq (slot6 o1) 14) - (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2) - (and ;;(slot-exists-p o1 'slot7) - (not (slot-boundp o1 'slot7))) - (and ;;(slot-exists-p o2 'slot7) - (not (slot-boundp o2 'slot7)))))) - t t t t t t t t) + ;; (format t "indexing redef-class d~%") + (let (( + v1 + (and (eq (slot1 o1) 1) + (signals-error (get-instances-by-value 'idx-eight 'slot1 1)))) + ;; (v1x (format t "indexing redef-class v1x~%")) + (v2 (and (eq (slot2 o1) 2) + (eq (length (get-instances-by-value 'idx-eight 'slot2 2)) 1))) + ;; (v2x (format t "indexing redef-class v2x~%")) + (v3 (eq (slot3 o1) 13)) ;; transient values not preserved (would be inconsistent) + ;; (v3x (format t "indexing redef-class v3x~%")) + (v4 (and (not (slot-exists-p o1 'slot4)) + (not (slot-exists-p o1 'slot5)) + (signals-error (get-instances-by-value 'idx-eight 'slot4 4)))) + ;; (v4x (format t "indexing redef-class v4x~%")) + (v5 (eq (slot6 o1) 14)) + ;; (v5x (format t "indexing redef-class v5x~%")) + (v6 (eq (length (get-instances-by-value 'idx-eight 'slot6 14)) 2)) + ;; (v6x (format t "indexing redef-class v6x~%")) + (v7 (and ;;(slot-exists-p o1 'slot7) + (not (slot-boundp o1 'slot7)))) + ;; (v7x (format t "indexing redef-class v7x~%")) + (v8 (and ;;(slot-exists-p o2 'slot7) + (not (slot-boundp o2 'slot7)))) + ;; (v8x (format t "indexing redef-class v8x~%"))) + ) + (values + v1 v2 v3 v4 v5 v6 v7 v8)))) + t t t t t t t t) ;; create 500 objects, write each object's slots @@ -387,7 +396,8 @@ (defun indexed-stress-setup (count class-name &rest inst-args) (dotimes (i count) - (apply #'make-instance class-name :stress1 i inst-args))) + (progn + (apply #'make-instance class-name :stress1 i inst-args)))) (defun normal-range-lookup (count size) "Given stress1 slot has values between 1 and count, extract a range of size size that starts @@ -415,11 +425,14 @@ (get-instances-by-range class 'stress1 start end))) (defparameter *stress-count* 700) +;;(defparameter *stress-count* 70) (defparameter *range-size* 80) (deftest indexing-timing (progn (make-stress-classes) +;; (trace elephant::drop-pobject) +;; (trace remove-kv) (let ((insts (get-instances-by-class 'stress-index)) (start nil) (end nil) @@ -428,15 +441,16 @@ (when insts (drop-instances insts :sc *store-controller*)) -;; (format t "~%Stress test normal setup time (~A):~%" *stress-count*) + (format t "Got done with that~%") + (format t "~%Stress test normal setup time (~A):~%" *stress-count*) (with-transaction () (normal-stress-setup *stress-count* 'stress-normal :stress2 10)) -;; (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) + (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) (with-transaction () (indexed-stress-setup *stress-count* 'stress-index :stress2 10)) -;; (format t "~%Stress test normal lookup time (~A):~%" *range-size*) + (format t "~%Stress test normal lookup time (~A):~%" *range-size*) (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) @@ -444,7 +458,9 @@ (setf end (get-internal-run-time)) (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) -;; (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) + (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) +;; (trace indexed-range-lookup) +;; (trace get-instances-by-range) (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) From rread at common-lisp.net Tue Feb 6 16:32:02 2007 From: rread at common-lisp.net (rread) Date: Tue, 6 Feb 2007 11:32:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070206163202.9FF5C5305E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv3412 Modified Files: testindexing.lisp Log Message: Improvements in the indexing test --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/05 19:33:46 1.23 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/06 16:32:02 1.24 @@ -389,15 +389,22 @@ (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) (:metaclass persistent-metaclass))) +(defparameter *stress-count* 700) +(defparameter *range-size* 10) + +(defun non-monotonic-stress-def (i) + (- *stress-count* i) +) + (defun normal-stress-setup (count class-name &rest inst-args) (setf normal-index (make-btree)) (dotimes (i count) - (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) + (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 (non-monotonic-stress-def i) inst-args)))) (defun indexed-stress-setup (count class-name &rest inst-args) (dotimes (i count) (progn - (apply #'make-instance class-name :stress1 i inst-args)))) + (apply #'make-instance class-name :stress1 (non-monotonic-stress-def i) inst-args)))) (defun normal-range-lookup (count size) "Given stress1 slot has values between 1 and count, extract a range of size size that starts @@ -410,8 +417,11 @@ (multiple-value-bind (value? key val) (cursor-next cur) (declare (ignore key)) (cond ((or (not value?) - (and value? - (>= (stress1 val) end))) +;; I think these lines were in correctly assuming a particular order. +;; (and value? +;; (>= (stress1 val) end) +;; ) + ) (return-from normal-range-lookup objects)) ((and value? (>= (stress1 val) start) @@ -421,56 +431,52 @@ (defun indexed-range-lookup (class count size) (let* ((start (/ count 2)) - (end (1- (+ start size)))) + (end (1- (+ start size))) + (res (get-instances-by-range class 'stress1 start end))) + res + )) + -(defparameter *stress-count* 700) -;;(defparameter *stress-count* 70) -(defparameter *range-size* 80) (deftest indexing-timing (progn (make-stress-classes) -;; (trace elephant::drop-pobject) -;; (trace remove-kv) (let ((insts (get-instances-by-class 'stress-index)) (start nil) (end nil) + (normal-check nil) + (index-check nil) (normal-time 0) (index-time 0)) (when insts (drop-instances insts :sc *store-controller*)) - (format t "Got done with that~%") - (format t "~%Stress test normal setup time (~A):~%" *stress-count*) (with-transaction () (normal-stress-setup *stress-count* 'stress-normal :stress2 10)) - (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) (with-transaction () (indexed-stress-setup *stress-count* 'stress-index :stress2 10)) - (format t "~%Stress test normal lookup time (~A):~%" *range-size*) (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) - (normal-range-lookup *stress-count* *range-size*)) + (push (length (normal-range-lookup *stress-count* *range-size*)) + normal-check)) (setf end (get-internal-run-time)) (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) - (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) -;; (trace indexed-range-lookup) -;; (trace get-instances-by-range) (setf start (get-internal-run-time)) (dotimes (i *range-size*) (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + (push (length (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + index-check)) (setf end (get-internal-run-time)) (setf index-time (/ (- end start 0.0) internal-time-units-per-second)) - (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%" *range-size* *stress-count* normal-time index-time) - (> normal-time index-time))) + (and (equal normal-check index-check) (> normal-time index-time))) + ) t) From rread at common-lisp.net Wed Feb 7 22:54:13 2007 From: rread at common-lisp.net (rread) Date: Wed, 7 Feb 2007 17:54:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070207225413.54C4F3405C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv4302/src/db-clsql Modified Files: package.lisp sql-controller.lisp Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2006/11/11 18:41:11 1.1 +++ /project/elephant/cvsroot/elephant/src/db-clsql/package.lisp 2007/02/07 22:54:12 1.2 @@ -20,5 +20,8 @@ (defpackage db-clsql (:use :common-lisp :uffi :cl-base64 - :elephant :elephant-memutil :elephant-backend)) + :elephant :elephant-memutil :elephant-backend +;; :elephant-utils + #+sbcl :sb-thread + )) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/05 00:32:27 1.16 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/07 22:54:12 1.17 @@ -22,14 +22,64 @@ ;; The main SQL Controller Class ;; +;; Every actual CL-SQL connection has to be in a separate thread. +;; My solution to this is to keep a map of threads, and reuse +;; connections within a certain thread. +;; This seems to be effective under SBCL; as of 06-Feb-2007 we +;; don't necessarily have a way to do this under the other implementations +;; (see src/utils/lock.lisp.) + (defclass sql-store-controller (store-controller) - ((db :accessor controller-db :initarg :db :initform nil)) + ( +;; (db :accessor controller-db :initarg :db :initform nil) + (dbcons :accessor controller-db-table :initarg :db :initform nil) + ) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera. This is the Postgresql-specific subclass of store-controller.")) + +;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, +;; unpleasant bug when ASDF tries to load this stuff. +;; (defvar *thread-table-lock* nil) +;; (defvar *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) + +(defvar *thread-table-lock* nil) + +(defun insure-thread-table-lock () + (if (null *thread-table-lock*) +;; nil +;; (setq *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) + (setq *thread-table-lock* (elephant::ele-make-lock)) + ) +) + + +(defun thread-hash () + (elephant::ele-thread-hash-key) +) + + +(defmethod controller-db ((sc sql-store-controller)) + (elephant::ele-with-lock (*thread-table-lock*) + (let ((curcon (gethash (thread-hash) (controller-db-table sc)))) + (if curcon + curcon + (let* ((dbtype (car (second (controller-spec sc)))) + (con (clsql:connect (cdr (second (controller-spec sc))) + :database-type dbtype + :pool t + :if-exists :new))) + (setf (gethash (thread-hash) (controller-db-table sc)) + con) + con) + ) + ) + )) + + (eval-when (:compile-toplevel :load-toplevel) (register-backend-con-init :clsql 'sql-test-and-construct)) @@ -270,15 +320,25 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. - (clsql::create-table [keyvalue] - - ;; This is most likely to work with any database system.. - '( - ([clctn_id] integer :not-null) - ([key] text :not-null) - ([value] text) - ) - :database con) + (clsql::create-sequence [serial] :database con) + (clsql::query + (format nil "create table keyvalue ( + pk integer PRIMARY KEY DEFAULT nextval('serial'), + clctn_id integer NOT NULL, + key varchar NOT NULL, + value varchar + )") + :database con) + + ;; (clsql::create-table [keyvalue] + + ;; ;; This is most likely to work with any database system.. + ;; '( + ;; ([clctn_id] integer :not-null) + ;; ([key] text :not-null) + ;; ([value] text) + ;; ) + ;; :database con) ;; :constraints '("PRIMARY KEY (clctn_id key)" ;; "UNIQUE (clctn_id,key)") @@ -338,6 +398,7 @@ (recover-fatal nil) (thread t)) (declare (ignore recover recover-fatal thread)) + (insure-thread-table-lock) (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) (path (cadr (second (controller-spec sc)))) @@ -346,7 +407,8 @@ (con (clsql:connect (cdr (second (controller-spec sc))) :database-type dbtype :if-exists :old))) - (setf (slot-value sc 'db) con) + (setf (slot-value sc 'dbcons) (make-hash-table :test 'equal)) +;; (setf (slot-value sc 'db) con) ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) @@ -365,19 +427,45 @@ ) ) +(defmethod connection-ok-p ((sc sql-store-controller)) + (connection-ok-p-con (controller-db sc))) + +(defun connection-ok-p-con (con) + (let ((str (format nil "~A" con))) + (search "OPEN" str) + )) + +(defmethod connection-really-ok-p ((sc sql-store-controller)) + ;; I don't really have a good way of doing this, but + ;; one thing that is sure is that the the print form should + ;; have OPEN and not CLOSED in it. + ) + +(defmethod controller-status ((sc sql-store-controller)) +;; This is a crummy way to deal with status; we really want +;; to return something we can compute against. + (clsql:status) + ) + + (defmethod reconnect-controller ((sc sql-store-controller)) - (setf (controller-db sc) - (clsql:reconnect :database (controller-db sc))) + (clsql:reconnect :database (controller-db sc) :force nil) +;; (setf (controller-db sc) +;; (clsql:reconnect :database (controller-db sc))) ) + (defmethod close-controller ((sc sql-store-controller)) - (when (slot-value sc 'db) - ;; close the connection - ;; (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) + (maphash #'(lambda (k v) + (ignore-errors + (if (connection-ok-p-con v) + (clsql:disconnect :database v) + ) + ) + ) + (controller-db-table sc) + ) (setf (slot-value sc 'root) nil) - )) + ) ;; Because this is part of the public ;; interface that I'm tied to, it has to accept a store-controller... @@ -401,7 +489,6 @@ (defun sql-add-to-clcn (clcn key value sc &key (insert-only nil)) - (declare (ignore sc)) (assert (integerp clcn)) (let ((con (controller-db sc)) (vbs @@ -456,17 +543,17 @@ (let* ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc)) - (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by value offset ~A limit 1 " + (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " clcn kbs n)) (tuples -;; (clsql::query offsetquery :database con) - (clsql::select [value] - :from [keyvalue] - :where [and [= [clctn_id] clcn] [= [key] kbs]] - :database con - ) + (clsql::query offsetquery :database con) +;; (clsql::select [value] +;; :from [keyvalue] +;; :where [and [= [clctn_id] clcn] [= [key] kbs]] +;; :database con +;; ) ) ) ;; Get the lowest value by sorting and taking the first value; @@ -478,20 +565,21 @@ ;; that efficiently without changing the database structure; ;; but that's OK, I could add a column to support that ;; relatively easily later on. -;; (if (and (> (length tuples) 1)) -;; (format t "l = ~A~%" (length tuples)) -;; ) - (if (< n (length tuples)) -;; (values (deserialize-from-base64-string (car (nth n tuples)) sc) -;; t) - (values (nth n (sort - (mapcar - #'(lambda (x) - (deserialize-from-base64-string (car x) sc)) - tuples) - #'my-generic-less-than)) + (if tuples + (values (deserialize-from-base64-string (caar tuples) sc) t) - (values nil nil)))) + (values nil nil)) + +;; (if (< n (length tuples)) +;; (values (nth n (sort +;; (mapcar +;; #'(lambda (x) +;; (deserialize-from-base64-string (car x) sc)) +;; tuples) +;; #'my-generic-less-than)) +;; t) +;; (values nil nil)) +)) (defun sql-get-from-clcn-cnt (clcn key sc) (assert (integerp clcn)) @@ -509,7 +597,7 @@ (assert (integerp clcn)) (let* ((con (controller-db sc)) (tuples - (clsql::select [key] [value] + (clsql::select [pk] [key] [value] :from [keyvalue] :where [and [= [clctn_id] clcn]] :database con @@ -559,7 +647,6 @@ (defun sql-remove-from-clcn (clcn key sc) - (declare (ignore sc)) (assert (integerp clcn)) (let ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc)) From rread at common-lisp.net Wed Feb 7 22:54:12 2007 From: rread at common-lisp.net (rread) Date: Wed, 7 Feb 2007 17:54:12 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070207225412.DB48D330A1@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4302 Modified Files: INSTALL ele-clsql.asd Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/INSTALL 2007/02/05 19:33:10 1.21 +++ /project/elephant/cvsroot/elephant/INSTALL 2007/02/07 22:54:12 1.22 @@ -117,7 +117,7 @@ 4) Compile and load Elephant: The new backend load process should work automatically on Un*x -systems but if there are problems with loading foreign libraries, +systems but if there are probolems with loading foreign libraries, then you can test your C tools setup with 'make' in the elephant root directory. This will build the common memutils library in src/memutil/libmemutil.so/dylib that all backends require. @@ -168,7 +168,7 @@ (asdf:operate 'asdf:load-op :elephant-tests) (in-package :ele-tests) (setf *default-spec* ) - where = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } + Where = { *testsqlite3-spec* | *testpg-spec* | *testbdb-spec* } (do-backend-tests) This will test the standalone API for your backend. Currently all tests are --- /project/elephant/cvsroot/elephant/ele-clsql.asd 2006/11/11 18:41:10 1.8 +++ /project/elephant/cvsroot/elephant/ele-clsql.asd 2007/02/07 22:54:12 1.9 @@ -57,7 +57,8 @@ (:file "sql-controller") (:file "sql-transaction") (:file "sql-collections")) - :serial t)))) + :serial t + )))) :depends-on (:elephant :clsql :cl-base64)) From rread at common-lisp.net Wed Feb 7 22:54:13 2007 From: rread at common-lisp.net (rread) Date: Wed, 7 Feb 2007 17:54:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070207225413.D7D993605A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv4302/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Commiting a thread-safe version of the SQL side (but SBCL-depdent.) --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/05 19:33:46 1.24 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/07 22:54:13 1.25 @@ -165,10 +165,12 @@ (print (do-test 'indexing-basic)) (print (do-test 'indexing-inherit)) (print (do-test 'indexing-range)) + (print (do-test 'indexing-wipe-index)) (print (do-test 'indexing-reconnect-db)) (print (do-test 'indexing-change-class)) (print (do-test 'indexing-redef-class)) - (print (do-test 'indexing-timing)))) + (print (do-test 'indexing-timing)) + )) (defun do-collection-tests (&optional (spec *default-spec*)) "Just test indexing" --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/06 16:32:02 1.24 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/07 22:54:13 1.25 @@ -204,7 +204,9 @@ (defclass idx-five-del () ((slot1 :initarg :slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) - + (format t "r1 = ~A~%" r1) + (format t "r1 = ~A~%" (get-index (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)) + 'slot1)) (values (eq (length r1) 1) (signals-error (get-instances-by-value 'idx-five-del 'slot1 1)) From ieslick at common-lisp.net Thu Feb 8 15:51:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 10:51:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070208155102.3A6FB3604E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27108 Modified Files: serializer2.lisp Log Message: Missing checking from Henrik's changes --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/05 19:33:11 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:51:01 1.19 @@ -21,9 +21,6 @@ #+cmu (:import-from :bignum %bignum-ref) - #+sbcl - (:import-from :sb-bignum - %bignum-ref) (:import-from :elephant *circularity-initial-hash-size* get-cached-instance @@ -44,7 +41,7 @@ (inline serialize deserialize slots-and-values deserialize-bignum - #+(or sbcl cmu) %bignum-ref))) + #+cmu %bignum-ref))) (uffi:def-type foreign-char :char) @@ -329,14 +326,14 @@ (buffer-write-byte +positive-bignum+ bs)) (buffer-write-int needed bs) (loop for i fixnum from 0 below word-size - ;; this ldb is consing on CMUCL! + ;; this ldb is consing on CMUCL/OpenMCL! ;; there is an OpenMCL function which should work ;; and non-cons do - #+(or cmu sbcl) - (buffer-write-uint (%bignum-ref num i) bs) - #+(or lispworks openmcl allegro) - (buffer-write-uint (ldb (byte 32 (* 32 i)) num) bs) + #+cmu + (buffer-write-uint32 (%bignum-ref num i) bs) ;; should fail under 64-bit CMU + #-cmu + (buffer-write-uint32 (ldb (byte 32 (* 32 i)) num) bs) ))) ;;; From ieslick at common-lisp.net Thu Feb 8 15:57:20 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 10:57:20 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070208155720.23CEE3C006@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv28034 Modified Files: TODO btree.lisp file.lisp octet-stream.lisp package.lisp Added Files: pages.lisp Removed Files: buffers.lisp Log Message: Working changes for db-lisp backend --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/08 15:57:19 1.2 @@ -1,4 +1,34 @@ +High level lisp backend design: +- Page storage, layout policy; lisp array or foreign data? + - key length limits + - ordering functions + - secondary index functions +- Locking policy (in-memory) + - blocking or optimistic concurrency + - how to signal +- Transaction ids +- Logging transactions and side effects + +Performance considerations: +- Slot access is usually local to objects +- Variable length objects are fundamental +- How to handle large blobs? + +Foreign array blocks? Faster copies, +avoid GC overhead, easy to write to +disk, static type, fast pointer ops. + +Aligned data types to simplify pointers + +Index pages (btree catalogs) +Object pages (sequences of slots) +Blob pages + +PTHREAD mutex speed + +=========================== + A lisp backend will need: - read/write binary sequences - move/cache binary pages to/from disk --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 15:57:19 1.2 @@ -1,2 +1,55 @@ (in-package :db-lisp) +;; Data layout +;; - page types: index, leaf, blobs + +(defparameter *type-table* + '((0 . :unknown) + (1 . :index) + (2 . :leaf) + (3 . :blob))) + +(defun get-type (byte) + (assert (<= byte (car (last *type-table*)))) + (cdr (assoc byte *type-table*))) + +(defun get-type-id (type-symbol) + (loop for (id symbol) in *type-table* do + (when (eq type-symbol symbol) + (return id)) + finally (error "Invalid page type identifier"))) + +;; +;; Read/Write references +;; + +;; +;; Page headers +;; + +(defun read-page-header (page) + (with-buffer-streams (header) + (buffer-write-from-array-offset (page-buffer page) 0 1 header) + (setf (page-type page) (get-type (buffer-read-byte header))))) + +(defun write-page-header (page) + (with-buffer-streams (header) + (buffer-write-byte (get-type-id (page-type page)) header) + (buffer-read-to-array-offset (page-buffer page) 0 header))) + +;; +;; Indexes: +;; + + + +;; User Operations: +;; btree-create + +;; btree-search +;; btree-insert + +;; Internal operations: +;; btree-split-child +;; btree-insert-nonfull + --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/08 15:57:19 1.2 @@ -2,17 +2,17 @@ (in-package :db-lisp) (defclass binary-file () - ((stream :initarg :stream :initform nil - :accessor binary-file-stream))) + ((path :initarg :path :initarg "" :accessor binary-file-path) + (stream :initarg :stream :accessor binary-file-stream))) -(defun open-binary-file (dir name &optional (if-does-not-exist :create)) - (let ((stream (open (make-pathname :directory dir :name name) +(defun open-binary-file (path &optional (if-does-not-exist :create)) + (let ((stream (open path :direction :io :element-type '(unsigned-byte 8) :if-exists :overwrite :if-does-not-exist if-does-not-exist))) (when stream - (make-instance 'binary-file :stream stream)))) + (make-instance 'binary-file :path path :stream stream)))) -(defmethod close-file ((bf binary-file)) +(defmethod close-binary-file ((bf binary-file)) (close (binary-file-stream bf))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/octet-stream.lisp 2007/02/08 15:57:19 1.2 @@ -174,7 +174,7 @@ (make-instance 'octet-output-stream :buffer (make-array 128 :element-type '(unsigned-byte 8)))) -(defclass octet-io-stream (octet-output-stream octet-input-stream) +(defclass octet-io-stream (octet-output-stream octet-input-stream) ((limit :accessor limit-p :initarg :limit))) (defmethod #.*stream-write-byte-function* ((stream octet-io-stream) integer) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/04 10:17:20 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 15:57:19 1.2 @@ -1,72 +1,11 @@ (in-package :cl-user) -(defpackage :rucksack-elephant - (:use :cl :rucksack) - (:export - ;; controller - #:open-rucksack #:close-rucksack #:with-rucksack #:current-rucksack - #:rucksack #:standard-rucksack - #:rucksack-cache - #:rucksack-directory - #:rucksack-commit #:rucksack-rollback - #:add-rucksack-root #:map-rucksack-roots #:rucksack-roots - #:commit #:rollback - ;; class indexing -;; #:add-class-index #:add-slot-index -;; #:remove-class-index #:remove-slot-index -;; #:map-class-indexes #:map-slot-indexes - #:rucksack-add-class-index #:rucksack-add-slot-index - #:rucksack-make-class-index - #:rucksack-remove-class-index #:rucksack-remove-slot-index - #:rucksack-class-index #:rucksack-slot-index - #:rucksack-map-class-indexes #:rucksack-map-slot-indexes - #:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object - #:rucksack-map-class #:rucksack-map-slot - ;; Transactions -;; #:current-transaction -;; #:transaction-start #:transaction-commit #:transaction-rollback -;; #:with-transaction -;; #:transaction #:standard-transaction -;; #:transaction-start-1 #:transaction-commit-1 -;; #:transaction-id - ;; Conditions - #:rucksack-error #:simple-rucksack-error #:transaction-conflict - #:btree-error #:btree-search-error #:btree-insertion-error - #:btree-key-already-present-error #:btree-type-error - #:btree-error-btree #:btree-error-key #:btree-error-value - ;; Heaps - #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap - #:open-heap #:close-heap - #:heap-stream #:heap-end - ;; BTree IF -;; #:btree - #:btree-key< #:btree-key= #:btree-value= - #:btree-max-node-size #:btree-unique-keys-p - #:btree-key-type #:btree-value-type - #:btree-node-class #:btree-node - ;; Indexes - #:map-index #:index-insert #:index-delete #:make-index - ;; BTrees - #:btree-search #:btree-insert -;; #:map-btree - - ;; Objects -;; #:persistent-object - #:persistent-data #:persistent-array #:persistent-cons - #:object-id - #:p-cons #:p-array - #:p-eql - #:p-car #:p-cdr #:p-list - #:p-make-array #:p-aref #:p-array-dimensions - #:p-length #:p-find #:p-replace #:p-position - )) - (defpackage :db-lisp - (:use :cl :elephant :elephant-backend :rucksack-elephant)) + (:use :cl :elephant :elephant-backend :elephant-memutil)) -;; file -;; octet-stream -;; binary-data -;; binary-types -;; buffers -;; btree +;; file - open/close binary files +;; octet-stream - read/write binary buffers +;; binary-fields - macro package for reading/writing lisp arrays +;; pages - binary pages read/written to and from stream; simple metadata +;; includes a simple LRU page-caching scheme using linked-lists +;; btree - btrees implemented on top of pages --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:20 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:20 1.1 (in-package :db-lisp) ;; ;; Mixins ;; (defclass doubly-linked-list-mixin () ((next :accessor dlist-next :initform nil) (prev :accessor dlist-prev :initform nil))) (defmethod link-node ((node doubly-linked-list-mixin) before after) "Insert page into doubly linked list" (unless (null before) (setf (dlist-next before) node)) (setf (dlist-next node) after) (setf (dlist-prev node) before) (unless (null after) (setf (page-prev after) ndoe)) node) (defmethod unlink-node ((node doubly-linked-list-mixin)) "Remove page from linked list; return next" (unless (null (dlist-next node)) (setf (dlist-prev (dlist-next node)) (dlist-prev node))) (unless (null (dlist-prev node)) (setf (dlist-next (dlist-prev node)) (dlist-next node))) node) ;; ============================================================================ ;; ;; Buffer-Page -- Maintains a page of binary data ;; ;; ============================================================================ (defclass buffer-page (doubly-linked-list-mixin) ((position :accessor page-position :initarg :position :initform -1) ;; position (type :accessor page-type :initarg :type :initform :unknown) (size :accessor page-size :initarg :page-size :initform 4096) (dirty-p :accessor page-dirty-p :initform nil) (buffer :accessor page-buffer :type (simple-array (unsigned-byte 8) (*))) (stream :accessor page-stream-store)) (:documentation "A buffer-page is an in-memory buffer containing the contents of a random access stream (usually a file).")) (defmethod initialize-instance :after ((page buffer-page) &rest initargs) (declare (ignore initargs)) (setf (page-buffer page) (make-array (page-size page) :element-type '(unsigned-byte 8)))) ;; ;; Primitive read-write of buffer-pages ;; ;; ;; Read/Write fixnums ;; (defun write-fixnum (page offset fix &optional (bytes 4)) (loop for i from 0 below bytes do (setf (aref (page-buffer page) (+ offset i)) (ldb (byte 8 (* i 8)) fix)))) ;; NOTE: Redo memutil/serializer primitives here? (defmethod copy-page ((page1 buffer-page) (page2 buffer-page)) (copy-slots page1 page2 '(position type size dirty-p stream)) (loop for (i fixnum) from 0 below (page-size page2) do (setf (aref (page-buffer page2) i) (aref (page-buffer page1) i)))) ;; ;; Read-write buffer-pages from buffer-streams ;; (defmethod write-buffer-stream ((page buffer-page) (bs buffer-stream) offset) "Put contents of buffer stream into the page at offset; return the buffer-stream" (buffer-read-to-array-offset (page-buffer page) offset bs) bs) (defmethod read-buffer-stream ((page buffer-page) (bs buffer-stream) offset length) "Put array contents at offset into buffer-stream and return stream" (declare (type fixnum offset length)) (buffer-write-from-array-offset (page-buffer page) offset length bs) bs) ;; ;; Page-level IO with backing stream store ;; (defmethod associate-page ((page associated-buffer-page) (stream stream) position) (setf (page-file-position page) position) (setf (page-stream-store page) stream)) (defmethod seek-to-page ((page buffer-page)) (file-position (page-stream page) (page-position page))) (defmethod load-page ((page buffer-page)) (seek-to-page page) (read-sequence (page-buffer page) str)) (defmethod flush-page ((page buffer-page)) (seek-to-page page) (write-sequence (page-buffer page) str)) (defmethod zero-page ((page buffer-page) &optional (value 0)) (loop for i from 0 upto (1- (length (page-buffer page))) do (setf (aref (page-buffer page) i) value)) page) ;; ============================================================================ ;; ;; Caching buffer pool ;; ;; ============================================================================ (defparameter *default-buffer-pool-pages* 4000) (defparameter *default-page-size* 4096) (defclass buffer-pool () ((lock :accessor pool-lock :initarg :lock :initform nil) (page-count :accessor pool-pages :initarg :pages :initform *default-buffer-pool-pages*) (page-size :accessor pool-page-size :initarg :page-size :initform *default-page-size*) (free-list :accessor pool-free-list :initform nil) (active-list :accessor pool-active-list :initform nil) (least-recently-used :accessor pool-lru-page :initform nil) (hash :accessor pool-hash :initform nil))) (defmethod initialize-instance :after ((pool buffer-pool) &rest rest) "Create a set of pages to populate the pool" (declare (ignore rest)) (labels ((make-page () (make-instance 'buffer-page :page-size (pool-page-size pool)))) (unless (= (pool-pages pool) 0) (setf (pool-free-list pool) (make-page))) (let ((prior (pool-free-list pool))) (dotimes (i (pool-pages pool) pool) (setf prior (link-page (make-page) prior nil)))))) ;; ;; Pool level operations ;; (defmethod eject-page ((pool buffer-pool)) "Eject the least recently used, unwritten page, from the cache" (assert (not (null (pool-lru-page pool)))) (let ((lru (pool-lru-page pool))) (setf (pool-lru-page pool) (dlist-prev (unlink-page lru))) (loop until (or (null lru) (not (dirty-p lru))) do (setf lru (dlist-prev lru))) (when (null lru) (error "No unwritten pages available to eject! Memory exhausted!")) lru)) (defun pop-free-list (pool) (let ((page (pool-free-list pool))) (setf (pool-free-list pool) (dlist-next page)) (unlink-node page))) (defun push-free-list (page pool) (link-node page nil (pool-free-list pool)) (setf (pool-free-list pool) page)) (defun push-active-list (page pool) (link-node page nil (pool-active-list pool)) (setf (pool-active-list pool) page)) (defun touch-page (page pool) (push-active-list (unlink-node page))) (defmethod get-empty-page ((pool buffer-pool) position) (if (null (pool-free-list pool)) (eject-page pool) (pop-free-list pool))) (defmethod lookup-page ((pool buffer-pool) position stream) (let ((pages (gethash position (pool-hash pool)))) (find stream pages :key #'page-stream-store))) (defmethod cache-page ((pool buffer-pool) page) (push page (gethash (page-position page) (pool-hash pool)))) ;; ;; User cache operations ;; (defmethod get-page ((pool buffer-pool) stream position) (touch-page (or (lookup-page pool) (cache-page pool (load-page (associate-page (get-empty-page pool) stream position)))) pool)) From ieslick at common-lisp.net Thu Feb 8 15:58:34 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 10:58:34 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070208155834.CA06952014@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv28359 Modified Files: serializer2.lisp Log Message: Last of Henrik's changes --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:51:01 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:58:26 1.20 @@ -165,7 +165,7 @@ (%serialize (frob) (etypecase frob (fixnum - (if (< #.most-positive-fixnum +2^32+) ;; should be compiled away + (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) From rread at common-lisp.net Thu Feb 8 22:33:35 2007 From: rread at common-lisp.net (rread) Date: Thu, 8 Feb 2007 17:33:35 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070208223335.345333F00D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv26423/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: More robust upgrade mechanism, one bug fix, better user of PK --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/02 23:51:58 1.9 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/08 22:33:35 1.10 @@ -526,7 +526,7 @@ (let ((cur-pk (get-current-key cursor))) (decf (:sql-crsr-ck cursor)) (if (equal cur-pk (get-current-key cursor)) - (decf (:dp-nmbr cursor)) + (setf (:dp-nmbr cursor) (max 0 (- (:dp-nmbr cursor) 1))) (setf (:dp-nmbr cursor) (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) @@ -593,12 +593,13 @@ (setf (:sql-crsr-ck cursor) (- (length (:sql-crsr-ks cursor)) 1)) (setf (:dp-nmbr cursor) + (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) (get-con (cursor-btree cursor)) ) - 1)) + 1))) (assert (>= (:dp-nmbr cursor) 0)) (setf (cursor-initialized-p cursor) t) (has-key-value-scnd cursor :returnpk returnpk) @@ -615,10 +616,11 @@ (progn (setf (:sql-crsr-ck cursor) (- (:sql-crsr-ck cursor) (+ 1 (:dp-nmbr cursor)))) (setf (:dp-nmbr cursor) + (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) (get-con (cursor-btree cursor)) -) 1)) + ) 1))) (has-key-value-scnd cursor :returnpk returnpk)) (cursor-last-x cursor :returnpk returnpk))) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/07 22:54:12 1.17 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/08 22:33:35 1.18 @@ -34,13 +34,13 @@ ( ;; (db :accessor controller-db :initarg :db :initform nil) (dbcons :accessor controller-db-table :initarg :db :initform nil) + (uses-pk :accessor uses-pk-of :initarg :uses-pk) ) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) et cetera. This is the Postgresql-specific subclass of store-controller.")) - ;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, ;; unpleasant bug when ASDF tries to load this stuff. ;; (defvar *thread-table-lock* nil) @@ -300,6 +300,20 @@ (clsql:table-exists-p [keyvalue] :database con :owner :all) ) +;; Our goal here is to see if the "pk" column exists.... +;; if it does, we can use a certain optimization the sql-get-from-clcn-nth. +;; Post 6.1 versions should have it, but 6.0 versions won't. +;; My goal here is to be as robust as possible; there is no portable way +;; to add a column nicely. If you want to upgrade (which will really only +;; help if you use duplicate keys), then do a migration from your old repository +;; to a new repository. +(defun query-uses-pk (con) + ;; we want to use ":owner :all" because we don't really care who created + ;; the table, as long as we have the rights we need! + (member "pk" (clsql:list-attributes [keyvalue] :database con :owner :all) + :test 'equal) + ) + ;; This is just an initial version; it is possible that ;; we might someday wish to use blobs instead; certainly, I am @@ -320,6 +334,8 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. + +;; At one time this was conditional, but all NEW repositories should have this. (clsql::create-sequence [serial] :database con) (clsql::query (format nil "create table keyvalue ( @@ -329,19 +345,17 @@ value varchar )") :database con) +;; (clsql::create-table [keyvalue] +;; ;; This is most likely to work with any database system.. +;; '( +;; ([clctn_id] integer :not-null) +;; ([key] text :not-null) +;; ([value] text) +;; ) +;; :database con) - ;; (clsql::create-table [keyvalue] - - ;; ;; This is most likely to work with any database system.. - ;; '( - ;; ([clctn_id] integer :not-null) - ;; ([key] text :not-null) - ;; ([value] text) - ;; ) - ;; :database con) - - ;; :constraints '("PRIMARY KEY (clctn_id key)" - ;; "UNIQUE (clctn_id,key)") +;; :constraints '("PRIMARY KEY (clctn_id key)" +;; "UNIQUE (clctn_id,key)") ;; apparently in postgres this is failing pretty awfully because ;; sequence-exists-p return nil and then we get an error that the sequence exists! @@ -412,8 +426,9 @@ ;; Now we should make sure that the KEYVALUE table exists, and, if ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) - (with-transaction (:store-controller sc) - (create-keyvalue-table con))) + (with-transaction (:store-controller sc) + (create-keyvalue-table con))) + (setf (uses-pk-of sc) (query-uses-pk con)) (unless (version-table-exists con) (with-transaction (:store-controller sc) (create-version-table con))) @@ -450,8 +465,6 @@ (defmethod reconnect-controller ((sc sql-store-controller)) (clsql:reconnect :database (controller-db sc) :force nil) -;; (setf (controller-db sc) -;; (clsql:reconnect :database (controller-db sc))) ) (defmethod close-controller ((sc sql-store-controller)) @@ -543,17 +556,21 @@ (let* ((con (controller-db sc)) (kbs (serialize-to-base64-string key sc)) - (offsetquery (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " - clcn - kbs - n)) + (offsetquery (if (uses-pk-of sc) + (format nil "select value from keyvalue where clctn_id = ~A and key = '~A' order by pk offset ~A limit 1 " + clcn + kbs + n) + nil)) (tuples - (clsql::query offsetquery :database con) -;; (clsql::select [value] -;; :from [keyvalue] -;; :where [and [= [clctn_id] clcn] [= [key] kbs]] -;; :database con -;; ) + (if (uses-pk-of sc) + (clsql::query offsetquery :database con) + (clsql::select [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con + ) + ) ) ) ;; Get the lowest value by sorting and taking the first value; @@ -565,21 +582,22 @@ ;; that efficiently without changing the database structure; ;; but that's OK, I could add a column to support that ;; relatively easily later on. - (if tuples - (values (deserialize-from-base64-string (caar tuples) sc) - t) - (values nil nil)) - -;; (if (< n (length tuples)) -;; (values (nth n (sort -;; (mapcar -;; #'(lambda (x) -;; (deserialize-from-base64-string (car x) sc)) -;; tuples) -;; #'my-generic-less-than)) -;; t) -;; (values nil nil)) -)) + (if (uses-pk-of sc) + (if tuples + (values (deserialize-from-base64-string (caar tuples) sc) + t) + (values nil nil)) + (if (< n (length tuples)) + (values (nth n (sort + (mapcar + #'(lambda (x) + (deserialize-from-base64-string (car x) sc)) + tuples) + #'my-generic-less-than)) + t) + (values nil nil)) + ) + )) (defun sql-get-from-clcn-cnt (clcn key sc) (assert (integerp clcn)) @@ -597,11 +615,20 @@ (assert (integerp clcn)) (let* ((con (controller-db sc)) (tuples - (clsql::select [pk] [key] [value] + (if (uses-pk-of sc) + (clsql::select [pk] [key] [value] :from [keyvalue] :where [and [= [clctn_id] clcn]] :database con - ))) + ) + (clsql::select [key] [value] + :from [keyvalue] + :where [and [= [clctn_id] clcn]] + :database con + ) + ) + ) + ) (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x)) tuples))) @@ -678,24 +705,11 @@ (if (or (null to-remove) (my-generic-less-than (car tuple) to-remove)) (setf to-remove (car tuple)))) - ;; (nth 0 (sort - ;; (mapcar - ;; #'(lambda (x) - ;; (deserialize-from-base64-string (car x) :sc sc)) - ;; tuples) - ;; #'my-generic-less-than))))) - ;; (format t "to-remove = ~A~%" to-remove) (clsql::delete-records :from [keyvalue] :where [and [= [clctn_id] clcn] [= [key] kbs] [= [value] to-remove]] :database con ) - ;; (format t "After deletion = ~A~%" - ;; (clsql::select [value] - ;; :from [keyvalue] - ;; :where [and [= [clctn_id] clcn] [= [key] kbs]] - ;; :database con - ;; )) ) ) ) From rread at common-lisp.net Thu Feb 8 22:33:35 2007 From: rread at common-lisp.net (rread) Date: Thu, 8 Feb 2007 17:33:35 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070208223335.65B8C7D002@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26423/tests Modified Files: testindexing.lisp Log Message: More robust upgrade mechanism, one bug fix, better user of PK --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/07 22:54:13 1.25 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/08 22:33:35 1.26 @@ -204,9 +204,6 @@ (defclass idx-five-del () ((slot1 :initarg :slot1 :initform 1 :accessor slot1)) (:metaclass persistent-metaclass)) - (format t "r1 = ~A~%" r1) - (format t "r1 = ~A~%" (get-index (get-value 'idx-five-del (elephant::controller-class-root *store-controller*)) - 'slot1)) (values (eq (length r1) 1) (signals-error (get-instances-by-value 'idx-five-del 'slot1 1)) From ieslick at common-lisp.net Thu Feb 8 23:05:46 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 18:05:46 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070208230546.6E3DE54135@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv2282/contrib/eslick/db-lisp Modified Files: btree.lisp package.lisp pages.lisp Log Message: Removing vestigial directory --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 23:05:46 1.3 @@ -7,7 +7,8 @@ '((0 . :unknown) (1 . :index) (2 . :leaf) - (3 . :blob))) + (3 . :overflow) + (#xFF . :root))) (defun get-type (byte) (assert (<= byte (car (last *type-table*)))) @@ -41,9 +42,27 @@ ;; Indexes: ;; +type = root +endian-tag = 0xDAF00F00 (32-bit) +db_version = 0-6-1 (48 bit) +free-data-block = page-ptr (32-bits) +num-keys - int32 + +type = index +num-keys - int32 +serialized-key - buffer-stream +page-pointer (int32-page) +serialized-key - buffer-stream +page-pointer (int32-page) +... +type - leaf +num-elts - ;; User Operations: +;; btree-open +(defun open-btree-file (path &key page-size (create t)) + ;; btree-create ;; btree-search --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 23:05:46 1.3 @@ -3,9 +3,3 @@ (defpackage :db-lisp (:use :cl :elephant :elephant-backend :elephant-memutil)) -;; file - open/close binary files -;; octet-stream - read/write binary buffers -;; binary-fields - macro package for reading/writing lisp arrays -;; pages - binary pages read/written to and from stream; simple metadata -;; includes a simple LRU page-caching scheme using linked-lists -;; btree - btrees implemented on top of pages --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 15:57:19 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 23:05:46 1.2 @@ -1,6 +1,31 @@ (in-package :db-lisp) ;; +;; Utilities +;; + +(defun copy-slots (obj1 obj2 slotnames) + (loop for slotname in slotnames do + (setf (slot-value obj2 slotname) (slot-value obj1 slotname)))) + +(defun write-integer-to-array (integer array offset &optional (bytes 4)) + (declare (type fixnum offset bytes) + (type integer integer) + (type (array (unsigned-byte 8)) array)) + (loop for i fixnum from 0 below bytes do + (setf (aref array (+ offset i)) + (ldb (byte 8 (* i 8)) integer)))) + +(defun read-integer-from-array (array offset &optional (bytes 4)) + (declare (type fixnum offset bytes) + (type (array (unsigned-byte 8)) array)) + (let ((value 0)) + (loop for i fixnum from 0 below bytes do + (setf value (dpb (aref array (+ i offset)) (byte 8 (* i 8)) value))) + value)) + + +;; ;; Mixins ;; @@ -53,14 +78,15 @@ ;; Primitive read-write of buffer-pages ;; -;; ;; Read/Write fixnums -;; -(defun write-fixnum (page offset fix &optional (bytes 4)) - (loop for i from 0 below bytes do - (setf (aref (page-buffer page) (+ offset i)) - (ldb (byte 8 (* i 8)) fix)))) +(defmethod write-integer (fixnum page offset &optional (bytes 4)) + (declare (type fixnum fixnum offset bytes)) + (write-fixnum-to-array fixnum (page-buffer page) offset bytes)) + +(defmethod read-integer (page offset &optional (bytes 4)) + (declare (type fixnum offset bytes)) + (read-integer-from-array (page-buffer page) offset bytes)) ;; NOTE: Redo memutil/serializer primitives here? @@ -182,9 +208,11 @@ (defmethod cache-page ((pool buffer-pool) page) (push page (gethash (page-position page) (pool-hash pool)))) +;; ------------------------------------------------------------------------ ;; ;; User cache operations ;; +;; ------------------------------------------------------------------------ (defmethod get-page ((pool buffer-pool) stream position) (touch-page From ieslick at common-lisp.net Thu Feb 8 23:05:46 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 18:05:46 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070208230546.AD09D54135@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv2282/db-bdb Modified Files: bdb-collections.lisp Log Message: Removing vestigial directory --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/04 10:08:27 1.16 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/08 23:05:46 1.17 @@ -306,17 +306,17 @@ (defmethod cursor-first ((cursor bdb-cursor)) (let ((sc (get-con (cursor-btree cursor)))) - (with-buffer-streams (key-buf value-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-oid key) (cursor-oid cursor))) - (progn (setf (cursor-initialized-p cursor) t) - (values t - (deserialize key sc) - (deserialize val sc))) - (setf (cursor-initialized-p cursor) nil)))))) + (with-buffer-streams (key-buf value-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-oid key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t + (deserialize key sc) + (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-last ((cursor bdb-cursor)) "A fast cursor last, but a bit 'hackish' by exploiting oid ordering" From ieslick at common-lisp.net Thu Feb 8 23:07:18 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 18:07:18 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070208230718.B650A650D3@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv2451 Modified Files: TODO UPGRADE-BDB Log Message: Checkpoint checkin of db-lisp --- /project/elephant/cvsroot/elephant/TODO 2007/02/05 19:33:10 1.45 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/08 23:07:18 1.46 @@ -9,12 +9,12 @@ ALPHA RELEASE TASKS Bug and feature fixes: +- Validate migration 0.6.0->0.6.1 +- Fix cur-del2 failure under SBCL (robert to reproduce and fix) ~ Resolve duplicate sorting guarantee in btree interface; currently supported - by BDB but not SQL and it is not tested in the regression suite (Robert) + by BDB but not SQL and it is not tested in the regression suite (Robert to comment) - Fix *dbconnection-spec* to support multiple controllers for multiple threads - for CLSQL backend -- Validate migration 0.6.0->0.6.1 -- Fix cur-del2 failure under SBCL + for CLSQL backend (Robert) BDB Features/Cleanup: - Trace all paths to db-put or db-delete and ensure that there is a check or a @@ -57,7 +57,6 @@ - Ensure that variable length UTF-8 is automatically stored as UTF-16 Documentation: -- 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 deadlock-detect @@ -128,6 +127,9 @@ 0.6.2 - Advanded work, low-hanging fruit (Summer '07) -------------------------------------------------- + +Migrate code base to Darcs and create feature/bug tickets in TRAC + 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? @@ -175,7 +177,22 @@ 0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------ - Full support for DCM or integration of DCM functionality - - Integrate prevalence-like in-memory database system for single image, multiple-thread operation + - Integrate prevalence-like in-memory database system for single image, + multiple-thread operation + - Richer set of policy decisions on per-class basis + - Concurrent mode (for backends that allow multiple processes to connect, current default) + - Single-user mode (cache values in instance slots for fast reads, write-through) + - Backing store mode (read/write to normal slots except on object creation or synch) + (in-memory slot indexing, on disk class) + (works for any backend) + - Backing-store mode + - Controller 'switches' + - NoSynch - allow transactions to be lost on failure but maintains consistency + instead of performance + - Upgrade overall functionality + - Solid garbage collection strategy + - 64-bit oids / 64-bit file sizes + - class templates stored and cached - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be stored only as OIDs, and we should have a separate OID->class table. This way change-class can be handled correctly. This also non-trivially compresses storage @@ -183,24 +200,16 @@ [Ian comment: only problem with this is an extra access to oid table each time a class is deserialized and overall storage is constant. Would make it easy to invalidate objects though!] - - Richer set of policy decisions on per-class basis - - Concurrent mode (for backends that allow multiple processes to connect, current default) - - Single-user mode (cache values in instance slots for fast reads, write-through) - - Backing store mode (read/write to normal slots except on object creation or synch) - (in-memory slot indexing, on disk class) - (works for any backend) - - Backing-store mode - - Controller 'switches' - - NoSynch - allow transactions to be lost on failure but maintains consistency instead of performance - Usage model examples -0.7.1 - Elephant/BDB/SQL Production Release +0.7.1 - Elephant BDB/SQL/Lisp Production Release -------------------------------------------------- - More work on testing, examples and documentation - Intent is for this to be a major, long-term supported release prior to work on the new backend (i.e. patches against this release for bugs rather than only available in latest development tree) + 0.8.0 - Supporting Tools Release -------------------------------------------------- - Add special support (if any) for persistent graph structures & queries --- /project/elephant/cvsroot/elephant/UPGRADE-BDB 2006/09/04 00:09:11 1.1 +++ /project/elephant/cvsroot/elephant/UPGRADE-BDB 2007/02/08 23:07:18 1.2 @@ -1,46 +1,42 @@ -Version 0.6.0 of Elephant using the BDB backend depends on Berkeley DB 4.3. As for September 3rd, 2006, -the current CVS is now dependant on Berkeley DB 4.4. If you already have a database based on 0.6.0 or a HEAD prior to September 3rd, you'll need to take the following steps to upgrade your BDB databases to work with my latest checkin. +Elephant 0.6.1 depends on Berkeley DB 4.5. -(NOTE: Allegro users may have additional work to do, please check e-mail logs on this topic) +------------------------------------ +Upgrading from 0.6 / Berkeley DB 4.3 +------------------------------------ -1) Install BDB 4.4.20 or later just as you installed BDB 4.3 +1) Install BDB 4.5 (keep 4.3 around for now) -2) Pull the latest HEAD from CVS +2) Update my-config.sexp to point to the appropriate BDB 4.5 directories -3) Update config.lisp and Makefile in elephant root to point to the appropriate directories +3) Upgrade your database directory to 4.5 -4) Rebuild elephant C libraries +3a) Run db43_recover in your 0.6 database +3b) Optional: run db43_archive -d to remove all logs not part of a checkpoint + This will make catastrophic recovery impossible, but reduces the amount of data you + have to backup. +3c) Backup your db files and remaining logs +3d) Run db45_checkpoint -1 in your 0.6 database directory -In the root directory: -> make clean -> make -> make bdb +4) Migrate 0.6 data to a new 0.6.1 database -5) Upgrade your database directory (only log files need updating) +4a) Open your old database: (setf sc (open-store '(:BDB "/Users/me/db/ele060/"))) +4b) Run upgrade: (upgrade sc '(:BDB "/Users/me/db/ele061/")) -From Sleepycat documentation: +5) Test your new application and report any bugs that arise to elephant-devel at common-lisp.net - 1. Shut down the old version of the application. - 2. Run recovery on the database environment using the DB_ENV->open method or the db_recover utility. - 3. Remove any Berkeley DB environment using the DB_ENV->remove method or an appropriate system utility. - 4. Archive the database environment for catastrophic recovery. See Archival procedures for more information. - 5. Recompile and install the new version of the application. - 6. Force a checkpoint using the DB_ENV->txn_checkpoint method or the db_checkpoint utility. - 7. Restart the application. +NOTE 1: close-store may fail when closing the old 0.6 database, this is OK +NOTE 2: 64-bit lisps will not successfully upgrade 32-bit 0.6 databases. Use a 32-bit + version of your lisp to update to 0.6.1 and then open that database in your 64-bit + lisp. There should be no compatibility problems. Best to test your application on + a 32-bit lisp if you can, just to be sure. -A known good procedure: +------------------------------------ +Upgrading from 0.5 / Berkeley DB 4.3 +------------------------------------ - 1. Cleanly exit lisp/elephant application - 2. Run 'db_recover' in database directory using 4.3 tools - 3. This will remove the environment - 3.b (optional) Run 'db_checkpoint -1' and 'db_archive -d' to checkpoint and update db files to latest log. This will - snapshot the DB and allow you to backup less data, but it makes catastrophic recovery to any time - before the snapshot impossible as you are deleting history with the '-d' option so exclude that if you - are conservative or aren't sure what you're doing. - 4. Copy your database files and all log files to a backup - 5. Run 'db_checkpoint -1' using 4.4 tools (ignore error message) - 6. Restart lisp, reload application and ensure that the latest elephant source has been fully recompiled +Follow the upgrade procedures outlined in Elephant 0.6.0 to migrate your database +from 0.5 to 0.6. Then follow the above procedures for upgradeing from an 0.6 database. -6) Connect to your DB, all should be well! - -This procedure worked for my Mac OS X upgrade from BDB 4.3 using the latest HEAD on a very large, complex DB. +NOTE: It may not take much work to make 0.6.1 upgrade directly from 0.5.0. However +there are so few 0.5.0 users that it wasn't deemed worth the work given that +there's an upgrade path available. \ No newline at end of file From ieslick at common-lisp.net Thu Feb 8 23:07:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 18:07:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070208230719.7FAC1650CD@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv2451/src/elephant Modified Files: migrate.lisp package.lisp serializer1.lisp Removed Files: serializer2-locks.lisp Log Message: Checkpoint checkin of db-lisp --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2006/04/26 17:53:44 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/08 23:07:18 1.5 @@ -129,7 +129,8 @@ ;; indexed persistent objects which (see below) are not copied by default ;; so we do the slot updates here (map-btree (lambda (classname classidx) - ;; Class indexes should never be copied already + ;; Class indexes should never be copied already; this checks + ;; for users breaking the class-index abstraction (assert (not (object-was-copied-p classidx))) (let ((newcidx (with-transaction (:store-controller dst) @@ -145,9 +146,9 @@ ;; Add the class index to the class root (with-transaction (:store-controller dst) (setf (get-value classname (controller-class-root dst)) newcidx)) - ;; Update the class to point at all it's new objects in the new store + ;; Update the class to point at objects in the new store (setf (%index-cache (find-class classname)) newcidx) - ;; Migrate the indexes' objects + ;; Migrate the index objects (copy-cindex-contents newcidx classidx) ;; And remember the class index just incase it's indexed elswhere ;; (and trips the assert above) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/04 04:34:57 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/08 23:07:19 1.12 @@ -37,6 +37,8 @@ #:controller-fast-symbols-p #:optimize-storage + #:upgrade + #:controller-version #:controller-serializer-version #:controller-serialize #:controller-deserialize #:serialize-database-version-key --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/05 03:18:22 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/08 23:07:19 1.7 @@ -291,6 +291,7 @@ (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) + (format t "Tag: ~A~%" tag) (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) From ieslick at common-lisp.net Thu Feb 8 23:07:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 8 Feb 2007 18:07:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070208230719.E1CC9650D3@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv2451/src/memutil Modified Files: memutil.lisp Log Message: Checkpoint checkin of db-lisp --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/03 14:07:01 1.21 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/08 23:07:19 1.22 @@ -41,6 +41,8 @@ #:reset-buffer-stream #:buffer-stream-buffer #:buffer-stream-length #:buffer-stream-size + #:buffer-read-to-array-offset #:buffer-write-from-array-offset + #:buffer-write-byte #:buffer-write-float #:buffer-write-double #:buffer-write-string #:buffer-write-int32 #:buffer-write-uint32 @@ -700,6 +702,26 @@ (dotimes (i writable bs) (buffer-write-byte (aref bv i) bs)))) +(defun buffer-read-to-array-offset (arry offset bs) + "Buffer relative; read contents of buffer-stream and write them into array at offset" + (declare (type buffer-stream bs) + (type fixnum offset)) + (let* ((position (buffer-stream-position bs)) + (size (buffer-stream-size bs)) + (vlen (- size position))) + (if (>= vlen 0) + (dotimes (i vlen arry) + (setf (aref arry (+ i offset)) + (buffer-read-byte bs)))))) + +(defun buffer-write-from-array-offset (arry offset length bs) + "Buffer relative; write array contents into buffer stream" + (declare (type fixnum offset) + (type buffer-stream bs)) + (dotimes (i length arry) + (buffer-write-byte (aref arry (+ i offset)) bs))) + + ;; ;; Compatibility ;; From ieslick at common-lisp.net Fri Feb 9 09:06:12 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 9 Feb 2007 04:06:12 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070209090612.6294F54125@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv19265 Modified Files: serializer1.lisp Log Message: Debugging statement slipped into checkin; repaired --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/08 23:07:19 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/09 09:06:12 1.8 @@ -291,7 +291,6 @@ (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) - (format t "Tag: ~A~%" tag) (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) From ieslick at common-lisp.net Fri Feb 9 17:11:53 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 9 Feb 2007 12:11:53 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070209171153.815BD54125@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv583/utils Modified Files: locks.lisp Log Message: Updated lock.lisp to support process ids --- /project/elephant/cvsroot/elephant/src/utils/locks.lisp 2007/02/03 00:57:34 1.1 +++ /project/elephant/cvsroot/elephant/src/utils/locks.lisp 2007/02/09 17:11:53 1.2 @@ -52,3 +52,12 @@ #+allegro `(excl:without-interrupts , at body) #-allegro `(ele-with-lock (,lock , at ignored) , at body)) +(defun ele-thread-hash-key () +"This routine has to return something unqiue about the thread which can serve as a hash key." + #+sbcl sb-thread::*current-thread* + #+allegro mp:*current-process* + #+cmu mp:*current-process* + #+mcl ccl:*current-process* + #+lispworks mp:*current-process* + #-(or allegro sbcl cmu lispworks mcl) nil + ) From ieslick at common-lisp.net Mon Feb 12 20:36:15 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:36:15 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp/archive Message-ID: <20070212203615.76D2061026@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive In directory clnet:/tmp/cvs-serv5336/archive Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive added to the repository From ieslick at common-lisp.net Mon Feb 12 20:36:44 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:36:44 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070212203644.2BCE46209D@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv5382 Modified Files: TODO elephant.asd Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/TODO 2007/02/08 23:07:18 1.46 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/12 20:36:43 1.47 @@ -9,12 +9,8 @@ ALPHA RELEASE TASKS Bug and feature fixes: -- Validate migration 0.6.0->0.6.1 -- Fix cur-del2 failure under SBCL (robert to reproduce and fix) ~ Resolve duplicate sorting guarantee in btree interface; currently supported by BDB but not SQL and it is not tested in the regression suite (Robert to comment) -- Fix *dbconnection-spec* to support multiple controllers for multiple threads - for CLSQL backend (Robert) BDB Features/Cleanup: - Trace all paths to db-put or db-delete and ensure that there is a check or a @@ -41,9 +37,9 @@ - Review and address all NOTE comments in the code - Review SBCL string serialization performance - Improve SQL base-64 serializer performance? -- Improve SQL secondary cursor performance (Robert) 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 FINAL RELEASE TASKS @@ -60,7 +56,7 @@ - Add notes about with/ensure-transaction usage (abort & commit behavior on exit) - Add notes about optimize-storage - Add notes about deadlock-detect -- Add notes about new BDB 4.4 *auto-commit* behavior. Default for entire +- Add notes about new BDB 4.5 *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 @@ -69,6 +65,12 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- +February 9th, 2007 +x Improve SQL secondary cursor performance (Robert) +x Fix *dbconnection-spec* to support multiple controllers for multiple threads + for CLSQL backend (Robert) +x Fix cur-del2 failure under SBCL (robert to reproduce and fix) + February 3rd, 2007 checkins: x Finished char -> unsigned char for buffer streams to solve SBCL type problems x Finished new serializer-initialization and open-controller protocol to handle --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/05 19:33:10 1.27 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/12 20:36:44 1.28 @@ -109,7 +109,8 @@ (list #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" - #+(or :X86-64) "-arch x86_64" + #+(and X86-64 (or macosx darwin darwin-host)) "-arch x86_64" + #+(and X86-64 linux) "-march x86-64" "-Wall" "-fPIC" "-O3" @@ -187,5 +188,6 @@ (:file "backend")) :serial t :depends-on (memutil utils))))) + :serial t :depends-on (:uffi :cl-base64)) From ieslick at common-lisp.net Mon Feb 12 20:36:45 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:36:45 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070212203645.191476200D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv5382/src/contrib/eslick/db-lisp Modified Files: TODO btree.lisp file.lisp package.lisp pages.lisp Added Files: ele-lisp.asd log.lisp Removed Files: lisp-types.lisp octet-stream.lisp serializer3.lisp Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/12 20:36:44 1.3 @@ -1,4 +1,23 @@ +Active TODO: +- secondary indices +- lisp-based comparison function for serialized streams +- variable size keys and values +- transaction logging and transactions +- page-level locks + (transactions are used to mark page-level rd/wr locks) + (on commit, transaction conflicts cause a transaction abort to be issued to appropriate threads) + (each transaction op can signal an abort condition) + (how to lock pages?) + +- direct serialization to lisp array (avoid memutil copy) +- utilities for recovery, checkpointing, etc + +- large sets of objects +- inverted index + +========================= + High level lisp backend design: - Page storage, layout policy; lisp array or foreign data? - key length limits --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/08 23:05:46 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/12 20:36:44 1.4 @@ -1,13 +1,41 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend +;;; +;;; part of +;;; +;;; Elephant Object Oriented Database: Common Lisp Backend +;;; +;;; Copyright (c) 2007 by Ian Eslick +;;; +;;; +;;; Elephant Lisp Backend users are granted the rights to distribute +;;; and use this software as governed by the terms of the Lisp Lesser +;;; GNU Public License (http://opensource.franz.com/preamble.html), +;;; also known as the LLGPL. + (in-package :db-lisp) +(defparameter *btree-page-size* 8192 + "The size of a btree page. 8192 leaves room for 32 + key/value pairs (@ 256 bytes /ea)") +(defparameter *btree-cache-size* 2048 + "The number of cache pages to allocate (4k pages at + 4k /ea - 16MB working set)") + +;; ;; Data layout ;; - page types: index, leaf, blobs +;; + +(defparameter *db-version* 1) (defparameter *type-table* - '((0 . :unknown) + '((0 . :free) (1 . :index) (2 . :leaf) (3 . :overflow) + (#xFE . :root-as-leaf) (#xFF . :root))) (defun get-type (byte) @@ -15,58 +43,490 @@ (cdr (assoc byte *type-table*))) (defun get-type-id (type-symbol) - (loop for (id symbol) in *type-table* do + (loop for (id . symbol) in *type-table* do (when (eq type-symbol symbol) (return id)) finally (error "Invalid page type identifier"))) ;; -;; Read/Write references +;; Byte fields +;; + +(defun write-field (field page integer) + (write-integer integer page (first field) (second field))) + +(defun read-field (field page) + (read-integer page (first field) (second field))) + +(defun write-field-default (field page) + (write-field field page (third field))) + +(defun verify-field-default (field page) + (assert (= (third field) (read-field field page)))) + +(defmacro def-field (name (start length &optional (default nil))) + `(defparameter ,name + (list ,start ,length ,default))) + +(defmethod field-length (field) + (second field)) + +(defmethod field-start (field) + (first field)) + +;; +;; Field definitions +;; + +(def-field +page-type+ (0 1)) + +(defun read-page-type (page) + (get-type (read-field +page-type+ page))) + +(defun write-page-type (page type) + (write-field +page-type+ page (get-type-id type))) + +(def-field +free-list-next+ (1 4 0)) + +(def-field +root-version+ (1 1 *db-version*)) +(def-field +root-reserved+ (2 8 #xDEADBEEFDEADBEEF)) +(def-field +root-alloc-pointer+ (10 4 0)) +(def-field +root-free-pointer+ (14 4 0)) +(def-field +root-last-valid-byte+ (18 3 0)) +(def-field +root-num-keys+ (21 2 0)) +(defconstant +root-key-start+ 23) + +(def-field +index-reserved+ (1 8 0)) +(def-field +index-last-valid-byte+ (9 3 0)) +(def-field +index-num-keys+ (12 2 0)) +(defconstant +index-key-start+ 14) + +(def-field +leaf-prev+ (1 4 0)) +(def-field +leaf-next+ (5 4 0)) +(def-field +leaf-last-valid-byte+ (9 3 0)) +(def-field +leaf-num-keys+ (12 2 0)) +(defconstant +leaf-key-start+ 14) + +(defun leaf-p (page) + (or (eq (page-type page) :leaf) + (eq (page-type page) :root-as-leaf))) + +;; +;; Initializing btree page types +;; + +(defun initialize-root-page (page) + (write-page-type page (setf (page-type page) :root-as-leaf)) + (write-field-default +root-version+ page) + (write-field-default +root-reserved+ page) + (write-field-default +root-free-pointer+ page) + (write-field-default +root-num-keys+ page)) + +(defun initialize-index-page (page) + (write-page-type page (setf (page-type page) :index)) + (write-field-default +index-reserved+ page) + (write-field-default +index-num-keys+ page)) + +(defun initialize-leaf-page (page) + (write-page-type page (setf (page-type page) :leaf)) + (write-field-default +leaf-prev+ page) + (write-field-default +leaf-next+ page)) + +(defun initialize-free-page (page) + (write-page-type page (setf (page-type page) :free)) + (write-field-default +free-list-next+ page)) + +;; +;; Keys and values +;; + +(defparameter *max-key-size* 255) +(defparameter *max-value-size* 255) + +(defun read-pointer (page offset) + (read-integer page offset 4)) + +(defun write-pointer (page offset pointer) + (write-integer pointer page offset 4)) + +(defmethod extract-key (page offset bs) + (let ((klen (read-integer page offset 4))) + (values (when (> klen 0) (read-buffer-stream page bs (+ offset 4) klen)) + (read-pointer page (+ offset klen 4)) + (+ offset klen 8)))) + +(defmethod write-key (page offset bs pointer) + (let ((klen (buffer-stream-size bs))) + (assert (< klen *max-key-size*)) + (write-integer page offset klen 4) + (write-buffer-stream page bs (+ offset 4)) + (write-pointer page (+ offset (buffer-stream-size bs) 4) pointer))) + +(defmethod extract-value (page offset bs) + (let ((vlen (read-integer page offset))) + (values (when (> vlen 0) (read-buffer-stream page bs (+ offset 4) vlen)) vlen))) + +(defmethod write-value (page offset bs) + (let ((vlen (buffer-stream-size bs))) + (assert (< vlen *max-value-size*)) + (write-integer page offset vlen 4) + (write-buffer-stream page bs offset))) + +(defmethod skip-value (page offset) + "Returns the offset after the value is consumed" + (let ((vlen (read-integer page offset))) + (+ offset vlen))) + +(defun last-valid-byte (page) + "Get the last valid page irrespective of page type" + (case (page-type page) + (:root (read-field +root-last-valid-byte+ page)) + (:index (read-field +index-last-valid-byte+ page)) + (:leaf (read-field +leaf-last-valid-byte+ page)))) + +(defun set-last-valid-byte (value page) + (case (page-type page) + (:root (write-field +root-last-valid-byte+ page value)) + (:index (write-field +index-last-valid-byte+ page value)) + (:leaf (write-field +leaf-last-valid-byte+ page value)))) + +(defsetf last-valid-byte set-last-valid-byte) + +;; +;; Comparison functions +;; + +(defun lexical-compare-< (bs1 bs2) + "Stub comparison function" + (if (= (buffer-stream-size bs1) (buffer-stream-size bs2)) + (loop for i from 0 below (buffer-stream-size bs1) do + (unless (element-equal bs1 bs2 i) + (return (if (element-< bs1 bs2 i) + :less-than + :greater-than))) + finally (return :equal)) + (if (< (buffer-stream-size bs1) (buffer-stream-size bs2)) + :less-than + :greater-than))) + + +(defun element-equal (bs1 bs2 offset) + (= (deref-array (buffer-stream-buffer bs1) '(:array :unsigned-byte) offset) + (deref-array (buffer-stream-buffer bs2) '(:array :unsigned-byte) offset))) + +(defun element-< (bs1 bs2 offset) + (< (deref-array (buffer-stream-buffer bs1) '(:array :unsigned-byte) offset) + (deref-array (buffer-stream-buffer bs2) '(:array :unsigned-byte) offset))) + +;; +;; BTREE Class and useful accessors +;; + +(defclass btree () + ((pool :accessor btree-buffer-pool :initarg :pool + :documentation "Maintain a pool of memory pages") + (primary-bfile :accessor btree-primary-file :initarg :bfile + :documentation "The file store for btrees") + (root :accessor btree-root :initarg :root + :documentation "The in-memory root of main BTree DB") + (compare-fn :accessor btree-compare-fn :initarg :compare-fn))) + +(defmethod btree-stream ((bt btree)) + (binary-file-stream (btree-file bt))) + +(defmethod btree-get-page ((bt btree) position) + (get-page (btree-buffer-pool bt) (btree-stream bt) position)) + +(defmethod btree-allocation-pointer ((bt btree)) + (read-field +root-alloc-pointer+ (btree-root bt))) + +(defmethod write-btree-allocation-pointer (value (bt btree)) + (write-field +root-alloc-pointer+ (btree-root bt) value)) + +(defsetf btree-allocation-pointer write-btree-allocation-pointer) + +(defmethod btree-free-pointer ((bt btree)) + (read-field +root-free-pointer+ (btree-root bt))) + +(defmethod write-btree-free-pointer (value (bt btree)) + (write-field +root-alloc-pointer+ (btree-root bt) value)) + +(defsetf btree-free-pointer write-btree-free-pointer) + +;; +;; Manipulating backing store ;; +;; Physical operations (not init, no flush) + +(defmethod pop-free-db-page ((bt btree)) + "Take a page off the free list" + (let* ((pop-page (btree-get-page bt (btree-free-pointer bt))) + (new-top-page (btree-get-page bt (read-field +free-list-next+ pop-page)))) + (setf (btree-free-pointer bt) (page-position new-top-page)) + pop-page)) + +(defmethod push-free-db-page ((bt btree) free-page) + "Pushes an initialized (tagged) free page on the free list" + (let ((new-top (page-position free-page)) + (old-top-page (btree-get-page bt (btree-free-pointer bt)))) + (write-field +free-list-next+ free-page old-top-page) + (setf (btree-free-pointer bt) new-top) + free-page)) + +(defmethod new-db-page ((bt btree)) + "Append a new page to the disk file" + (let ((new-page-position (btree-allocation-pointer bt))) + (incf (btree-allocation-pointer bt) + (page-size (btree-root bt))) + new-page-position)) + +(defmethod get-free-db-page ((bt btree)) + "Get a fresh page from free list or by allocation" + (if (> (btree-free-pointer bt) 0) + (pop-free-db-page bt) + (new-db-page bt))) + +(defmethod leaf-next (page) + "Access the next page field of a leaf" + (read-field +leaf-next+ page)) +(defmethod set-leaf-next (page pointer) + (write-field +leaf-next+ page pointer)) +(defsetf leaf-next set-leaf-next) + +(defmethod set-leaf-prev (page pointer) + "Access the prev page field of a leaf" + (write-field +leaf-prev+ page pointer)) +(defmethod leaf-prev (page) + (read-field +leaf-prev+ page)) +(defsetf leaf-prev set-leaf-prev) + +;; Logical operations + +(defmethod free-page ((bt btree) page) + "Free a page so it goes on the free list" + (initialize-free-page page) + (push-free-db-page bt page)) + +(defmethod allocate-index-page ((bt btree)) + (let ((idx-page (get-free-db-page bt))) + (initialize-index-page idx-page) + idx-page)) + +(defmethod allocate-leaf-page ((bt btree)) + (let ((leaf-page (get-free-db-page bt))) + (initialize-leaf-page leaf-page) + leaf-page)) + +(defun insert-leaf-page (new-page new-pointer prev-page next-page) + "Link in a leaf page from the double linked list of leaf pages" + (setf (leaf-prev new-page) (leaf-prev next-page) + (leaf-next new-page) (leaf-next prev-page) + (leaf-next prev-page) new-pointer + (leaf-prev next-page) new-pointer) + new-page) + +(defun delete-leaf-page (old-page) + "Remove a leaf page from the double linked list of leaf pages" + (setf (leaf-next (leaf-prev old-page)) (leaf-next old-page) + (leaf-prev (leaf-next old-page)) (leaf-prev old-page))) + + ;; -;; Page headers +;; Manipulating keys and values ;; - -(defun read-page-header (page) - (with-buffer-streams (header) - (buffer-write-from-array-offset (page-buffer page) 0 1 header) - (setf (page-type page) (get-type (buffer-read-byte header))))) -(defun write-page-header (page) - (with-buffer-streams (header) - (buffer-write-byte (get-type-id (page-type page)) header) - (buffer-read-to-array-offset (page-buffer page) 0 header))) +(defun insert-key (page start key-bs pointer) + "Given a point just after a key/pointer or + at the beginning of a key region, insert and + copy the remaining data to make room checking + for boundary conditions" + (let* ((last-byte (last-valid-byte page)) + (region-size (- last-byte start)) + (length (buffer-stream-size key-bs)) + (offset (+ length 8))) + (assert (< (+ last-byte offset) (page-size page))) + (assert (< offset 256)) + (copy-region page start region-size offset) + (write-key page start key-bs pointer) + (setf (last-valid-byte page) (+ offset last-byte)) + page)) + +(defun insert-key-and-value (page start key-bs pointer value-bs) + (let* ((last-byte (last-valid-byte page)) + (region-size (- last-byte start)) + (length (+ (buffer-stream-size key-bs) + (buffer-stream-size value-bs))) + (offset (+ length 12))) + (assert (< (+ last-byte offset) (page-size page))) + (assert (< offset 256)) + (copy-region page start region-size offset) + (write-key page start key-bs pointer) + (write-value page (+ start 8) value-bs) + (setf (last-valid-byte page) (+ offset last-byte)) + page)) + +(defun delete-key (page start) + (let* ((last-byte (last-valid-byte page)) + (key-size (read-integer page start)) + (begin (+ start key-size 8)) + (region-size (- last-byte begin)) + (offset (- (+ key-size 8)))) + (copy-region page begin region-size offset) + (setf (last-valid-byte page) (+ offset last-byte)) + page)) + +(defun delete-key-and-value (page start) + (let* ((last-byte (last-valid-byte page)) + (key-size (read-integer page start)) + (value-size (read-integer page (+ start key-size 4))) + (delete-size (+ key-size value-size 12)) + (begin (+ start delete-size)) [169 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/08 15:57:19 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/12 20:36:44 1.3 @@ -1,3 +1,18 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend +;;; +;;; part of +;;; +;;; Elephant Object Oriented Database: Common Lisp Backend +;;; +;;; Copyright (c) 2007 by Ian Eslick +;;; +;;; +;;; Elephant Lisp Backend users are granted the rights to distribute +;;; and use this software as governed by the terms of the Lisp Lesser +;;; GNU Public License (http://opensource.franz.com/preamble.html), +;;; also known as the LLGPL. (in-package :db-lisp) @@ -5,14 +20,14 @@ ((path :initarg :path :initarg "" :accessor binary-file-path) (stream :initarg :stream :accessor binary-file-stream))) -(defun open-binary-file (path &optional (if-does-not-exist :create)) - (let ((stream (open path - :direction :io :element-type '(unsigned-byte 8) - :if-exists :overwrite :if-does-not-exist if-does-not-exist))) - (when stream - (make-instance 'binary-file :path path :stream stream)))) +(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create)) + (assert (binary-file-path file)) + (setf (binary-file-stream file) + (open (binary-file-path file) + :direction :io :element-type '(unsigned-byte 8) + :if-exists :overwrite :if-does-not-exist if-does-not-exist))) -(defmethod close-binary-file ((bf binary-file)) +(defmethod close-file ((bf binary-file)) (close (binary-file-stream bf))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/08 23:05:46 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/package.lisp 2007/02/12 20:36:44 1.4 @@ -1,5 +1,21 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend +;;; +;;; part of +;;; +;;; Elephant Object Oriented Database: Common Lisp Backend +;;; +;;; Copyright (c) 2007 by Ian Eslick +;;; +;;; +;;; Elephant Lisp Backend users are granted the rights to distribute +;;; and use this software as governed by the terms of the Lisp Lesser +;;; GNU Public License (http://opensource.franz.com/preamble.html), +;;; also known as the LLGPL. + (in-package :cl-user) (defpackage :db-lisp - (:use :cl :elephant :elephant-backend :elephant-memutil)) + (:use :cl :elephant :elephant-backend :elephant-memutil :uffi)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/08 23:05:46 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/12 20:36:44 1.3 @@ -1,3 +1,19 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend +;;; +;;; part of +;;; +;;; Elephant Object Oriented Database: Common Lisp Backend +;;; +;;; Copyright (c) 2007 by Ian Eslick +;;; +;;; +;;; Elephant Lisp Backend users are granted the rights to distribute +;;; and use this software as governed by the terms of the Lisp Lesser +;;; GNU Public License (http://opensource.franz.com/preamble.html), +;;; also known as the LLGPL. + (in-package :db-lisp) ;; @@ -40,7 +56,7 @@ (setf (dlist-next node) after) (setf (dlist-prev node) before) (unless (null after) - (setf (page-prev after) ndoe)) + (setf (dlist-prev after) node)) node) (defmethod unlink-node ((node doubly-linked-list-mixin)) @@ -82,7 +98,7 @@ (defmethod write-integer (fixnum page offset &optional (bytes 4)) (declare (type fixnum fixnum offset bytes)) - (write-fixnum-to-array fixnum (page-buffer page) offset bytes)) + (write-integer-to-array fixnum (page-buffer page) offset bytes)) (defmethod read-integer (page offset &optional (bytes 4)) (declare (type fixnum offset bytes)) @@ -92,10 +108,24 @@ (defmethod copy-page ((page1 buffer-page) (page2 buffer-page)) (copy-slots page1 page2 '(position type size dirty-p stream)) - (loop for (i fixnum) from 0 below (page-size page2) do + (loop for i fixnum from 0 below (page-size page2) do (setf (aref (page-buffer page2) i) (aref (page-buffer page1) i)))) +(defmethod copy-region ((page buffer-page) start length offset) + "Move region defined by start and length offset bytes. If offset + is negative, move to lower parts of the array, if position, toward + the end." + (let ((buffer (page-buffer page))) + (declare (type (array (unsigned-byte 8)) buffer)) + (if (< 0 offset) + (loop for i from 0 below length do + (setf (aref buffer (+ start offset i)) + (aref buffer (+ start i)))) + (loop for i from 0 below length do + (setf (aref buffer (- (+ start length offset) i)) + (aref buffer (- (+ start length) i))))))) + ;; ;; Read-write buffer-pages from buffer-streams ;; @@ -115,20 +145,21 @@ ;; Page-level IO with backing stream store ;; -(defmethod associate-page ((page associated-buffer-page) (stream stream) position) - (setf (page-file-position page) position) - (setf (page-stream-store page) stream)) +(defmethod associate-page ((page buffer-page) (stream stream) position) + (setf (page-position page) position) + (setf (page-stream-store page) stream) + page) (defmethod seek-to-page ((page buffer-page)) - (file-position (page-stream page) (page-position page))) + (file-position (page-stream-store page) (page-position page))) (defmethod load-page ((page buffer-page)) (seek-to-page page) - (read-sequence (page-buffer page) str)) + (read-sequence (page-buffer page) (page-stream-store page))) (defmethod flush-page ((page buffer-page)) (seek-to-page page) - (write-sequence (page-buffer page) str)) + (write-sequence (page-buffer page) (page-stream-store page))) (defmethod zero-page ((page buffer-page) &optional (value 0)) (loop for i from 0 upto (1- (length (page-buffer page))) do @@ -163,7 +194,7 @@ (setf (pool-free-list pool) (make-page))) (let ((prior (pool-free-list pool))) (dotimes (i (pool-pages pool) pool) - (setf prior (link-page (make-page) prior nil)))))) + (setf prior (link-node (make-page) prior nil)))))) ;; ;; Pool level operations @@ -173,8 +204,8 @@ "Eject the least recently used, unwritten page, from the cache" (assert (not (null (pool-lru-page pool)))) (let ((lru (pool-lru-page pool))) - (setf (pool-lru-page pool) (dlist-prev (unlink-page lru))) - (loop until (or (null lru) (not (dirty-p lru))) do + (setf (pool-lru-page pool) (dlist-prev (unlink-node lru))) + (loop until (or (null lru) (not (page-dirty-p lru))) do (setf lru (dlist-prev lru))) (when (null lru) (error "No unwritten pages available to eject! Memory exhausted!")) @@ -194,9 +225,9 @@ (setf (pool-active-list pool) page)) (defun touch-page (page pool) - (push-active-list (unlink-node page))) + (push-active-list (unlink-node page) pool)) -(defmethod get-empty-page ((pool buffer-pool) position) +(defmethod get-empty-page ((pool buffer-pool)) (if (null (pool-free-list pool)) (eject-page pool) (pop-free-list pool))) @@ -214,9 +245,9 @@ ;; ;; ------------------------------------------------------------------------ -(defmethod get-page ((pool buffer-pool) stream position) +(defmethod get-page ((pool buffer-pool) position stream) (touch-page - (or (lookup-page pool) + (or (lookup-page pool position stream) (cache-page pool (load-page (associate-page (get-empty-page pool) stream position)))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/ele-lisp.asd 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/ele-lisp.asd 2007/02/12 20:36:45 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend ;;; ;;; part of ;;; ;;; Elephant Object Oriented Database: Common Lisp Backend ;;; ;;; Copyright (c) 2007 by Ian Eslick ;;; ;;; ;;; Elephant and Elephant Lisp Backend users are granted the rights to ;;; distribute and use this software as governed by the terms of the ;;; Lisp Lesser GNU Public License (http://opensource.franz.com/preamble.html), ;;; also known as the LLGPL. (in-package :cl-user) (defpackage ele-lisp-system (:use :cl :asdf :elephant-system)) (in-package :ele-lisp-system) ;; ;; System definition ;; (defsystem ele-lisp :name "elephant-db-lisp" :author "Ian Eslick " :version "0.7.0" :maintainer "Ian Eslick " :licence "LLGPL" :description "Lisp backend for the Elephant persistent object database" :components ((:module :src :components ((:module :contrib :components ((:module :eslick :components ((:module :db-lisp :components ((:file "package") (:file "file") (:file "pages") (:file "log") (:file "btree") (:file "transactions") (:file "btree-ops") (:file "lisp-transactions") (:file "lisp-slots") (:file "lisp-collections") (:file "lisp-controller")) :serial t)))))))) :depends-on (:elephant)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/log.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/log.lisp 2007/02/12 20:36:45 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-lisp.asd -- ASDF system definition for elephant lisp backend ;;; ;;; part of ;;; ;;; Elephant Object Oriented Database: Common Lisp Backend ;;; ;;; Copyright (c) 2007 by Ian Eslick ;;; ;;; ;;; Elephant Lisp Backend users are granted the rights to distribute ;;; and use this software as governed by the terms of the Lisp Lesser ;;; GNU Public License (http://opensource.franz.com/preamble.html), ;;; also known as the LLGPL. (in-package :db-lisp) ;; ;; Simple logging facility to track operations ;; (defparameter *default-log-page-size*) (defclass binary-file-logger () ((lock :accessor bflogger-lock :initarg :lock :initform (make-ele-lock)) (filename :accessor bflogger-filename :initarg :filename) (binary-file :accessor bflogger-bfile :initform nil) (current-offset :accessor bflogger-offset :initarg :offset :initform 0) (operation-reader :accessor bflogger-ops :initarg :op-reader))) (defmethod initialize-instance :after ((log binary-file-logger) &rest rest) (unless (bflogger-stream log) (setf (bflogger-bfile log) (open-binary-file (bflogger-filename log))))) (defmethod bflogger-stream ((log binary-file-logger)) (when (bflogger-bfile log) (binary-file-stream (bflogger-bfile log)))) ;; ;; Error conditions on log operations ;; (define-condition log-full () ((filename :accessor log-full-filename :initarg :filename) (logger :accessor log-full-logger :logger))) (define-condition operation-error (error) ((op :accessor operation-error-op :initarg :op))) ;; ;; Top-level user interface ;; (defun open-log (path &key (max-bytes (expt 2 23))) (make-instance 'binary-file-logger :filename path)) (defmethod close-log ((log binary-file-logger)) (when (bflogger-bfile log) (close-binary-file (bflogger-bfile log)))) ;; ;; Record and play operations ;; (defclass bflog-op () ((operation-id :accessor bflog-op-id :initarg :op-id :initform nil) (file-offset :accessor bflog-op-offset :initarg :offset :initform nil) (payload :accessor bflog-op-payload :initarg :payload)) (:documentation "A cooperative class for reading and writing data to logs as well as replaying logged operations. Intended as a base class for users")) (defclass end-of-log-op (bflog-op) ((operation-id :initform +eol-op+))) ;; ;; Payload API ;; (defmethod unparse-payload ((op bflog-op) array offset) "Default method; assume payload is a byte-array and return it, otherwise base class should override and return an array" (bflog-op-payload op)) (defmethod unparse-payload :around ((op bflog-op) array ) (let ((payload (call-next-method))) (assert (typep payload '(array (unsigned-byte 8)))) payload)) (defmethod parse-payload ((op bflog-op) (array (array (unsigned-byte 8))) offset) (declare (type fixnum offset)) (setf (bflog-op-payload op) array)) ;; ;; User interface ;; (defvar *log-temp-array* (make-array 10000 :element-type '(unsigned-byte 8) :fill-pointer t :adjustable t)) (defmethod write-operation ((op bflog-op) (log binary-file-logger)) (let ((array *log-temp-array*)) (with-ele-lock (bflogger-lock log) (write-integer-to-array (bflog-op-id op) array 0 1) ;; tag (parse-payload op array 4) ;; get payload starting after length field (let ((end (fill-pointer array))) ;; length of payload (write-integer-to-array (- end 5) 1 4) ;; write payload length (write-sequence array (bflogger-stream log) :end (fill-pointer array)) ;; dump to disk (setf (fill-pointer array) 0)) (finish-output (bflogger-stream log)) t))) ;;(defmethod read-operation ((log binary-file-logger)) ;; (read-sequence From ieslick at common-lisp.net Mon Feb 12 20:36:45 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:36:45 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp/archive Message-ID: <20070212203645.A902D6200D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive In directory clnet:/tmp/cvs-serv5382/src/contrib/eslick/db-lisp/archive Added Files: binary-data.lisp binary-types.lisp lisp-types.lisp octet-stream.lisp serializer3.lisp Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-data.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;; ;; Macros ;; (defmacro with-gensyms ((&rest names) &body body) `(let ,(loop for n in names collect `(,n (make-symbol ,(string n)))) , at body)) ;; ;; Binary types ;; ;; NOTE: Needs to be made MP safe (defvar *in-progress-objects* nil) (defconstant +null+ (code-char 0)) (defgeneric read-value (type stream &key) (:documentation "Read a value of the given type from the stream.")) (defgeneric write-value (type stream value &key) (:documentation "Write a value as the given type to the stream.")) (defgeneric read-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Fill in the slots of object from stream.")) (defgeneric write-object (object stream) (:method-combination progn :most-specific-last) (:documentation "Write out the slots of object to the stream.")) ;; These may not be needed; design your compound objects so that ;; you can read offsets and parse compound objects ;;(defgeneric read-field-value (type stream &optional base-pos) ;; (:documentation "Index directly to a subfield of a complex type to read ;; from a random underlying stream")) ;; ;;(defgeneric write-field-value (type stream value &optional base-pos) ;; (:documentation "Write an object directly to the subfield of a complex ;; type in the provided field")) ;; ;; Defaults for read-value of binary-object types (defmethod read-value ((type symbol) stream &key) (let ((object (make-instance type))) (read-object object stream) object)) (defmethod write-value ((type symbol) stream value &key) (assert (typep value type)) (write-object value stream)) (defun read-value-at (type stream pos) "Ensure a stream is at a particular offset before reading" (file-position stream pos) (read-value type stream)) (defun write-value-at (type stream pos value) "Ensure a stream is at a particular offset before writing" (file-position stream pos) (write-value type stream value)) ;;; Binary types (defmacro define-binary-type (name (&rest args) &body spec) (with-gensyms (type stream value) `(progn (defmethod read-value ((,type (eql ',name)) ,stream &key , at args) (declare (ignorable , at args)) ,(type-reader-body spec stream)) (defmethod write-value ((,type (eql ',name)) ,stream ,value &key , at args) (declare (ignorable , at args)) ,(type-writer-body spec stream value))))) (defun type-reader-body (spec stream) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(read-value ',type ,stream , at args))) (2 (destructuring-bind ((in) &body body) (cdr (assoc :reader spec)) `(let ((,in ,stream)) , at body))))) (defun type-writer-body (spec stream value) (ecase (length spec) (1 (destructuring-bind (type &rest args) (mklist (first spec)) `(write-value ',type ,stream ,value , at args))) (2 (destructuring-bind ((out v) &body body) (cdr (assoc :writer spec)) `(let ((,out ,stream) (,v ,value)) , at body))))) ;;; Binary classes (defmacro define-generic-binary-class (name (&rest superclasses) slots read-method) (with-gensyms (objectvar streamvar) `(progn (eval-when (:compile-toplevel :load-toplevel :execute) (setf (get ',name 'slots) ',(mapcar #'first slots)) (setf (get ',name 'superclasses) ',superclasses)) (defclass ,name ,superclasses ,(mapcar #'slot->defclass-slot slots)) ,read-method (defmethod write-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->write-value x streamvar)) slots)))))) (defmacro define-binary-class (name (&rest superclasses) slots) (with-gensyms (objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-object progn ((,objectvar ,name) ,streamvar) (declare (ignorable ,streamvar)) (with-slots ,(new-class-all-slots slots superclasses) ,objectvar ,@(mapcar #'(lambda (x) (slot->read-value x streamvar)) slots)))))) (defmacro define-tagged-binary-class (name (&rest superclasses) slots &rest options) (with-gensyms (typevar objectvar streamvar) `(define-generic-binary-class ,name ,superclasses ,slots (defmethod read-value ((,typevar (eql ',name)) ,streamvar &key) (let* ,(mapcar #'(lambda (x) (slot->binding x streamvar)) slots) (let ((,objectvar (make-instance ,@(or (cdr (assoc :dispatch options)) (error "Must supply :disptach form.")) ,@(mapcan #'slot->keyword-arg slots)))) (read-object ,objectvar ,streamvar) ,objectvar)))))) (defun as-keyword (sym) (intern (string sym) :keyword)) (defun normalize-slot-spec (spec) (list (first spec) (mklist (second spec)))) (defun mklist (x) (if (listp x) x (list x))) (defun slot->defclass-slot (spec) (let ((name (first spec))) `(,name :initarg ,(as-keyword name) :accessor ,name))) (defun slot->read-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(setf ,name (read-value ',type ,stream , at args)))) (defun slot->write-value (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(write-value ',type ,stream ,name , at args))) (defun slot->binding (spec stream) (destructuring-bind (name (type &rest args)) (normalize-slot-spec spec) `(,name (read-value ',type ,stream , at args)))) (defun slot->keyword-arg (spec) (let ((name (first spec))) `(,(as-keyword name) ,name))) ;;; Keeping track of inherited slots (defun direct-slots (name) (copy-list (get name 'slots))) (defun inherited-slots (name) (loop for super in (get name 'superclasses) nconc (direct-slots super) nconc (inherited-slots super))) (defun all-slots (name) (nconc (direct-slots name) (inherited-slots name))) (defun new-class-all-slots (slots superclasses) "Like all slots but works while compiling a new class before slots and superclasses have been saved." (nconc (mapcan #'all-slots superclasses) (mapcar #'first slots))) ;;; In progress Object stack (defun current-binary-object () (first *in-progress-objects*)) (defun parent-of-type (type) (find-if #'(lambda (x) (typep x type)) *in-progress-objects*)) (defmethod read-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) (defmethod write-object :around (object stream) (declare (ignore stream)) (let ((*in-progress-objects* (cons object *in-progress-objects*))) (call-next-method))) ;; Copyright (c) 2005, Peter Seibel All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * Redistributions in binary form must reproduce the above ;; copyright notice, this list of conditions and the following ;; disclaimer in the documentation and/or other materials provided ;; with the distribution. ;; * Neither the name of the Peter Seibel nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/binary-types.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A few basic types (define-binary-type unsigned-integer (bytes) (:reader (in) (loop with value = 0 for shift downfrom (* bytes 8) to 0 by 8 do (setf value (logior (ash (read-byte in) shift) value)) finally (return value))) (:writer (out value) (loop for shift downfrom (* bytes 8) to 0 by 8 do (write-byte (logand (ash value (- shift)) #xFF) out)))) (define-binary-type unsigned-integer-cplx (bytes bits-per-byte) (:reader (in) (loop with value = 0 for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (setf (ldb (byte bits-per-byte low-bit) value) (read-byte in)) finally (return value))) (:writer (out value) (loop for low-bit downfrom (* bits-per-byte (1- bytes)) to 0 by bits-per-byte do (write-byte (ldb (byte bits-per-byte low-bit) value) out)))) (define-binary-type u8 () (unsigned-integer :bytes 1)) (define-binary-type u16 () (unsigned-integer :bytes 2)) (define-binary-type u24 () (unsigned-integer :bytes 3)) (define-binary-type u32 () (unsigned-integer :bytes 4)) (define-binary-type u64 () (unsigned-integer :bytes 8)) ;;; Strings (define-binary-type generic-string (length character-type) (:reader (in) (let ((string (make-string length))) (dotimes (i length) (setf (char string i) (read-value character-type in))) string)) (:writer (out string) (dotimes (i length) (write-value character-type out (char string i))))) (define-binary-type generic-terminated-string (terminator character-type) (:reader (in) (with-output-to-string (s) (loop for char = (read-value character-type in) until (char= char terminator) do (write-char char s)))) (:writer (out string) (loop for char across string do (write-value character-type out char) finally (write-value character-type out terminator)))) ;;; ISO-8859-1 strings (define-binary-type iso-8859-1-char () (:reader (in) (let ((code (read-byte in))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (if (<= 0 code #xff) (write-byte code out) (error "Illegal character for iso-8859-1 encoding: character: ~c with code: ~d" char code))))) (define-binary-type iso-8859-1-string (length) (generic-string :length length :character-type 'iso-8859-1-char)) (define-binary-type iso-8859-1-terminated-string (terminator) (generic-terminated-string :terminator terminator :character-type 'iso-8859-1-char)) ;;; UCS-2 (Unicode) strings (i.e. UTF-16 without surrogate pairs, phew.) ;;; Define a binary type for reading a UCS-2 character relative to a ;;; particular byte ordering as indicated by the BOM value. ;; v2.3 specifies that the BOM should be present. v2.2 is silent ;; though it is arguably inherent in the definition of UCS-2) Length ;; is in bytes. On the write side, since we don't have any way of ;; knowing what BOM was used to read the string we just pick one. ;; This does mean roundtrip transparency could be broken. (define-binary-type ucs-2-char (swap) (:reader (in) (let ((code (read-value 'u2 in))) (when swap (setf code (swap-bytes code))) (or (code-char code) (error "Character code ~d not supported" code)))) (:writer (out char) (let ((code (char-code char))) (unless (<= 0 code #xffff) (error "Illegal character for ucs-2 encoding: ~c with char-code: ~d" char code)) (when swap (setf code (swap-bytes code))) (write-value 'u2 out code)))) (defun swap-bytes (code) (assert (<= code #xffff)) (rotatef (ldb (byte 8 0) code) (ldb (byte 8 8) code)) code) (define-binary-type ucs-2-char-big-endian () (ucs-2-char :swap nil)) (define-binary-type ucs-2-char-little-endian () (ucs-2-char :swap t)) (defun ucs-2-char-type (byte-order-mark) (ecase byte-order-mark (#xfeff 'ucs-2-char-big-endian) (#xfffe 'ucs-2-char-little-endian))) (define-binary-type ucs-2-string (length) (:reader (in) (let ((byte-order-mark (read-value 'u2 in)) (characters (1- (/ length 2)))) (read-value 'generic-string in :length characters :character-type (ucs-2-char-type byte-order-mark)))) (:writer (out string) (write-value 'u2 out #xfeff) (write-value 'generic-string out string :length (length string) :character-type (ucs-2-char-type #xfeff)))) (define-binary-type ucs-2-terminated-string (terminator) (:reader (in) (let ((byte-order-mark (read-value 'u2 in))) (read-value 'generic-terminated-string in :terminator terminator :character-type (ucs-2-char-type byte-order-mark)))) (:writer (out string) (write-value 'u2 out #xfeff) (write-value 'generic-terminated-string out string :terminator terminator :character-type (ucs-2-char-type #xfeff)))) ;; Copyright (c) 2005, Peter Seibel All rights reserved. ;; Redistribution and use in source and binary forms, with or without ;; modification, are permitted provided that the following conditions are ;; met: ;; * Redistributions of source code must retain the above copyright ;; notice, this list of conditions and the following disclaimer. ;; * Redistributions in binary form must reproduce the above ;; copyright notice, this list of conditions and the following ;; disclaimer in the documentation and/or other materials provided ;; with the distribution. ;; * Neither the name of the Peter Seibel nor the names of its ;; contributors may be used to endorse or promote products derived ;; from this software without specific prior written permission. ;; THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS ;; "AS IS" AND ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT ;; LIMITED TO, THE IMPLIED WARRANTIES OF MERCHANTABILITY AND FITNESS FOR ;; A PARTICULAR PURPOSE ARE DISCLAIMED. IN NO EVENT SHALL THE COPYRIGHT ;; OWNER OR CONTRIBUTORS BE LIABLE FOR ANY DIRECT, INDIRECT, INCIDENTAL, ;; SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT NOT ;; LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE, ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE ;; OF THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/lisp-types.lisp 2007/02/12 20:36:45 1.1 (in-package :db-lisp) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Map lisp types to binary types (defparameter *lisp-binary-typemap* '((fixnum . u32) [7 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/octet-stream.lisp 2007/02/12 20:36:45 1.1 [248 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/archive/serializer3.lisp 2007/02/12 20:36:45 1.1 [381 lines skipped] From ieslick at common-lisp.net Mon Feb 12 20:37:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:37:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070212203702.A312772091@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv5382/src/elephant Modified Files: classes.lisp classindex.lisp controller.lisp serializer2.lisp Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/04 10:08:27 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/12 20:36:45 1.12 @@ -97,7 +97,7 @@ (update-indexed-record instance (indexed-slot-names-from-defs instance)) (if (removed-indexing? instance) (progn - (let ((class-idx (get-value (class-name instance) (controller-class-root *store-controller*)))) + (let ((class-idx (find-class-index (class-name instance)))) (when class-idx (wipe-class-indexing instance class-idx))) (setf (%index-cache instance) nil)) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/02 23:51:58 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/12 20:36:46 1.16 @@ -72,11 +72,11 @@ (con (get-con instance))) (declare (type fixnum oid)) (if (no-indexing-needed? class instance slot-def oid) - (with-transaction (:store-controller con) + (ensure-transaction (:store-controller con) (persistent-slot-writer con new-value instance slot-name)) (let ((class-idx (find-class-index class))) ;; (format t "Indexing object: ~A oid: ~A~%" instance oid) - (with-transaction (:store-controller con) + (ensure-transaction (:store-controller con) ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement (when (get-value oid class-idx) (remove-kv oid class-idx)) @@ -106,8 +106,7 @@ (when errorp (error "Class ~A is not an indexed class" class)) (if (class-index-cached? class) - ;; we've got a cached reference, just return it - (%index-cache class) + (%index-cache class) ;; we've got a cached reference, just return it (multiple-value-bind (btree found) (get-value (class-name class) (controller-class-root sc)) (if found @@ -431,23 +430,27 @@ nil))))) +(defun subsets (size list) + (let ((subsets nil)) + (loop for elt in list + for i from 0 do + (when (= 0 (mod i size)) + (setf (car subsets) (nreverse (car subsets))) + (push nil subsets)) + (push elt (car subsets))) + (setf (car subsets) (nreverse (car subsets))) + (nreverse subsets))) + + (defmacro do-subsets ((subset subset-size list) &body body) - (let ((place (gensym)) - (i (gensym))) - `(let ((,place ,list) - (,subset nil)) - (loop while ,place do - (setf ,subset nil) - (loop for ,i from 1 upto ,subset-size do - (if (null ,place) (return) - (push (pop ,place) ,subset))) - , at body)))) + `(loop for ,subset in (subsets ,subset-size ,list) do + , at body)) (defun drop-instances (instances &key (sc *store-controller*)) (when instances (assert (consp instances)) (do-subsets (subset 500 instances) - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) (mapc (lambda (instance) (remove-kv (oid instance) (find-class-index (class-of instance))) (drop-pobject instance)) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/08 23:05:47 1.30 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/12 20:36:46 1.31 @@ -143,6 +143,7 @@ "Default version assumption for unmarked databases is 0.6.0" ;; NOTE: It is possible to check for 0.5.0 databases, but it is not ;; implemented now due to the low (none?) number of users still on 0.5.0" + (declare (ignorable sc)) (let ((db-version (call-next-method))) (if db-version db-version '(0 6 0)))) @@ -345,7 +346,7 @@ (apply #'open-controller controller args) (if *store-controller* (progn - (warning "Store controller already set so was not updated") + (warn "Store controller already set so was not updated") controller) (setq *store-controller* controller)))) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/08 15:58:26 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/12 20:36:46 1.21 @@ -165,13 +165,13 @@ (%serialize (frob) (etypecase frob (fixnum - (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away + (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+)) - (if (< (abs frob) +2^32+) + (if (< (abs frob) +2^31+) (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) From ieslick at common-lisp.net Mon Feb 12 20:37:03 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:37:03 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070212203703.1E6CA2F058@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv5382/src/utils Modified Files: package.lisp Log Message: Henrik's fixes and latest db-lisp updates --- /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/03 00:57:34 1.1 +++ /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/12 20:37:02 1.2 @@ -19,10 +19,11 @@ (in-package :cl-user) -(defpackage elephant-utils +(defpackage #:elephant-utils (:use common-lisp) (:export #:ele-make-lock #:ele-with-lock #:ele-make-fast-lock - #:ele-with-fast-lock)) + #:ele-with-fast-lock + #:ele-thread-hash-key)) From ieslick at common-lisp.net Mon Feb 12 20:46:25 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 12 Feb 2007 15:46:25 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070212204625.73FDE5833D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv7686/src/elephant Modified Files: serializer2.lisp Log Message: Slight tweak to accomodate Henrik's observation about fixnums being signed --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/12 20:36:46 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/12 20:46:25 1.22 @@ -151,6 +151,7 @@ (defconstant +2^31+ (expt 2 31)) (defconstant +2^32+ (expt 2 32)) +(defconstant +2^63+ (expt 2 63)) (defconstant +2^64+ (expt 2 64)) (defun serialize (frob bs sc) @@ -165,12 +166,12 @@ (%serialize (frob) (etypecase frob (fixnum - (if (< #.most-positive-fixnum +2^32+) ;; should be compiled away + (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away (progn (buffer-write-byte +fixnum32+ bs) (buffer-write-int32 frob bs)) (progn - (assert (< #.most-positive-fixnum +2^64+)) + (assert (< #.most-positive-fixnum +2^63+)) (if (< (abs frob) +2^31+) (progn (buffer-write-byte +fixnum32+ bs) From ieslick at common-lisp.net Tue Feb 13 16:49:32 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 11:49:32 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070213164932.052AE34069@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv12699 Modified Files: bdb-transactions.lisp Log Message: Fixed potential lock leak in BDB where commit fails, but the system does not properly abort the failed transaction --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/02 23:51:58 1.5 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/13 16:49:32 1.6 @@ -47,9 +47,9 @@ (unwind-protect (prog1 (funcall txn-fn) - (setq success t) (db-transaction-commit txn :txn-nosync txn-nosync - :txn-sync txn-sync)) + :txn-sync txn-sync) + (setq success t)) (unless success (db-transaction-abort txn))))))) (unless (and (eq result txn) (not success)) From ieslick at common-lisp.net Tue Feb 13 16:50:40 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 11:50:40 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070213165040.4F21E38013@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv12887/elephant Modified Files: serializer2.lisp Log Message: Minor edits and cleanup of serializer2 --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/12 20:46:25 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/13 16:50:40 1.23 @@ -325,7 +325,7 @@ (if (< frob 0) (buffer-write-byte +negative-bignum+ bs) (buffer-write-byte +positive-bignum+ bs)) - (buffer-write-int needed bs) + (buffer-write-uint32 needed bs) (loop for i fixnum from 0 below word-size ;; this ldb is consing on CMUCL/OpenMCL! ;; there is an OpenMCL function which should work @@ -389,9 +389,9 @@ ((= tag +pathname+) (parse-namestring (or (%deserialize bs) ""))) ((= tag +positive-bignum+) - (deserialize-bignum bs (buffer-read-fixnum bs) t)) + (deserialize-bignum bs (buffer-read-fixnum32 bs) t)) ((= tag +negative-bignum+) - (deserialize-bignum bs (buffer-read-fixnum bs) nil)) + (deserialize-bignum bs (buffer-read-fixnum32 bs) nil)) ((= tag +rational+) (/ (the integer (%deserialize bs)) (the integer (%deserialize bs)))) @@ -496,8 +496,8 @@ (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)) +;; #+(or cmu sbcl allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) + #+(or allegro sbcl cmu lispworks openmcl) (byte 32 (* 32 i)) with num integer = 0 do (setq num (dpb (buffer-read-uint bs) byte-spec num)) From ieslick at common-lisp.net Wed Feb 14 04:36:08 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:08 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070214043608.067BE2F0CE@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv32730 Modified Files: TODO config.sexp elephant.asd Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/TODO 2007/02/12 20:36:43 1.47 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/14 04:36:08 1.48 @@ -6,65 +6,72 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -ALPHA RELEASE TASKS +TASKS TO GET TO ALPHA: + +Migration: +- Validate BDB migration 0.6.0->0.6.1 (Ian) +- Validate SQL migration 0.6.0->0.6.1 (Robert) +- Legacy conversions issue for SQL (and BDB?) due to package rename (both) -Bug and feature fixes: -~ Resolve duplicate sorting guarantee in btree interface; currently supported - by BDB but not SQL and it is not tested in the regression suite (Robert to comment) + +TASKS TO GET TO BETA: BDB Features/Cleanup: -- 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] -- Determine how to detect deadlock conditions as an optional run-safe mode? -- Automatically run db_deadlock when opening a bdb backend? Requires path to - functions and ability to launch shell command. Closing the store stops the - sub-process. - Always support locks that timeout? Tradeoffs? - Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API +- Perform checkpoints (prep for DCM functionality) +- Verify db_deadlock for other lisps (launch and kill background program I/F) +- Derived indices fail to re-connect, verify this -BETA RELEASE TASKS - -Lisp support: +Lisp Support: +- 64-bit lisp verification - Win32 builds - Windows support for asdf-based library builds? Include 32-bit dll in release? - Validate OpenMCL 1.1 on Mac OS X - Validate Lispworks -- 64-bit lisp verification Stability and Performance: +- Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Review and address all NOTE comments in the code - Review SBCL string serialization performance - Improve SQL base-64 serializer performance? -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 - -FINAL RELEASE TASKS +TASKS TO GET TO FINAL RELEASE: Test coverage: -- Test for optimize storage method (just add probe-file methods to get file size) +- 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 + happening concurrently to make sure that multi-threading is in good shape (Henrik's code) - 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: +- Add document section about backend interface: - Add notes about with/ensure-transaction usage (abort & commit behavior on exit) - Add notes about optimize-storage - Add notes about deadlock-detect +- Add notes about checkpoint (null in SQL?) - Add notes about new BDB 4.5 *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. +- More notes about transaction performance 0.6.1 - Features COMPLETED to date ---------------------------------- +February 13th, 2007: +x User choice to run db_deadlock when opening a bdb backend? Requires path to + functions and ability to launch shell command. Closing the store stops the sub-process. +x Resolve duplicate ordering issues (punting to future release; documentation fix) +x 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 + + February 9th, 2007 x Improve SQL secondary cursor performance (Robert) x Fix *dbconnection-spec* to support multiple controllers for multiple threads @@ -77,6 +84,7 @@ subtle issues in database metadata and the user of the serializer Feburary 2nd, 2007 checkins: +x Punted duplicate sorting to 0.7.0 x Support locks in serializer for all systems x Provide support for fast and slow critical sections by lisps: buffer-streams, circularity-arrays/hashes, shared controller side-effects... (see email) @@ -178,6 +186,7 @@ 0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------ + - Revisit duplicate sorting on primary key (artifact of btree index storage order) - Full support for DCM or integration of DCM functionality - Integrate prevalence-like in-memory database system for single image, multiple-thread operation @@ -193,7 +202,7 @@ instead of performance - Upgrade overall functionality - Solid garbage collection strategy - - 64-bit oids / 64-bit file sizes + - 64-bit oids / 64-bit file sizes? - class templates stored and cached - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be stored only as OIDs, and we should have a separate OID->class table. This way --- /project/elephant/cvsroot/elephant/config.sexp 2007/02/02 23:51:58 1.5 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/02/14 04:36:08 1.6 @@ -1,6 +1,7 @@ -((:berkeley-db-include-dir . "/usr/local/BerkeleyDB.4.5/") +((:berkeley-db-include-dir . "/opt/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") + (:berkeley-db-lib . "/opt/local/BerkeleyDB.4.5/lib/libDB-4.5.dylib") + (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") (:pthread-lib . nil) (:clsql-lib . nil)) --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/12 20:36:44 1.28 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/14 04:36:08 1.29 @@ -159,7 +159,9 @@ ((:module utils :components ((:file "package") - (:file "locks"))) + (:file "convenience") + (:file "locks") + (:file "os"))) (:module memutil :components ((:elephant-c-source "libmemutil") From ieslick at common-lisp.net Wed Feb 14 04:36:09 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:09 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070214043609.F04B33201A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv32730/src/contrib/eslick/db-lisp Modified Files: TODO btree.lisp file.lisp pages.lisp Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/12 20:36:44 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/TODO 2007/02/14 04:36:09 1.4 @@ -1,8 +1,8 @@ Active TODO: - secondary indices -- lisp-based comparison function for serialized streams - variable size keys and values +- lisp-based comparison function for serialized streams - transaction logging and transactions - page-level locks (transactions are used to mark page-level rd/wr locks) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/12 20:36:44 1.4 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/btree.lisp 2007/02/14 04:36:09 1.5 @@ -38,9 +38,9 @@ (#xFE . :root-as-leaf) (#xFF . :root))) -(defun get-type (byte) - (assert (<= byte (car (last *type-table*)))) - (cdr (assoc byte *type-table*))) +(defun get-type (id) + (assert (<= id (caar (last *type-table*)))) + (cdr (assoc id *type-table*))) (defun get-type-id (type-symbol) (loop for (id . symbol) in *type-table* do @@ -88,24 +88,24 @@ (def-field +free-list-next+ (1 4 0)) +(defconstant +root-key-start+ 23) (def-field +root-version+ (1 1 *db-version*)) (def-field +root-reserved+ (2 8 #xDEADBEEFDEADBEEF)) (def-field +root-alloc-pointer+ (10 4 0)) (def-field +root-free-pointer+ (14 4 0)) -(def-field +root-last-valid-byte+ (18 3 0)) +(def-field +root-last-valid-byte+ (18 3 +root-key-start+)) (def-field +root-num-keys+ (21 2 0)) -(defconstant +root-key-start+ 23) +(defconstant +index-key-start+ 14) (def-field +index-reserved+ (1 8 0)) -(def-field +index-last-valid-byte+ (9 3 0)) +(def-field +index-last-valid-byte+ (9 3 +index-key-start+)) (def-field +index-num-keys+ (12 2 0)) -(defconstant +index-key-start+ 14) +(defconstant +leaf-key-start+ 14) (def-field +leaf-prev+ (1 4 0)) (def-field +leaf-next+ (5 4 0)) -(def-field +leaf-last-valid-byte+ (9 3 0)) +(def-field +leaf-last-valid-byte+ (9 3 +leaf-key-start+)) (def-field +leaf-num-keys+ (12 2 0)) -(defconstant +leaf-key-start+ 14) (defun leaf-p (page) (or (eq (page-type page) :leaf) @@ -119,7 +119,9 @@ (write-page-type page (setf (page-type page) :root-as-leaf)) (write-field-default +root-version+ page) (write-field-default +root-reserved+ page) + (write-field-default +root-alloc-pointer+ page) (write-field-default +root-free-pointer+ page) + (write-field-default +root-last-valid-byte+ page) (write-field-default +root-num-keys+ page)) (defun initialize-index-page (page) @@ -143,36 +145,36 @@ (defparameter *max-key-size* 255) (defparameter *max-value-size* 255) -(defun read-pointer (page offset) +(defmethod read-pointer ((page buffer-page) offset) (read-integer page offset 4)) -(defun write-pointer (page offset pointer) +(defmethod write-pointer ((page buffer-page) offset pointer) (write-integer pointer page offset 4)) -(defmethod extract-key (page offset bs) +(defmethod extract-key ((page buffer-page) offset bs) (let ((klen (read-integer page offset 4))) (values (when (> klen 0) (read-buffer-stream page bs (+ offset 4) klen)) (read-pointer page (+ offset klen 4)) - (+ offset klen 8)))) + (+ klen 8)))) -(defmethod write-key (page offset bs pointer) +(defmethod write-key ((page buffer-page) offset (bs buffer-stream) pointer) (let ((klen (buffer-stream-size bs))) (assert (< klen *max-key-size*)) - (write-integer page offset klen 4) + (write-integer klen page offset) (write-buffer-stream page bs (+ offset 4)) (write-pointer page (+ offset (buffer-stream-size bs) 4) pointer))) -(defmethod extract-value (page offset bs) +(defmethod extract-value ((page buffer-page) offset (bs buffer-stream)) (let ((vlen (read-integer page offset))) (values (when (> vlen 0) (read-buffer-stream page bs (+ offset 4) vlen)) vlen))) -(defmethod write-value (page offset bs) +(defmethod write-value ((page buffer-page) offset bs) (let ((vlen (buffer-stream-size bs))) (assert (< vlen *max-value-size*)) - (write-integer page offset vlen 4) - (write-buffer-stream page bs offset))) + (write-integer vlen page offset 4) + (write-buffer-stream page bs (+ offset 4)))) -(defmethod skip-value (page offset) +(defmethod skip-value ((page buffer-page) offset) "Returns the offset after the value is consumed" (let ((vlen (read-integer page offset))) (+ offset vlen))) @@ -181,17 +183,42 @@ "Get the last valid page irrespective of page type" (case (page-type page) (:root (read-field +root-last-valid-byte+ page)) + (:root-as-leaf (read-field +root-last-valid-byte+ page)) (:index (read-field +index-last-valid-byte+ page)) (:leaf (read-field +leaf-last-valid-byte+ page)))) -(defun set-last-valid-byte (value page) +(defun set-last-valid-byte (page value) (case (page-type page) (:root (write-field +root-last-valid-byte+ page value)) + (:root-as-leaf (write-field +root-last-valid-byte+ page value)) (:index (write-field +index-last-valid-byte+ page value)) (:leaf (write-field +leaf-last-valid-byte+ page value)))) (defsetf last-valid-byte set-last-valid-byte) +(defun first-key-offset (page) + (case (page-type page) + (:root +root-key-start+) + (:root-as-leaf +root-key-start+) + (:index +index-key-start+) + (:leaf +leaf-key-start+))) + +(defmethod num-keys ((page buffer-page)) + (case (page-type page) + (:root (read-field +root-num-keys+ page)) + (:root-as-leaf (read-field +root-num-keys+ page)) + (:index (read-field +index-num-keys+ page)) + (:leaf (read-field +leaf-num-keys+ page)))) + +(defmethod set-num-keys ((page buffer-page) value) + (case (page-type page) + (:root (write-field +root-num-keys+ page value)) + (:root-as-leaf (write-field +root-num-keys+ page value)) + (:index (write-field +index-num-keys+ page value)) + (:leaf (write-field +leaf-num-keys+ page value)))) + +(defsetf num-keys set-num-keys) + ;; ;; Comparison functions ;; @@ -222,7 +249,7 @@ ;; BTREE Class and useful accessors ;; -(defclass btree () +(defclass lisp-btree () ((pool :accessor btree-buffer-pool :initarg :pool :documentation "Maintain a pool of memory pages") (primary-bfile :accessor btree-primary-file :initarg :bfile @@ -231,42 +258,43 @@ :documentation "The in-memory root of main BTree DB") (compare-fn :accessor btree-compare-fn :initarg :compare-fn))) -(defmethod btree-stream ((bt btree)) - (binary-file-stream (btree-file bt))) +(defmethod btree-stream ((bt lisp-btree)) + (binary-file-stream (btree-primary-file bt))) -(defmethod btree-get-page ((bt btree) position) +(defmethod btree-get-page ((bt lisp-btree) position) (get-page (btree-buffer-pool bt) (btree-stream bt) position)) -(defmethod btree-allocation-pointer ((bt btree)) +(defmethod btree-allocation-pointer ((bt lisp-btree)) (read-field +root-alloc-pointer+ (btree-root bt))) -(defmethod write-btree-allocation-pointer (value (bt btree)) +(defmethod write-btree-allocation-pointer (value (bt lisp-btree)) (write-field +root-alloc-pointer+ (btree-root bt) value)) (defsetf btree-allocation-pointer write-btree-allocation-pointer) -(defmethod btree-free-pointer ((bt btree)) +(defmethod btree-free-pointer ((bt lisp-btree)) (read-field +root-free-pointer+ (btree-root bt))) -(defmethod write-btree-free-pointer (value (bt btree)) +(defmethod write-btree-free-pointer (value (bt lisp-btree)) (write-field +root-alloc-pointer+ (btree-root bt) value)) (defsetf btree-free-pointer write-btree-free-pointer) + ;; ;; Manipulating backing store ;; ;; Physical operations (not init, no flush) -(defmethod pop-free-db-page ((bt btree)) +(defmethod pop-free-db-page ((bt lisp-btree)) "Take a page off the free list" (let* ((pop-page (btree-get-page bt (btree-free-pointer bt))) (new-top-page (btree-get-page bt (read-field +free-list-next+ pop-page)))) (setf (btree-free-pointer bt) (page-position new-top-page)) pop-page)) -(defmethod push-free-db-page ((bt btree) free-page) +(defmethod push-free-db-page ((bt lisp-btree) free-page) "Pushes an initialized (tagged) free page on the free list" (let ((new-top (page-position free-page)) (old-top-page (btree-get-page bt (btree-free-pointer bt)))) @@ -274,14 +302,14 @@ (setf (btree-free-pointer bt) new-top) free-page)) -(defmethod new-db-page ((bt btree)) +(defmethod new-db-page ((bt lisp-btree)) "Append a new page to the disk file" (let ((new-page-position (btree-allocation-pointer bt))) (incf (btree-allocation-pointer bt) (page-size (btree-root bt))) new-page-position)) -(defmethod get-free-db-page ((bt btree)) +(defmethod get-free-db-page ((bt lisp-btree)) "Get a fresh page from free list or by allocation" (if (> (btree-free-pointer bt) 0) (pop-free-db-page bt) @@ -303,17 +331,17 @@ ;; Logical operations -(defmethod free-page ((bt btree) page) +(defmethod free-page ((bt lisp-btree) page) "Free a page so it goes on the free list" (initialize-free-page page) (push-free-db-page bt page)) -(defmethod allocate-index-page ((bt btree)) +(defmethod allocate-index-page ((bt lisp-btree)) (let ((idx-page (get-free-db-page bt))) (initialize-index-page idx-page) idx-page)) -(defmethod allocate-leaf-page ((bt btree)) +(defmethod allocate-leaf-page ((bt lisp-btree)) (let ((leaf-page (get-free-db-page bt))) (initialize-leaf-page leaf-page) leaf-page)) @@ -350,6 +378,7 @@ (copy-region page start region-size offset) (write-key page start key-bs pointer) (setf (last-valid-byte page) (+ offset last-byte)) + (incf (num-keys page)) page)) (defun insert-key-and-value (page start key-bs pointer value-bs) @@ -364,6 +393,7 @@ (write-key page start key-bs pointer) (write-value page (+ start 8) value-bs) (setf (last-valid-byte page) (+ offset last-byte)) + (incf (num-keys page)) page)) (defun delete-key (page start) @@ -374,6 +404,7 @@ (offset (- (+ key-size 8)))) (copy-region page begin region-size offset) (setf (last-valid-byte page) (+ offset last-byte)) + (decf (num-keys page)) page)) (defun delete-key-and-value (page start) @@ -386,6 +417,7 @@ (offset (- delete-size))) (copy-region page begin region-size offset) (setf (last-valid-byte page) (+ offset last-byte)) + (decf (num-keys page)) page)) (defun replace-value (page vstart new-value) @@ -399,25 +431,12 @@ (copy-region page region-start region-length offset)) (write-value page vstart new-value))) - -(defun first-key-offset (page) - (case (page-type page) - (:root +root-key-start+) - (:index +index-key-start+) - (:leaf +leaf-key-start+))) - -(defun num-keys (page) - (case (page-type page) - (:root (read-field +root-num-keys+ page)) - (:index (read-field +index-num-keys+ page)) - (:leaf (read-field +leaf-num-keys+ page)))) - (defmacro scan-page-keys ((key-bs pointer position btree page) &body body) "Walks a page one key at a time returning the associated pointer and position after consuming the pointer. For leaf pages, this places it at the beginning of the value field. The body is not evaluated if there are zero keys." - (declare (ignorable btree)) + (declare (ignorable lisp-btree)) (assert (and (atom key-bs) (atom pointer) (atom position))) (let ((i (gensym)) (dbkey (gensym)) @@ -439,13 +458,20 @@ ;; Top-level initialization ;; -(defun open-btree-file (path &key +(defun open-lisp-btree (path &key (page-size *btree-page-size*) (cache-pages *btree-cache-size*) bpool - (compare-name 'lexical-compare-<)) - (let* ((new-p (probe-file path :follow-symlinks t)) - (bfile (open-binary-file path :if-does-not-exist :create)) + (compare-name 'lexical-compare-<) + (if-does-not-exist :create) + (if-exists :new-version)) + (let* ((new-p (or + (eq if-exists :overwrite) + (not (probe-file path :follow-symlinks t)))) + (bfile (make-instance 'binary-file + :path path + :if-exists if-exists + :if-does-not-exist if-does-not-exist)) (bpool (if bpool bpool (make-instance 'buffer-pool :pages cache-pages @@ -453,20 +479,20 @@ (root (make-instance 'buffer-page :type :root :page-size page-size)) - (btree (make-instance 'btree - :file bfile + (btree (make-instance 'lisp-btree + :root root :pool bpool - :root-page root + :bfile bfile :compare-fn compare-name))) (associate-page root (binary-file-stream bfile) 0) (if new-p (initialize-root-page root) (load-page root)) - (assert (root-page-p root)) + (assert (root-p root)) btree)) -(defun close-btree-file (btree) - (close-binary-file (btree-file btree)) +(defun close-lisp-btree (btree) + (close-file (btree-primary-file btree)) (setf (btree-buffer-pool btree) nil) (setf (btree-root btree) nil)) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/12 20:36:44 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/file.lisp 2007/02/14 04:36:09 1.4 @@ -20,12 +20,13 @@ ((path :initarg :path :initarg "" :accessor binary-file-path) (stream :initarg :stream :accessor binary-file-stream))) -(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create)) +(defmethod initialize-instance :after ((file binary-file) &key (if-does-not-exist :create) (if-exists :new-version)) (assert (binary-file-path file)) (setf (binary-file-stream file) (open (binary-file-path file) :direction :io :element-type '(unsigned-byte 8) - :if-exists :overwrite :if-does-not-exist if-does-not-exist))) + :if-exists if-exists + :if-does-not-exist if-does-not-exist))) (defmethod close-file ((bf binary-file)) (close (binary-file-stream bf))) --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/12 20:36:44 1.3 +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/pages.lisp 2007/02/14 04:36:09 1.4 @@ -28,13 +28,16 @@ (declare (type fixnum offset bytes) (type integer integer) (type (array (unsigned-byte 8)) array)) + (assert (< offset (length array))) (loop for i fixnum from 0 below bytes do (setf (aref array (+ offset i)) - (ldb (byte 8 (* i 8)) integer)))) + (ldb (byte 8 (* i 8)) integer))) + integer) (defun read-integer-from-array (array offset &optional (bytes 4)) (declare (type fixnum offset bytes) (type (array (unsigned-byte 8)) array)) + (assert (< offset (length array))) (let ((value 0)) (loop for i fixnum from 0 below bytes do (setf value (dpb (aref array (+ i offset)) (byte 8 (* i 8)) value))) From ieslick at common-lisp.net Wed Feb 14 04:36:10 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:10 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070214043610.40B4F34053@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv32730/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp bdb-transactions.lisp package.lisp Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/08 23:05:46 1.17 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/14 04:36:09 1.18 @@ -55,7 +55,6 @@ (defmethod (setf get-value) (value key (bt bdb-btree)) -;; (with-transaction () (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-oid (oid bt) key-buf) @@ -63,26 +62,9 @@ (serialize value value-buf sc) (db-put-buffered (controller-btrees sc) key-buf value-buf))) -;; ) value) -;; (labels ((write-value () -;; (let ((sc (get-con bt))) -;; (with-buffer-streams (key-buf value-buf) -;; (buffer-write-oid (oid bt) key-buf) -;; (serialize key key-buf sc) -;; (serialize value value-buf sc) -;; (db-put-buffered (controller-btrees sc) -;; key-buf value-buf -;; :auto-commit *auto-commit*) -;; value)))) -;; (if (eq *current-transaction* 0) -;; (with-transaction (:store-controller (get-con bt)) -;; (write-value)) -;; (write-value)))) - (defmethod remove-kv (key (bt bdb-btree)) -;; (with-transaction (:store-controller (get-con bt)) (let ((sc (get-con bt)) ) (with-buffer-streams (key-buf) (buffer-write-oid (oid bt) key-buf) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/04 04:34:56 1.22 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 04:36:10 1.23 @@ -231,47 +231,23 @@ (error "Unrecognized deadlock type '~A'" typestring)) (cdr result))) -(eval-when (compile load eval) - (when (find-package :port) - (pushnew :port *features*))) - -(defun launch-background-program (directory program &key (args nil)) - "Launch a program in a specified directory - not all shell interfaces - or OS's support this" - #+(and allegro (not mswindows)) - (apply #'excl:run-shell-command (funcall #'vector directory program) - args) - #-(and allegro (not mswindows)) - nil) - (defmethod start-deadlock-detector ((ctrl bdb-store-controller) &key (type :oldest) (time 0.1) log) - #+port (multiple-value-bind (str errstr pid) (launch-background-program (second (controller-spec ctrl)) (namestring - (make-pathname :directory '(:ABSOLUTE "usr" "local" "BerkeleyDB.4.3" "bin") + (make-pathname :directory '(:ABSOLUTE "opt" "local" "bin" "db45_deadlock") :name "db_deadlock")) :args `("-a" ,(lookup-deadlock-type type) "-t" ,(format nil "~D" time) ,@(when log (list "-L" (format nil "~A" log))))) - (declare (ignore errstr)) - (setf (controller-deadlock-pid ctrl) pid) - (setf (controller-deadlock-input ctrl) str))) + (declare (ignore str errstr)) + (setf (controller-deadlock-pid ctrl) pid))) (defmethod stop-deadlock-detector ((ctrl bdb-store-controller)) (when (controller-deadlock-pid ctrl) - (shell-kill (controller-deadlock-pid ctrl)) - (setf (controller-deadlock-pid ctrl) nil)) - (when (controller-deadlock-input ctrl) - (close (controller-deadlock-input ctrl)) - (setf (controller-deadlock-input ctrl) nil))) + (kill-background-program (controller-deadlock-pid ctrl)))) -(defmethod shell-kill (pid) - #+allegro (sys:reap-os-subprocess :pid pid :wait t) - #+(and (not allegro) port) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) - #+(and sbcl linux) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid)))) - ;; ;; Take advantage of release 4.4's compact storage feature. Hidden features of BDB only ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/13 16:49:32 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/14 04:36:10 1.7 @@ -38,8 +38,7 @@ :txn-nosync txn-nosync :txn-nowait txn-nowait :txn-sync txn-sync)))) - (declare (type pointer-void txn) - (dynamic-extent txn)) + (declare (type pointer-void txn)) (let ((result (let ((*current-transaction* txn)) (declare (special *current-transaction*)) @@ -56,16 +55,6 @@ (return result)))) finally (error "Too many retries in transaction")))) -;; (with-bdb-transaction (:transaction ,transaction -;; :environment env -;; :parent ,parent -;; :degree-2 ,degree-2 -;; :dirty-read ,dirty-read -;; :txn-nosync ,txn-nosync -;; :txn-nowait ,txn-nowait -;; :txn-sync ,txn-sync -;; :retries ,retries) - (defmethod controller-start-transaction ((sc bdb-store-controller) &key parent @@ -85,101 +74,12 @@ :degree-2 degree-2)) -(defmethod controller-commit-transaction ((sc bdb-store-controller) transaction &key &allow-other-keys) +(defmethod controller-commit-transaction ((sc bdb-store-controller) transaction + &key txn-nosync txn-sync &allow-other-keys) (assert (not *current-transaction*)) - (db-transaction-commit transaction)) + (db-transaction-commit transaction :txn-nosync txn-nosync :txn-sync txn-sync)) (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 , at 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 , at 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/package.lisp 2006/12/16 19:35:10 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/14 04:36:10 1.4 @@ -26,7 +26,7 @@ Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Berkeley DB, so refer to their documentation for details.") - (:use common-lisp uffi elephant-memutil elephant-backend elephant) + (:use common-lisp uffi elephant-memutil elephant-backend elephant-utils elephant) #+cmu (:use alien) #+sbcl From ieslick at common-lisp.net Wed Feb 14 04:36:12 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:12 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070214043612.CE2FB3F00C@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv32730/src/elephant Modified Files: classes.lisp classindex.lisp collections.lisp controller.lisp metaclasses.lisp transactions.lisp Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/12 20:36:45 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/14 04:36:10 1.13 @@ -20,6 +20,8 @@ (defvar *debug-si* nil) +(declaim #-elephant-without-optimize (optimize (speed 3))) + (defmethod initialize-instance :before ((instance persistent) &rest initargs &key from-oid @@ -235,13 +237,11 @@ (defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Get the slot value from the database." - (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-reader (get-con instance) instance name))) (defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Set the slot value in the database." - (declare (optimize (speed 3))) (if (indexed class) (indexed-slot-writer class instance slot-def new-value) (let ((name (slot-definition-name slot-def))) @@ -249,13 +249,11 @@ (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Checks if the slot exists in the database." - (declare (optimize (speed 3))) (let ((name (slot-definition-name slot-def))) (persistent-slot-boundp (get-con instance) instance name))) (defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol)) "Checks if the slot exists in the database." - (declare (optimize (speed 3))) (loop for slot in (class-slots class) for matches-p = (eq (slot-definition-name slot) slot-name) until matches-p @@ -266,7 +264,6 @@ (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) "Deletes the slot from the database." - (declare (optimize (speed 3))) ;; NOTE: call remove-indexed-slot here instead? ;; (when (indexed slot-def) ;; (unregister-indexed-slot class (slot-definition-name slot-def))) @@ -322,8 +319,7 @@ #+(or cmu sbcl) (defun make-persistent-reader (name) (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) + (declare (type persistent-object instance)) (persistent-slot-reader (get-con instance) instance name))) #+(or cmu sbcl) @@ -336,8 +332,7 @@ #+(or cmu sbcl) (defun make-persistent-slot-boundp (name) (lambda (instance) - (declare (optimize (speed 3)) - (type persistent-object instance)) + (declare (type persistent-object instance)) (persistent-slot-boundp (get-con instance) instance name))) #+sbcl ;; CMU also? Old code follows... --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/12 20:36:46 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/14 04:36:10 1.17 @@ -12,6 +12,8 @@ (in-package "ELEPHANT") +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) + ;; ;; User level class indexing control protocol ;; @@ -72,8 +74,7 @@ (con (get-con instance))) (declare (type fixnum oid)) (if (no-indexing-needed? class instance slot-def oid) - (ensure-transaction (:store-controller con) - (persistent-slot-writer con new-value instance slot-name)) + (persistent-slot-writer con new-value instance slot-name) (let ((class-idx (find-class-index class))) ;; (format t "Indexing object: ~A oid: ~A~%" instance oid) (ensure-transaction (:store-controller con) @@ -375,9 +376,7 @@ (get-instances-by-value (find-class class) slot-name value)) (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) -;; (declare -;; (optimize (speed 3) (safety 1) (space 1)) -;; (type (or string symbol) slot-name)) + (declare (type (or string symbol) slot-name)) (let ((instances nil)) (with-btree-cursor (cur (find-inverted-index class slot-name)) (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) @@ -405,9 +404,8 @@ (get-instances-by-range (find-class class) slot-name start end)) (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) -;; (declare (optimize speed (safety 1) (space 1)) -;; (type fixnum start end) -;; (type string idx-name)) + (declare (type fixnum start end) + (type string idx-name)) (with-inverted-cursor (cur class idx-name) (labels ((next-range (instances) (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) @@ -429,23 +427,6 @@ (next-in-range skey (cons val nil)) nil))))) - -(defun subsets (size list) - (let ((subsets nil)) - (loop for elt in list - for i from 0 do - (when (= 0 (mod i size)) - (setf (car subsets) (nreverse (car subsets))) - (push nil subsets)) - (push elt (car subsets))) - (setf (car subsets) (nreverse (car subsets))) - (nreverse subsets))) - - -(defmacro do-subsets ((subset subset-size list) &body body) - `(loop for ,subset in (subsets ,subset-size ,list) do - , at body)) - (defun drop-instances (instances &key (sc *store-controller*)) (when instances (assert (consp instances)) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/02 23:51:58 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/14 04:36:10 1.8 @@ -325,7 +325,7 @@ (defmethod map-btree (fn (btree btree)) "Like maphash. Default implementation - overridable" - (ensure-transaction (:store-controller (get-con btree)) + (with-transaction (:store-controller (get-con btree)) (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) @@ -338,15 +338,25 @@ (multiple-value-bind (valid k) (cursor-next cur) (cond ((not valid) ;; truly empty t) - ((eq k *elephant-properties-label*) ;; has properties + ((and (eq btree (controller-root (get-con btree))) + (eq k *elephant-properties-label*)) ;; has properties (not (cursor-next cur))) (t nil)))))) -(defun dump-btree (bt) +(defun print-btree-node (k v) + (format t "k ~A / v ~A~%" k v)) + +(defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil)) + "Print the contents of a btree for easy inspection & debugging" (format t "DUMP ~A~%" bt) - (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt) - ) + (let ((i 0)) + (map-btree + (lambda (k v) + (when (and count (>= (incf i) count)) + (return-from dump-btree)) + (funcall print-fn k v)) + bt))) (defun btree-keys (bt) (format t "BTREE keys for ~A~%" bt) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/12 20:36:46 1.31 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 04:36:10 1.32 @@ -193,7 +193,6 @@ (migrate target source) (close-store target))) - ;; ;; Modular serializer support and default serializers for a version ;; --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/04/26 17:53:44 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/02/14 04:36:10 1.8 @@ -20,6 +20,8 @@ (in-package "ELEPHANT") +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) + (defclass persistent () ((%oid :accessor oid :initarg :from-oid) (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst)) --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/02 23:51:58 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/14 04:36:10 1.6 @@ -26,6 +26,39 @@ non-local exist, provides ACID properties for DB operations within the body and properly binds any relevant parameters.")) +;; Transaction architecture: +;; +;; User and designer considerations: +;; - *current-transaction* is reserved for use by dynamic transaction context. The default global +;; value must always be null (no transaction). Each backend can set it to a different parameter +;; within the dynamic context of an execute-transaction. +;; - Any closures returned from within a transaction cannot bind *current-transaction* +;; - Only a normal return value will result in the transaction being committed, any non-local exit +;; results in a transaction abort. If you want to do something more sophisticated, roll your own +;; using controller-start-transaction, etc. +;; - The body of a with or ensure transaction can take any action (throw, signal, error, etc) +;; knowing that the transaction will be aborted +;; +;; Designer considerations: +;; - with-transaction passes *current-transaction* or the user parameter to execute-transaction +;; in the parent keyword argument. Backends allowing nested transactions can treat the transaction +;; as a parent, otherwise they can reuse the current transaction by ignoring it (inheriting the dynamic +;; value of *current-transaction*) or rebinding the dynamic context (whatever makes coding easier). +;; - ensure-transaction uses *current-transaction* to determine if there is a current transaction +;; in progress. If so, it jumps to the body directly. Otherwise it executes the body in a +;; new transaction. +;; - execute-transaction contract: +;; - Backends must dynamically bind *current-transaction* to a meaningful identifier for the +;; transaction in progress and execute the provided closure in that context +;; - All non-local exists result in an abort; only regular return values result in a commit +;; - If a transaction is aborted due to a deadlock or read conflict, execute-transaction should +;; automatically retry with an appropriate default amount +;; - execute-transaction can take any number of backend-defined keywords, although designers should +;; make sure there are no semantic conflicts if there is a name overlap with existing backends +;; - A typical design approach is to make sure that the most primitive interfaces to the backend +;; database look at *current-transaction* to determine whether a transaction is active. Users code can also +;; access this parameter to check whether a transaction is active. + (defmacro with-transaction ((&rest keyargs &key (store-controller '*store-controller*) (parent '*current-transaction*) @@ -66,7 +99,13 @@ :retries ,retries ,@(remove-keywords '(:store-controller :parent :transaction :retries) keyargs)))))) - + +(defmacro with-batched-transaction ((batch size list &rest txn-options) &body body) + "Perform a set of DB operations over a list of elements in batches of size 'size'. + Pass specific transaction options after the list reference." + `(loop for ,batch in (subsets ,subset-size ,list) do + (with-transaction ,txn-options + , at body))) ;; ;; An interface to manage transactions explicitly @@ -82,12 +121,3 @@ (defgeneric controller-abort-transaction (store-controller transaction &key &allow-other-keys) (:documentation "Abort an elephant transaction")) - -;; -;; Utility -; - -(defun remove-keywords (key-names args) - (loop for ( name val ) on args by #'cddr - unless (member name key-names) - append (list name val))) From ieslick at common-lisp.net Wed Feb 14 04:36:13 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070214043613.31E1D7D167@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv32730/src/memutil Modified Files: memutil.lisp Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/08 23:07:19 1.22 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/14 04:36:13 1.23 @@ -709,6 +709,7 @@ (let* ((position (buffer-stream-position bs)) (size (buffer-stream-size bs)) (vlen (- size position))) + (assert (< (+ offset size) (length arry))) (if (>= vlen 0) (dotimes (i vlen arry) (setf (aref arry (+ i offset)) From ieslick at common-lisp.net Wed Feb 14 04:36:16 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:36:16 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070214043616.445C34B068@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv32730/src/utils Modified Files: package.lisp Log Message: Documentation, optimizations, deadlock process, etc --- /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/12 20:37:02 1.2 +++ /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/14 04:36:13 1.3 @@ -26,4 +26,9 @@ #:ele-with-lock #:ele-make-fast-lock #:ele-with-fast-lock - #:ele-thread-hash-key)) + #:ele-thread-hash-key + #:launch-background-program + #:kill-background-program + #:do-subsets + #:subsets + #:remove-keywords)) From ieslick at common-lisp.net Wed Feb 14 04:38:56 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:38:56 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070214043856.D4BD1120A4@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv697 Added Files: convenience.lisp os.lisp Log Message: Missing files from last checkin --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/14 04:38:56 NONE +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/14 04:38:56 1.1 ;; Copyright Ian Eslick ;; License: LGPL ;; ;; A collection of handy utilities for compacting code complexity in elephant ;; (in-package :elephant-utils) (defmacro do-subsets ((subset subset-size list) &body body) "Look over subsets of the list" `(loop for ,subset in (subsets ,subset-size ,list) do , at body)) (defun subsets (size list) "Generate subsets of size n from the list; the last subset has the remaining elements if size does not represent an equal division" (let ((subsets nil)) (loop for elt in list for i from 0 do (when (= 0 (mod i size)) (setf (car subsets) (nreverse (car subsets))) (push nil subsets)) (push elt (car subsets))) (setf (car subsets) (nreverse (car subsets))) (nreverse subsets))) (defun remove-keywords (key-names args) (loop for ( name val ) on args by #'cddr unless (member name key-names) append (list name val))) (defun concat-separated-strings (separator &rest lists) (format nil (concatenate 'string "~{~A~^" (string separator) "~}") (append-sublists lists))) (defun append-sublists (list) "Takes a list of lists and appends all sublists" (let ((results (car list))) (dolist (elem (cdr list) results) (setq results (append results elem))))) --- /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 NONE +++ /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 1.1 (in-package :elephant-utils) (defun launch-background-program (directory program &key (args nil)) "Launch a program in a specified directory - not all shell interfaces or OS's support this" #+(and allegro (not mswindows)) (excl:run-shell-command (concat-separated-strings " " (list program) args) :wait nil :directory directory) ;; #+(and allegro mswindows) ;; #+(and sbcl unix) ;; (sb-ext:start-process ... ;; #+(and openmcl unix) ;; #+lispworks ) (defun kill-background-program (pid) #+(and allegro (not mswindows)) (progn (excl.osi:kill pid 9) (system:reap-os-subprocess :pid pid)) ;; #+(and allegro mswindows) #+(and sbcl unix) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid))) ) From ieslick at common-lisp.net Wed Feb 14 04:41:21 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 13 Feb 2007 23:41:21 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070214044121.DE4482F0D8@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv2473 Removed Files: binary-data.lisp binary-types.lisp Log Message: Moving old files to archive From ieslick at common-lisp.net Wed Feb 14 17:41:29 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 14 Feb 2007 12:41:29 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070214174129.816194E00F@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv23282/src/db-bdb Modified Files: bdb-controller.lisp Log Message: User parameter if; deadlock detector param support --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 04:36:10 1.23 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 17:41:29 1.24 @@ -236,8 +236,7 @@ (launch-background-program (second (controller-spec ctrl)) (namestring - (make-pathname :directory '(:ABSOLUTE "opt" "local" "bin" "db45_deadlock") - :name "db_deadlock")) + (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) :args `("-a" ,(lookup-deadlock-type type) "-t" ,(format nil "~D" time) ,@(when log (list "-L" (format nil "~A" log))))) From ieslick at common-lisp.net Wed Feb 14 17:41:29 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 14 Feb 2007 12:41:29 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070214174129.EA7425001D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv23282/src/elephant Modified Files: controller.lisp package.lisp Log Message: User parameter if; deadlock detector param support --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 04:36:10 1.32 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 17:41:29 1.33 @@ -99,6 +99,15 @@ dep-list)) ;; +;; PER-USER INSTALLATION PARAMETERS +;; + +(defun get-user-configuration-parameter (name) + (elephant-system::get-config-option + name + (asdf:find-system :elephant))) + +;; ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; @@ -128,6 +137,35 @@ (for garbage collection,) et cetera.")) ;; +;; Per-controller instance caching +;; + +(defun cache-instance (sc obj) + "Cache a persistent object with the controller." + (declare (type store-controller sc)) + (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!" + (declare (type store-controller sc) + (type fixnum oid)) + (let ((obj (get-cache oid (instance-cache sc)))) + (if obj obj + ;; Should get cached since make-instance calls cache-instance + (make-instance (handle-legacy-classes class-name nil) + :from-oid oid :sc sc)))) + +(defmethod flush-instance-cache ((sc store-controller)) + "Reset the instance cache (flush object lookups). Useful + for testing. Does not reclaim existing objects so there + will be duplicate instances with identical functionality" + (ele-with-lock ((instance-cache-lock sc)) + (setf (instance-cache sc) + (make-cache-table :test 'eql)))) + + +;; ;; Database versioning ;; @@ -240,35 +278,6 @@ (defun string-pair->symbol (name) (intern (string-upcase (cdr name)) (car name))) -;; -;; Per-controller instance caching -;; - -(defun cache-instance (sc obj) - "Cache a persistent object with the controller." - (declare (type store-controller sc)) - (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!" - (declare (type store-controller sc) - (type fixnum oid)) - (let ((obj (get-cache oid (instance-cache sc)))) - (if obj obj - ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name nil) - :from-oid oid :sc sc)))) - -(defmethod flush-instance-cache ((sc store-controller)) - "Reset the instance cache (flush object lookups). Useful - for testing. Does not reclaim existing objects so there - will be duplicate instances with identical functionality" - (ele-with-lock ((instance-cache-lock sc)) - (setf (instance-cache sc) - (make-cache-table :test 'eql)))) - - ;; ================================================================================ ;; ;; BACKEND STORE CONTROLLER PROTOCOL --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/08 23:07:19 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/14 17:41:29 1.13 @@ -36,6 +36,7 @@ #:controller-symbol-cache #:controller-symbol-id-cache #:controller-fast-symbols-p #:optimize-storage + #:get-user-configuration-parameter #:upgrade From ieslick at common-lisp.net Wed Feb 14 17:42:22 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 14 Feb 2007 12:42:22 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-acache Message-ID: <20070214174222.A1D3A63088@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache In directory clnet:/tmp/cvs-serv23445/src/contrib/eslick/db-acache Added Files: ele-acache.asd Log Message: Missing files for in-development backends --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/ele-acache.asd 2007/02/14 17:42:22 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-acache/ele-acache.asd 2007/02/14 17:42:22 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; ele-acache.asd -- ASDF file for allegrocache backend ;;; ;;; Initial version 2/18/2006 by Ian Eslick ;;; ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; ;;; ;;; Elephant users are granted the rights to distribute and use this software ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defsystem ele-acache :name "elephant" :author "Ben Lee " :version "0.6.0" :maintainer "Ben Lee " :licence "LLGPL" :description "Allegro cache backend for elephant" :components ((:module :src :components ((:module :db-acache :components ((:file "package") (:file "acache-controller") (:file "acache-transactions") (:file "acache-collections")) :serial t)))) :depends-on (:elephant)) From ieslick at common-lisp.net Wed Feb 14 17:42:24 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 14 Feb 2007 12:42:24 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/eslick/db-lisp Message-ID: <20070214174224.17F2063085@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp In directory clnet:/tmp/cvs-serv23445/src/contrib/eslick/db-lisp Added Files: tests.lisp Log Message: Missing files for in-development backends --- /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/tests.lisp 2007/02/14 17:42:23 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/eslick/db-lisp/tests.lisp 2007/02/14 17:42:23 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; test.lisp -- Internal tests for elephant lisp backend ;;; ;;; part of ;;; ;;; Elephant Object Oriented Database: Common Lisp Backend ;;; ;;; Copyright (c) 2007 by Ian Eslick ;;; ;;; ;;; Elephant Lisp Backend users are granted the rights to distribute ;;; and use this software as governed by the terms of the Lisp Lesser ;;; GNU Public License (http://opensource.franz.com/preamble.html), ;;; also known as the LLGPL. (in-package :db-lisp) (defparameter *btree-file* "btree-test-file.db") (defvar btree nil) (defvar root nil) (defvar idx1 nil) (defvar idx2 nil) (defvar leaf1 nil) (defvar leaf2 nil) (defun initialize-btree-tests () (setf btree (open-lisp-btree *btree-file* :if-exists :overwrite)) (setf root (btree-root btree)) btree) (defun cleanup-btree-tests () (close-lisp-btree btree) (setf root nil idx1 nil idx2 nil leaf1 nil leaf2 nil)) (defun dump-keys (page) (with-buffer-streams (k) (scan-page-keys (k pointer position btree page) (format t "k: ~A ptr: ~A pos: ~A~%" (elephant-serializer2::deserialize k nil) pointer position)))) (defmacro with-key ((bs num) &body body) `(with-buffer-stream (,bs) (elephant-serializer2::serialize ,num ,bs) , at body)) From rread at common-lisp.net Wed Feb 14 22:39:10 2007 From: rread at common-lisp.net (rread) Date: Wed, 14 Feb 2007 17:39:10 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070214223910.8A02519008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv3373 Modified Files: sql-controller.lisp Log Message: Changes to make sqlite3 work --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/08 22:33:35 1.18 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/14 22:39:10 1.19 @@ -41,6 +41,13 @@ creation, counters, locks, the root (for garbage collection,) et cetera. This is the Postgresql-specific subclass of store-controller.")) +(defmethod supports-sequence ((sc sql-store-controller)) + (not (equal + (car (cadr (controller-spec sc))) + :sqlite3) + ) +) + ;; This should be much more elegant --- but as of Feb. 6, SBCL 1.0.2 has a weird, ;; unpleasant bug when ASDF tries to load this stuff. ;; (defvar *thread-table-lock* nil) @@ -52,13 +59,13 @@ (if (null *thread-table-lock*) ;; nil ;; (setq *thread-table-lock* (sb-thread::make-mutex :name "thread-table-lock")) - (setq *thread-table-lock* (elephant::ele-make-lock)) + (setq *thread-table-lock* (elephant-utils::ele-make-lock)) ) ) (defun thread-hash () - (elephant::ele-thread-hash-key) + (elephant-utils::ele-thread-hash-key) ) @@ -284,14 +291,26 @@ (clsql:table-exists-p [version] :database con :owner :all) ) -(defun create-version-table (con) - ;; ALL OF THIS needs to be inside a transaction. - (clsql::create-table [version] +(defun create-version-table (sc) + (let ((con (controller-db sc))) + (clsql::create-table [version] '( ([dbversion] text :not-null) ) :database con ) - ) + (if (and (clsql:table-exists-p [keyvlaue] :database con :owner :all) + (= 0 (caar (clsql:query "select count(*) from keyvalue")))) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" *elephant-code-version*)) + :database con) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" '(0 6 0))) + :database con) + ) + ) + ) ;; These functions are probably not cross-database portable... (defun keyvalue-table-exists (con) @@ -320,7 +339,7 @@ ;; storing blobs now in the Berkeley-db and we meed to make sure ;; we are properly testing that. However, blobs are awkward to ;; handle, so I am going to do this first... -(defun create-keyvalue-table (con) +(defun create-keyvalue-table (sc) ;; the "serial" specifiation here does not seem to work, ( ;; apparently not supported by clsql, so I have to execute these ;; commands specifically. This may be a database-dependent way of doing @@ -334,25 +353,29 @@ ;; CREATE-SEQUENCE and SEQUENCE-NEXT. That would solve our problem! ;; ALL OF THIS needs to be inside a transaction. - + (let* ((con (controller-db sc))) ;; At one time this was conditional, but all NEW repositories should have this. - (clsql::create-sequence [serial] :database con) - (clsql::query - (format nil "create table keyvalue ( + (if (supports-sequence sc) + (progn + (clsql::create-sequence [serial] :database con) + (clsql::query + (format nil "create table keyvalue ( pk integer PRIMARY KEY DEFAULT nextval('serial'), clctn_id integer NOT NULL, key varchar NOT NULL, value varchar )") - :database con) -;; (clsql::create-table [keyvalue] -;; ;; This is most likely to work with any database system.. -;; '( -;; ([clctn_id] integer :not-null) -;; ([key] text :not-null) -;; ([value] text) -;; ) -;; :database con) + :database con) + ) + (clsql::create-table [keyvalue] + ;; This is most likely to work with any database system.. + '( + ([clctn_id] integer :not-null) + ([key] text :not-null) + ([value] text) + ) + :database con) + ) ;; :constraints '("PRIMARY KEY (clctn_id key)" ;; "UNIQUE (clctn_id,key)") @@ -380,7 +403,7 @@ :attributes '([clctn_id] [key]) :database con) ;;) - ) + )) (defmethod database-version ((sc sql-store-controller)) "A version determination for a given store @@ -397,13 +420,6 @@ (read-from-string (caar tuples)) nil)))) -(defun set-database-version (sc) - (let ((con (controller-db sc))) - (clsql::insert-records :into [version] - :attributes '(dbversion) - :values (list (format nil "~A" *elephant-code-version*)) - :database con))) - (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning @@ -427,13 +443,11 @@ ;; it does not, we need to create it.. (unless (keyvalue-table-exists con) (with-transaction (:store-controller sc) - (create-keyvalue-table con))) + (create-keyvalue-table sc))) (setf (uses-pk-of sc) (query-uses-pk con)) (unless (version-table-exists con) (with-transaction (:store-controller sc) - (create-version-table con))) - ;; Set elephant version if new - (when new-p (set-database-version sc)) + (create-version-table sc))) (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)) From ieslick at common-lisp.net Fri Feb 16 03:43:47 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 15 Feb 2007 22:43:47 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070216034347.DF3BA1A09C@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv26996 Modified Files: TODO elephant.asd Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/TODO 2007/02/14 04:36:08 1.48 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/16 03:43:47 1.49 @@ -227,6 +227,8 @@ (ala AllegroCache) - Support for cheap persistent sets (medium? can do on SQL?) - Native persistent hashes (easy for BDB; can do on SQL backends?) + - Persistent aggregates for better conceptual integration with lisp? + - pcons, parray, pstruct, etc - Support a simple object query language over the database - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/14 04:36:08 1.29 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/16 03:43:47 1.30 @@ -161,7 +161,8 @@ ((:file "package") (:file "convenience") (:file "locks") - (:file "os"))) + (:file "os")) + :serial t) (:module memutil :components ((:elephant-c-source "libmemutil") From ieslick at common-lisp.net Fri Feb 16 03:43:48 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 15 Feb 2007 22:43:48 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070216034348.1DDD81B010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv26996/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 17:41:29 1.24 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 03:43:47 1.25 @@ -232,29 +232,29 @@ (cdr result))) (defmethod start-deadlock-detector ((ctrl bdb-store-controller) &key (type :oldest) (time 0.1) log) - (multiple-value-bind (str errstr pid) - (launch-background-program - (second (controller-spec ctrl)) - (namestring - (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) - :args `("-a" ,(lookup-deadlock-type type) - "-t" ,(format nil "~D" time) - ,@(when log (list "-L" (format nil "~A" log))))) + (let ((process-handle + (launch-background-program + (second (controller-spec ctrl)) + (namestring + (make-pathname :defaults (get-user-configuration-parameter :berkeley-db-deadlock))) + :args `("-a" ,(lookup-deadlock-type type) + "-t" ,(format nil "~D" time) + ,@(when log (list "-L" (format nil "~A" log))))))) (declare (ignore str errstr)) - (setf (controller-deadlock-pid ctrl) pid))) + (setf (controller-deadlock-pid ctrl) process-handle))) (defmethod stop-deadlock-detector ((ctrl bdb-store-controller)) (when (controller-deadlock-pid ctrl) (kill-background-program (controller-deadlock-pid ctrl)))) ;; -;; Take advantage of release 4.4's compact storage feature. Hidden features of BDB only +;; Take advantage of release 4.4's compact storage feature. Feature of BDB only ;; (defmethod optimize-storage ((ctrl bdb-store-controller) &key start-key stop-key (freelist-only nil) (free-space t) &allow-other-keys) - "Tell the backend to optimize storage between key values" + "Tell the backend to optimize and reclaim storage between key values" (with-buffer-streams (start stop end) (if (null start) (progn From ieslick at common-lisp.net Fri Feb 16 03:43:48 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 15 Feb 2007 22:43:48 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070216034348.5438B1E071@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv26996/src/utils Modified Files: os.lisp Log Message: Latest changes to launching deadlock processes, all lisps supported (but not tested) except lispworks --- /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/14 04:38:56 1.1 +++ /project/elephant/cvsroot/elephant/src/utils/os.lisp 2007/02/16 03:43:48 1.2 @@ -1,26 +1,54 @@ (in-package :elephant-utils) +(defmacro in-directory ((dir) &body body) + `(progn + (#+sbcl sb-posix:chdir + #+cmu unix:unix-chdir + #+allegro excl:chdir + #+lispworks hcl:change-directory + #+openmcl ccl:cwd + ,dir) + , at body)) + (defun launch-background-program (directory program &key (args nil)) "Launch a program in a specified directory - not all shell interfaces or OS's support this" #+(and allegro (not mswindows)) - (excl:run-shell-command (concat-separated-strings " " (list program) args) - :wait nil - :directory directory) -;; #+(and allegro mswindows) -;; #+(and sbcl unix) -;; (sb-ext:start-process ... -;; #+(and openmcl unix) -;; #+lispworks + (multiple-value-bind (in out pid) + (excl:run-shell-command (concat-separated-strings " " (list program) args) + :wait nil + :directory directory) + (declare (ignore in out)) + pid) + #+(and sbcl unix) + (in-directory (directory) + (sb-ext:run-program program args :wait nil)) + #+cmu + (in-directory (directory) + (ext:run-program program args :wait nil)) + #+openmcl + (in-directory (directory) + (ccl:run-program program args :wait nil)) + #+lispworks + (apply #'sys::call-system + (format nil "~a~{ '~a'~}~@[ &~]" prog args) + :current-directory directory + :wait nil) ) -(defun kill-background-program (pid) +(defun kill-background-program (process-handle) #+(and allegro (not mswindows)) - (progn (excl.osi:kill pid 9) - (system:reap-os-subprocess :pid pid)) -;; #+(and allegro mswindows) + (progn (excl.osi:kill process-handle 9) + (system:reap-os-subprocess :pid process-handle)) #+(and sbcl unix) - (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid))) + (sb-ext:process-kill process-handle 9) + #+openmcl + (ccl:signal-external-process process-handle 9) +;; #+lispworks +;; (apply #'sys::call-system +;; (format nil "kill ~A -9" process-handle) +;; :current-directory directory +;; :wait t) ) From ieslick at common-lisp.net Fri Feb 16 07:11:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 02:11:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070216071102.6007534020@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv28850 Modified Files: TODO Log Message: Cleaned up optimize-storage for BDB backends with optimize-layout generic function on stores and btrees --- /project/elephant/cvsroot/elephant/TODO 2007/02/16 03:43:47 1.49 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/16 07:11:02 1.50 @@ -13,13 +13,10 @@ - Validate SQL migration 0.6.0->0.6.1 (Robert) - Legacy conversions issue for SQL (and BDB?) due to package rename (both) - TASKS TO GET TO BETA: BDB Features/Cleanup: - Always support locks that timeout? Tradeoffs? -- Figure out how to compact a specific btree and/or key-range using optimize-storage. - Probably need to update keyword part of the API - Perform checkpoints (prep for DCM functionality) - Verify db_deadlock for other lisps (launch and kill background program I/F) - Derived indices fail to re-connect, verify this @@ -63,7 +60,9 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- -February 13th, 2007: +February 13-17th, 2007: +x Figure out how to compact a specific btree and/or key-range using optimize-storage. + Probably need to update keyword part of the API x User choice to run db_deadlock when opening a bdb backend? Requires path to functions and ability to launch shell command. Closing the store stops the sub-process. x Resolve duplicate ordering issues (punting to future release; documentation fix) From ieslick at common-lisp.net Fri Feb 16 07:11:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 02:11:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070216071102.AA75138010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv28850/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp package.lisp Log Message: Cleaned up optimize-storage for BDB backends with optimize-layout generic function on stores and btrees --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/14 04:36:09 1.18 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/16 07:11:02 1.19 @@ -72,6 +72,13 @@ (db-delete-buffered (controller-btrees sc) key-buf)))) +(defmethod optimize-layout ((bt bdb-btree) &key (freelist-only t) (free-space nil) &allow-other-keys) + (optimize-layout (get-con bt) + :start-key (oid bt) + :end-key (oid bt) + :freelist-only freelist-only + :free-space free-space)) + ;; Secondary indices (defclass bdb-indexed-btree (indexed-btree bdb-btree) @@ -232,7 +239,7 @@ (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)) + (controller-indices-assoc (get-con bt)) key-buf value-buf))) (if buf (values (deserialize buf (get-con bt)) T) (values nil nil))))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 03:43:47 1.25 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 07:11:02 1.26 @@ -251,23 +251,29 @@ ;; Take advantage of release 4.4's compact storage feature. Feature of BDB only ;; -(defmethod optimize-storage ((ctrl bdb-store-controller) &key start-key stop-key - (freelist-only nil) (free-space t) - &allow-other-keys) +(defmethod optimize-layout ((ctrl bdb-store-controller) &key start-key stop-key + (freelist-only t) (free-space nil) + &allow-other-keys) "Tell the backend to optimize and reclaim storage between key values" (with-buffer-streams (start stop end) - (if (null start) + (if (null start-key) (progn - (db-compact (controller-db ctrl) nil nil end) - (db-compact (controller-btrees ctrl) nil nil end) (db-compact (controller-indices ctrl) nil nil end) - (db-compact (controller-indices-assoc ctrl) nil nil end) - (db-compact (controller-oid-db ctrl) nil nil end)) + (db-compact (controller-db ctrl) nil nil end) + (db-compact (controller-btrees ctrl) nil nil end)) (progn (serialize start-key start ctrl) - (db-compact (controller-db ctrl) start - (when stop-key (serialize stop-key stop ctrl) stop) - end + (when stop-key (serialize stop-key stop ctrl)) + (db-compact (controller-indices ctrl) start + (when stop-key stop) end + :freelist-only freelist-only + :free-space free-space) + (db-compact (controller-db ctrl) nil + (when stop-key stop) end + :freelist-only freelist-only + :free-space free-space) + (db-compact (controller-btrees ctrl) nil + (when stop-key stop) end :freelist-only freelist-only :free-space free-space))) (values (deserialize end ctrl)))) --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/14 04:36:10 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/16 07:11:02 1.5 @@ -41,4 +41,4 @@ (:import-from :ccl #:byte-length) (:export - #:optimize-storage)) + #:optimize-layout)) From ieslick at common-lisp.net Fri Feb 16 07:11:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 02:11:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070216071102.E344F38010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv28850/src/elephant Modified Files: collections.lisp controller.lisp package.lisp Log Message: Cleaned up optimize-storage for BDB backends with optimize-layout generic function on stores and btrees --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/14 04:36:10 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/16 07:11:02 1.9 @@ -57,6 +57,9 @@ (defgeneric existsp (key bt) (:documentation "Test existence of a key / value pair in a BTree")) +(defmethod optimize-layout ((bt t) &key &allow-other-keys) + t) + ;; ;; Btrees that support secondary indices ;; --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 17:41:29 1.33 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 07:11:02 1.34 @@ -307,10 +307,11 @@ (:documentation "Provides a persistent source of unique id's")) -(defgeneric optimize-storage (sc &key &allow-other-keys) - (:documentation - "Tell the backend to reclaim any storage caused by key deletion, if possible. - This should default to return space to the filesystem rather than just to the free list.")) +(defgeneric optimize-layout (sc &key &allow-other-keys) + (:documentation "If supported, speed up the index and allocation by freeing up + any available storage and return it to the free list. See the + methods of backends to determine what options are valid. Supported + both on stores (all btrees and persistent slots) and specific btrees")) ;; ;; Low-level support for metaclass protocol @@ -377,7 +378,7 @@ ;; -;; Operations on the root index +; Operations on the root index ;; (defun add-to-root (key value &key (store-controller *store-controller*)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/14 17:41:29 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/16 07:11:02 1.14 @@ -35,7 +35,7 @@ #:get-cached-instance #:flush-instance-cache #:controller-symbol-cache #:controller-symbol-id-cache #:controller-fast-symbols-p - #:optimize-storage + #:optimize-layout #:get-user-configuration-parameter #:upgrade From ieslick at common-lisp.net Fri Feb 16 17:02:38 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 12:02:38 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070216170238.A35C731035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv734 Modified Files: bdb-controller.lisp Log Message: Fixed bug in failing to properly detect the version while opening 0.6.0 BDB db's in 0.6.1 --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 07:11:02 1.26 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 17:02:38 1.27 @@ -66,7 +66,7 @@ (recover-fatal nil) (thread t) (deadlock-detect nil)) (let ((env (db-env-create)) - (new-p (not (probe-file (make-pathname :defaults (second (controller-spec sc)) + (new-p (not (probe-file (make-pathname :directory (second (controller-spec sc)) :name "%ELEPHANT"))))) (setf (controller-environment sc) env) (db-env-set-flags env 0 :auto-commit t) From ieslick at common-lisp.net Fri Feb 16 23:02:51 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 18:02:51 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070216230251.438DC281E3@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv31505 Modified Files: TODO Log Message: Changed transaction protocol to better support multiple-stores. Should only effect BDB and not SQL, migration and upgrade fixes, some more debug support; green on Allegro/MacOS BDB and SQlite3 --- /project/elephant/cvsroot/elephant/TODO 2007/02/16 07:11:02 1.50 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/16 23:02:50 1.51 @@ -11,7 +11,10 @@ Migration: - Validate BDB migration 0.6.0->0.6.1 (Ian) - Validate SQL migration 0.6.0->0.6.1 (Robert) -- Legacy conversions issue for SQL (and BDB?) due to package rename (both) +- Improve migration robustness + high - resolve store-controller conflicts + high - avoid transaction limits in map-btree by adaptive chunking + low - Nested persistent objects in standard objects, arrays, etc TASKS TO GET TO BETA: @@ -61,6 +64,7 @@ ---------------------------------- February 13-17th, 2007: +x Legacy conversions issue for SQL (and BDB?) due to package rename (both) x Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API x User choice to run db_deadlock when opening a bdb backend? Requires path to From ieslick at common-lisp.net Fri Feb 16 23:02:52 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 18:02:52 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070216230252.03140281DC@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv31505/src/db-bdb Modified Files: bdb-transactions.lisp berkeley-db.lisp package.lisp Log Message: Changed transaction protocol to better support multiple-stores. Should only effect BDB and not SQL, migration and upgrade fixes, some more debug support; green on Allegro/MacOS BDB and SQlite3 --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/14 04:36:10 1.7 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/16 23:02:51 1.8 @@ -40,14 +40,15 @@ :txn-sync txn-sync)))) (declare (type pointer-void txn)) (let ((result - (let ((*current-transaction* txn)) - (declare (special *current-transaction*)) + (let ((*current-transaction* (make-transaction-record sc txn)) + (*store-controller* sc)) + (declare (special *current-transaction* *store-controller*)) (catch 'transaction (unwind-protect (prog1 (funcall txn-fn) (db-transaction-commit txn :txn-nosync txn-nosync - :txn-sync txn-sync) + :txn-sync txn-sync) (setq success t)) (unless success (db-transaction-abort txn))))))) --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/02 23:51:58 1.7 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/16 23:02:51 1.8 @@ -73,7 +73,9 @@ ) (defmacro txn-default (dvar) - `(if ,dvar ,dvar +NULL-VOID+)) + (let ((dv (gensym))) + `(let ((,dv ,dvar)) + (if ,dv (transaction-object ,dv) +NULL-VOID+)))) ;; ;; Constants and Flags --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/16 07:11:02 1.5 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/16 23:02:51 1.6 @@ -19,6 +19,10 @@ (in-package :cl-user) +(defpackage sleepycat + (:documentation "For legacy upgrades") + (:use common-lisp)) + (defpackage db-bdb (:documentation "A low-level UFFI-based interface to Berkeley DB to implement the elephant front-end framework. Uses the From ieslick at common-lisp.net Fri Feb 16 23:02:53 2007 From: ieslick at common-lisp.net (ieslick) Date: Fri, 16 Feb 2007 18:02:53 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070216230253.BA5D92B032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv31505/src/elephant Modified Files: backend.lisp controller.lisp migrate.lisp serializer1.lisp serializer2.lisp transactions.lisp Log Message: Changed transaction protocol to better support multiple-stores. Should only effect BDB and not SQL, migration and upgrade fixes, some more debug support; green on Allegro/MacOS BDB and SQlite3 --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/04 10:08:27 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/02/16 23:02:53 1.11 @@ -68,6 +68,9 @@ #:cursor-initialized-p ;; Transactions #:*current-transaction* + #:make-transaction-record + #:transaction-store + #:transaction-object #:execute-transaction #:controller-start-transaction #:controller-commit-transaction @@ -127,6 +130,9 @@ #:cursor-initialized-p ;; Transactions #:*current-transaction* + #:make-transaction-record + #:transaction-store + #:transaction-object #:execute-transaction #:controller-start-transaction #:controller-commit-transaction --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 07:11:02 1.34 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 23:02:53 1.35 @@ -349,13 +349,15 @@ "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 or single-store per thread apps" + applications or single-store per thread apps. Multi-store apps should either confine + their *store-controller* to a given dynamic context or wrap each store-specific op in + a transaction using with or ensure transaction" (assert (consp spec)) (let ((controller (get-controller spec))) (apply #'open-controller controller args) (if *store-controller* (progn - (warn "Store controller already set so was not updated") +;; (warn "Store controller already set so was not updated") ;; this was annoying me controller) (setq *store-controller* controller)))) --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/08 23:07:18 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/16 23:02:53 1.6 @@ -133,18 +133,19 @@ ;; for users breaking the class-index abstraction (assert (not (object-was-copied-p classidx))) (let ((newcidx - (with-transaction (:store-controller dst) + (ensure-transaction (:store-controller dst) (build-indexed-btree dst)))) ;; Add inverse indices to new main class index (map-indices (lambda (name srciidx) - (with-transaction (:store-controller dst) - (add-index newcidx - :index-name name - :key-form (key-form srciidx) - :populate nil))) + (let ((key-form (key-form srciidx))) + (ensure-transaction (:store-controller dst) + (add-index newcidx + :index-name name + :key-form key-form + :populate nil)))) classidx) ;; Add the class index to the class root - (with-transaction (:store-controller dst) + (ensure-transaction (:store-controller dst) (setf (get-value classname (controller-class-root dst)) newcidx)) ;; Update the class to point at objects in the new store (setf (%index-cache (find-class classname)) newcidx) @@ -158,7 +159,7 @@ (map-btree (lambda (key value) (let ((newval (migrate dst value))) (unless (eq key *elephant-properties-label*) - (with-transaction (:store-controller dst :txn-nosync t) + (ensure-transaction (:store-controller dst :txn-nosync t) (add-to-root key newval :store-controller dst))))) (controller-root src)) dst) @@ -168,7 +169,7 @@ (map-btree (lambda (oldoid oldinst) (declare (ignore oldoid)) (let ((newinst (migrate sc oldinst))) - (with-transaction (:store-controller sc) + (ensure-transaction (:store-controller sc) ;; This isn't redundant in most cases, but we may have ;; indexed objects without slots and without a slot ;; write the new index won't be updated in that case @@ -245,7 +246,7 @@ (loop for slot-def in (persistent-slot-defs class) do (when (slot-boundp-using-class class src slot-def) (let ((value (migrate dstsc (slot-value-using-class class src slot-def)))) - (with-transaction (:store-controller dstsc) + (ensure-transaction (:store-controller dstsc) (setf (slot-value-using-class class dst slot-def) value)))))) @@ -256,7 +257,7 @@ (if (object-was-copied-p src) (retrieve-copied-object src) (let ((newbtree (build-btree dst))) - (with-transaction (:store-controller dst :txn-nosync t) + (ensure-transaction (:store-controller dst :txn-nosync t) (copy-btree-contents dst newbtree src)) (register-copied-object src newbtree) newbtree))) @@ -265,19 +266,26 @@ "Also copy the inverse indices for indexed btrees" (if (object-was-copied-p src) (retrieve-copied-object src) - (with-transaction (:store-controller dst :txn-nosync t) - (let ((newbtree (build-indexed-btree dst))) - (copy-btree-contents dst newbtree src) - (map-indices (lambda (name srciidx) - (add-index newbtree :index-name name :key-form (key-form srciidx) :populate t)) - src) - (register-copied-object src newbtree) - newbtree)))) + (let ((newbtree + (ensure-transaction (:store-controller dst :txn-nosync t) + (build-indexed-btree dst)))) + (ensure-transaction (:store-controller dst :txn-nosync t) + (copy-btree-contents dst newbtree src)) + (map-indices (lambda (name srciidx) + (format t "Adding index: ~A~%" name) + (let ((key-form (key-form srciidx))) + (ensure-transaction (:store-controller dst :txn-nosync t) + (add-index newbtree :index-name name :key-form key-form :populate t)))) + src) + (register-copied-object src newbtree) + newbtree))) (defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) - (let ((newval (migrate sc value))) - (setf (get-value key dst) newval))) + (format t "Migrating btree entry: ~A ~A~%" key value) + (let ((newval (migrate sc value)) + (newkey (migrate sc key))) + (setf (get-value newkey dst) newval))) src)) @@ -296,7 +304,9 @@ :rehash-size (hash-table-rehash-size src) :rehash-threshold (hash-table-rehash-threshold src)))) (maphash (lambda (key value) - (setf (gethash key newhash) (migrate dst value))) + (format t "Migrating hash entry: ~A ~A~%" key value) + (setf (gethash key newhash) + (migrate dst value))) src))) (defmethod migrate ((dst store-controller) (src cons)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/09 09:06:12 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/16 23:02:53 1.9 @@ -281,6 +281,51 @@ (%serialize frob) bs)) +(defparameter *trace-serializer* t) + +(defparameter *tag-table* + `((,+fixnum+ . "fixnum32") + (,+char+ . "char") + (,+single-float+ . "single-float") + (,+double-float+ . "double float") + (,+negative-bignum+ . "neg bignum") + (,+positive-bignum+ . "pos bignum") + (,+rational+ . "rational number") + (,+nil+ . "null") + (,+ucs1-symbol+ . "8-bit symbol") + (,+ucs1-string+ . "8-bit string") + (,+ucs1-pathname+ . "8-bit pathname") + (,+ucs2-symbol+ . "16-bit symbol") + (,+ucs2-string+ . "16-bit string") + (,+ucs2-pathname+ . "16-bit pathname") + (,+ucs4-symbol+ . "32-bit symbol") + (,+ucs4-string+ . "32-bit string") + (,+ucs4-pathname+ . "32-bit pathname") + (,+persistent+ . "persistent object") + (,+cons+ . "cons cell") + (,+hash-table+ . "hash table") + (,+object+ . "standard object") + (,+array+ . "array"))) + +(defun enable-serializer-tracing () + (setf *trace-serializer* t)) + +(defun disable-serializer-tracing () + (setf *trace-serializer* nil)) + +(defun print-pre-deserialize-tag (tag) + (when *trace-serializer* + (let ((tag-name (assoc tag *tag-table*))) + (if tag-name + (format t "Deserializing type: ~A~%" tag-name) + (progn + (format t "Unrecognized tag: ~A~%" tag) + (break)))))) + +(defun print-post-deserialize-tag (value) + (when *trace-serializer* + (format t "Returned: ~A~%" value))) + (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) @@ -291,6 +336,8 @@ (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) +;; (print-pre-deserialize-tag tag) +;; (let ((value (cond ((= tag +fixnum+) (buffer-read-fixnum bs)) @@ -429,7 +476,10 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) - (t (error "deserialize fubar!")))))) + (t (error "deserialize fubar!"))) +;; (print-post-deserialize-tag value) +;; value) + ))) (etypecase buf-str (null (return-from deserialize nil)) (buffer-stream --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/13 16:50:40 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/16 23:02:53 1.24 @@ -341,6 +341,50 @@ ;;; DESERIALIZER ;;; +(defparameter *trace-deserializer* t) + +(defparameter *tag-table* + `((,+fixnum32+ . "fixnum32") + (,+fixnum64+ . "fixnum32") + (,+char+ . "char") + (,+single-float+ . "single-float") + (,+double-float+ . "double float") + (,+negative-bignum+ . "neg bignum") + (,+positive-bignum+ . "pos bignum") + (,+rational+ . "rational number") + (,+nil+ . "null") + (,+utf8-string+ . "UTF8 string") + (,+utf16-string+ . "UTF16le string") + (,+uft32-string+ . "UTF32le string") + (,+symbol+ . "symbol") + (,+pathname+ . "pathname") + (,+persistent+ . "persistent object") + (,+cons+ . "cons cell") + (,+hash-table+ . "hash table") + (,+object+ . "standard object") + (,+array+ . "array") + (,+struct+ . "struct") + (,+class+ . "class"))) + +(defun enable-deserializer-tracing () + (setf *trace-deserializer* t)) + +(defun disable-deserializer-tracing () + (setf *trace-deserializer* nil)) + +(defun print-pre-deserialize-tag (tag) + (when *trace-deserializer* + (let ((tag-name (assoc tag *tag-table*))) + (if tag-name + (format t "Deserializing type: ~A~%" tag-name) + (progn + (format t "Unrecognized tag: ~A~%" tag) + (break)))))) + +(defun print-post-deserialize-tag (value) + (when *trace-deserializer* + (format t "Returned: ~A~%" value))) + (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." (declare (type (or null buffer-stream) buf-str)) @@ -357,6 +401,8 @@ (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag) (dynamic-extent tag)) +;; (print-pre-deserialize-tag tag) +;; (let ((value (cond ((= tag +fixnum32+) (buffer-read-fixnum32 bs)) @@ -479,7 +525,10 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) - (t (error "deserialize fubar!")))))) + (t (error "deserialize fubar!"))) +;; (print-post-deserialize-tag value) +;; value) + ))) (etypecase buf-str (null (return-from deserialize nil)) (buffer-stream --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/14 04:36:10 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/16 23:02:53 1.7 @@ -58,6 +58,37 @@ ;; - A typical design approach is to make sure that the most primitive interfaces to the backend ;; database look at *current-transaction* to determine whether a transaction is active. Users code can also ;; access this parameter to check whether a transaction is active. +;; +;; Multiple store considerations: +;; - When operating with multiple stores, nested transactions and BDB there are some subtle issues to +;; work around: how to avoid writing one store with a transaction created in the context of another. +;; - For many leaf functions: *store-controller* and *current-transaction* have to both be correct; +;; this requirement may relax in the future +;; - The following macros accomodate multiple stores by requiring that execute-transaction return a +;; pair of (store-controller . txn-obj) where txn-obj is owned by the backend and the store-controller +;; is the store instance it is associated with. A nested or ensured transaction is only indicated +;; in the call to execute transaction if the store controllers match, otherwise a new transaction +;; for that store is created + +(defun make-transaction-record (sc txn) + "Backends must use this to assign values to *current-transaction* binding" + (cons sc txn)) + +(defun transaction-store (txnrec) + "Get the store that owns the transaction from a transaction record" + (car txnrec)) + +(defun transaction-object (txnrec) + "Get the backend-specific transaction object" + (cdr txnrec)) + +(defun transaction-object-p (txnrec) + (consp txnrec)) + +(defun owned-txn-p (sc parent-txn-rec) + (and parent-txn-rec + (transaction-object-p parent-txn-rec) + (eq sc (transaction-store parent-txn-rec)))) (defmacro with-transaction ((&rest keyargs &key (store-controller '*store-controller*) @@ -70,12 +101,16 @@ aborted. If the body deadlocks, the body is re-executed in a new transaction, retrying a fixed number of iterations. If nested, the backend must support nested transactions." - `(funcall #'execute-transaction ,store-controller - (lambda () , at body) - :parent ,parent - :retries ,retries - ,@(remove-keywords '(:store-controller :parent :retries) - keyargs))) + (let ((sc (gensym))) + `(let ((,sc ,store-controller)) + (funcall #'execute-transaction ,store-controller + (lambda () , at body) + :parent (if (owned-txn-p ,sc ,parent) + (transaction-object ,parent) + nil) + :retries ,retries + ,@(remove-keywords '(:store-controller :parent :retries) + keyargs))))) (defmacro ensure-transaction ((&rest keyargs &key (store-controller '*store-controller*) @@ -88,9 +123,11 @@ 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 () , at body))) - (if ,transaction + (let ((txn-fn (gensym)) + (sc (gensym))) + `(let ((,txn-fn (lambda () , at body)) + (,sc ,store-controller)) + (if (owned-txn-p ,sc ,transaction) (funcall ,txn-fn) (funcall #'execute-transaction ,store-controller ,txn-fn @@ -103,7 +140,7 @@ (defmacro with-batched-transaction ((batch size list &rest txn-options) &body body) "Perform a set of DB operations over a list of elements in batches of size 'size'. Pass specific transaction options after the list reference." - `(loop for ,batch in (subsets ,subset-size ,list) do + `(loop for ,batch in (subsets ,size ,list) do (with-transaction ,txn-options , at body))) From ieslick at common-lisp.net Sat Feb 17 12:13:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 07:13:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070217121319.14B7938013@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv11213 Modified Files: TODO Log Message: Final migration fixes for BDB and restructuring of BDB default transaction handling to allow for nested controllers and transactions; migration info --- /project/elephant/cvsroot/elephant/TODO 2007/02/16 23:02:50 1.51 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/17 12:13:18 1.52 @@ -9,33 +9,32 @@ TASKS TO GET TO ALPHA: Migration: -- Validate BDB migration 0.6.0->0.6.1 (Ian) - Validate SQL migration 0.6.0->0.6.1 (Robert) -- Improve migration robustness - high - resolve store-controller conflicts - high - avoid transaction limits in map-btree by adaptive chunking - low - Nested persistent objects in standard objects, arrays, etc TASKS TO GET TO BETA: BDB Features/Cleanup: - Always support locks that timeout? Tradeoffs? - Perform checkpoints (prep for DCM functionality) -- Verify db_deadlock for other lisps (launch and kill background program I/F) -- Derived indices fail to re-connect, verify this +- Derived indices used to fail on re-connect, verify this Lisp Support: -- 64-bit lisp verification - Win32 builds - Windows support for asdf-based library builds? Include 32-bit dll in release? +- 64-bit lisp verification - Validate OpenMCL 1.1 on Mac OS X - Validate Lispworks +- Verify db_deadlock for other lisps (launch and kill background program I/F) Stability and Performance: -- Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Review and address all NOTE comments in the code - Review SBCL string serialization performance - Improve SQL base-64 serializer performance? +- Migration: Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs +- Migration: Improve support for nested persistent objects inside standard objects, arrays, etc? +- Migration: Improve scaling properties of migration so all objects do not need to be resident in memory? +- Migration: Validate that graph structures with loop are copied properly +- Migration: Improve printing and informative messages TASKS TO GET TO FINAL RELEASE: @@ -64,6 +63,7 @@ ---------------------------------- February 13-17th, 2007: +x Fix BDB migration 0.6.0->0.6.1, improve nested transaction/store interactions x Legacy conversions issue for SQL (and BDB?) due to package rename (both) x Figure out how to compact a specific btree and/or key-range using optimize-storage. Probably need to update keyword part of the API From ieslick at common-lisp.net Sat Feb 17 12:13:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 07:13:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070217121319.6BB903C00B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv11213/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp bdb-slots.lisp berkeley-db.lisp Log Message: Final migration fixes for BDB and restructuring of BDB default transaction handling to allow for nested controllers and transactions; migration info --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/16 07:11:02 1.19 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/17 12:13:19 1.20 @@ -39,19 +39,22 @@ (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))) + key-buf value-buf + :transaction (my-current-transaction sc)))) (if buf (values (deserialize buf sc) T) (values nil nil)))))) (defmethod existsp (key (bt bdb-btree)) - (with-buffer-streams (key-buf value-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)) - key-buf value-buf))) - (if buf t - nil)))) + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-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 + :transaction (my-current-transaction sc)))) + (if buf t + nil))))) (defmethod (setf get-value) (value key (bt bdb-btree)) @@ -61,16 +64,17 @@ (serialize key key-buf sc) (serialize value value-buf sc) (db-put-buffered (controller-btrees sc) - key-buf value-buf))) - value) + key-buf value-buf + :transaction (my-current-transaction sc)))) + value) (defmethod remove-kv (key (bt bdb-btree)) (let ((sc (get-con bt)) ) (with-buffer-streams (key-buf) (buffer-write-oid (oid bt) key-buf) (serialize key key-buf sc) - (db-delete-buffered (controller-btrees sc) - key-buf)))) + (db-delete-buffered (controller-btrees sc) key-buf + :transaction (my-current-transaction sc))))) (defmethod optimize-layout ((bt bdb-btree) &key (freelist-only t) (free-space nil) &allow-other-keys) (optimize-layout (get-con bt) @@ -132,7 +136,8 @@ ;; the key/value already exists (db-put-buffered (controller-indices sc) - secondary-buf primary-buf) + secondary-buf primary-buf + :transaction (my-current-transaction sc)) (reset-buffer-stream primary-buf) (reset-buffer-stream secondary-buf))) (let ((key-fn (key-fn index)) @@ -181,7 +186,8 @@ (serialize value value-buf sc) (ensure-transaction (:store-controller sc) (db-put-buffered (controller-btrees sc) - key-buf value-buf) + key-buf value-buf + :transaction (my-current-transaction sc)) (loop for index being the hash-value of indices do (multiple-value-bind (index? secondary-key) @@ -193,7 +199,8 @@ ;; should silently do nothing if the key/value already ;; exists (db-put-buffered (controller-indices sc) - secondary-buf key-buf) + secondary-buf key-buf + :transaction (my-current-transaction sc)) (reset-buffer-stream secondary-buf)))) value)))) ) @@ -220,10 +227,12 @@ ;; this is a C performance hack (db-delete-kv-buffered (controller-indices (get-con bt)) - secondary-buf key-buf) + secondary-buf key-buf + :transaction (my-current-transaction sc)) (reset-buffer-stream secondary-buf)))) (db-delete-buffered (controller-btrees (get-con bt)) - key-buf)))))))) + key-buf + :transaction (my-current-transaction sc))))))))) ;; This also needs to build the correct kind of index, and ;; be the correct kind of btree... @@ -235,14 +244,16 @@ (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-oid (oid bt) key-buf) - (serialize key key-buf (get-con bt)) - (let ((buf (db-get-key-buffered - (controller-indices-assoc (get-con bt)) - key-buf value-buf))) - (if buf (values (deserialize buf (get-con bt)) T) - (values nil nil))))) + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-oid (oid bt) key-buf) + (serialize key key-buf sc) + (let ((buf (db-get-key-buffered + (controller-indices-assoc sc) + key-buf value-buf + :transaction (my-current-transaction sc)))) + (if buf (values (deserialize buf sc) T) + (values nil nil)))))) (defmethod get-primary-key (key (bt btree-index)) (let ((sc (get-con bt))) @@ -251,7 +262,8 @@ (serialize key key-buf sc) (let ((buf (db-get-key-buffered (controller-indices sc) - key-buf value-buf))) + key-buf value-buf + :transaction (my-current-transaction sc)))) (if buf (let ((oid (buffer-read-oid buf))) (values (deserialize buf sc) oid)) @@ -263,10 +275,12 @@ (defmethod make-cursor ((bt bdb-btree)) "Make a cursor from a btree." - (make-instance 'bdb-cursor - :btree bt - :handle (db-cursor (controller-btrees (get-con bt))) - :oid (oid bt))) + (let ((sc (get-con bt))) + (make-instance 'bdb-cursor + :btree bt + :handle (db-cursor (controller-btrees sc) + :transaction (my-current-transaction sc)) + :oid (oid bt)))) (defmethod cursor-close ((cursor bdb-cursor)) (db-cursor-close (cursor-handle cursor)) @@ -461,12 +475,12 @@ (defmethod make-cursor ((bt bdb-btree-index)) "Make a secondary-cursor from a secondary index." - (make-instance 'bdb-secondary-cursor - :btree bt - :handle (db-cursor - (controller-indices-assoc (get-con bt))) - :oid (oid bt))) - + (let ((sc (get-con bt))) + (make-instance 'bdb-secondary-cursor + :btree bt + :handle (db-cursor (controller-indices-assoc sc) + :transaction (my-current-transaction sc)) + :oid (oid bt)))) (defmethod cursor-pcurrent ((cursor bdb-secondary-cursor)) (when (cursor-initialized-p cursor) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/16 17:02:38 1.27 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/17 12:13:19 1.28 @@ -59,6 +59,15 @@ (otherwise nil)))) ;; +;; Store-specific transaction support +;; + +(defmacro my-current-transaction (sc) + (let ((txn-rec *current-transaction*)) + (if (and txn-rec (eq (transaction-store txn-rec) sc)) + (transaction-object txn-rec) + +NULL-VOID+))) +;; ;; Open/close ;; @@ -186,7 +195,8 @@ (with-buffer-streams (key val) (serialize-database-version-key key) (let ((buf (db-get-key-buffered (controller-metadata sc) - key val))) + key val + :transaction +NULL-VOID+))) (if buf (deserialize-database-version-value buf) nil)))) @@ -196,7 +206,8 @@ (serialize-database-version-key key) (serialize-database-version-value *elephant-code-version* val) (db-put-buffered (controller-metadata sc) - key val) + key val + :transaction +NULL-VOID+) *elephant-code-version*)) ;; (defmethod old-database-version ((sc bdb-store-controller)) @@ -258,23 +269,26 @@ (with-buffer-streams (start stop end) (if (null start-key) (progn - (db-compact (controller-indices ctrl) nil nil end) - (db-compact (controller-db ctrl) nil nil end) - (db-compact (controller-btrees ctrl) nil nil end)) + (db-compact (controller-indices ctrl) nil nil end :transaction +NULL-VOID+) + (db-compact (controller-db ctrl) nil nil end :transaction +NULL-VOID+) + (db-compact (controller-btrees ctrl) nil nil end :transaction +NULL-VOID+)) (progn (serialize start-key start ctrl) (when stop-key (serialize stop-key stop ctrl)) (db-compact (controller-indices ctrl) start (when stop-key stop) end :freelist-only freelist-only - :free-space free-space) + :free-space free-space + :transaction +NULL-VOID+) (db-compact (controller-db ctrl) nil (when stop-key stop) end :freelist-only freelist-only - :free-space free-space) + :free-space free-space + :transaction +NULL-VOID+) (db-compact (controller-btrees ctrl) nil (when stop-key stop) end :freelist-only freelist-only - :free-space free-space))) + :free-space free-space + :transaction +NULL-VOID+))) (values (deserialize end ctrl)))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/02/02 23:51:58 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/02/17 12:13:19 1.3 @@ -30,7 +30,8 @@ (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) (let ((buf (db-get-key-buffered (controller-db sc) - key-buf value-buf))) + key-buf value-buf + :transaction (my-current-transaction sc)))) (if buf (deserialize buf sc) #+cmu (error 'unbound-slot :instance instance :slot name) @@ -44,7 +45,7 @@ (serialize new-value value-buf sc) (db-put-buffered (controller-db sc) key-buf value-buf - :transaction (txn-default *current-transaction*)) + :transaction (my-current-transaction sc)) new-value)) (defmethod persistent-slot-boundp ((sc bdb-store-controller) instance name) @@ -52,7 +53,8 @@ (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) (let ((buf (db-get-key-buffered (controller-db sc) - key-buf value-buf))) + key-buf value-buf + :transaction (my-current-transaction sc)))) (if buf t nil)))) (defmethod persistent-slot-makunbound ((sc bdb-store-controller) instance name) @@ -60,4 +62,6 @@ (buffer-write-int (oid instance) key-buf) (serialize name key-buf sc) (db-delete-buffered (controller-db sc) key-buf - :transaction (txn-default *current-transaction*)))) + :transaction (my-current-transaction sc)))) + + --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/16 23:02:51 1.8 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/02/17 12:13:19 1.9 @@ -73,9 +73,9 @@ ) (defmacro txn-default (dvar) - (let ((dv (gensym))) - `(let ((,dv ,dvar)) - (if ,dv (transaction-object ,dv) +NULL-VOID+)))) + `(progn + (assert (null ,dvar)) + +NULL-VOID+)) ;; ;; Constants and Flags From ieslick at common-lisp.net Sat Feb 17 12:13:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 07:13:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070217121319.A8AC43D00D@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv11213/src/elephant Modified Files: migrate.lisp transactions.lisp Log Message: Final migration fixes for BDB and restructuring of BDB default transaction handling to allow for nested controllers and transactions; migration info --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/16 23:02:53 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/17 12:13:19 1.7 @@ -21,12 +21,13 @@ ;; ;; The generic function Migrate provides an interface to moving objects between -;; repositories +;; repositories and is used by the upgrade interface. ;; ;; NOTES AND LIMITATIONS: ;; - Migrate currently will not handle circular list objects -;; - Migrate does not support arrays with nested persistent objects +;; - Migrate does not support arrays or standard objects with nested persistent objects +;; - There are potential problems with graphs and other deep structures ;; ;; - Indexed classes only have their class index copied if you use the ;; top level migration. Objects will be copied without slot data if you @@ -68,7 +69,7 @@ ;; to the target repository which you can then overwrite. To avoid the ;; default persistent slot copying, bind the dynamic variable ;; *inhibit-slot-writes* in your user method using -;; (with-inhibited-slot-copy () ...) a convenience macro +;; (with-inhibited-slot-copy () ...), a convenience macro. ;; @@ -132,20 +133,21 @@ ;; Class indexes should never be copied already; this checks ;; for users breaking the class-index abstraction (assert (not (object-was-copied-p classidx))) + (format t "Migrating class indexes for: ~A~%" classname) (let ((newcidx - (ensure-transaction (:store-controller dst) + (with-transaction (:store-controller dst) (build-indexed-btree dst)))) ;; Add inverse indices to new main class index (map-indices (lambda (name srciidx) (let ((key-form (key-form srciidx))) - (ensure-transaction (:store-controller dst) + (with-transaction (:store-controller dst) (add-index newcidx :index-name name :key-form key-form :populate nil)))) classidx) ;; Add the class index to the class root - (ensure-transaction (:store-controller dst) + (with-transaction (:store-controller dst) (setf (get-value classname (controller-class-root dst)) newcidx)) ;; Update the class to point at objects in the new store (setf (%index-cache (find-class classname)) newcidx) @@ -156,6 +158,7 @@ (register-copied-object classidx newcidx))) (controller-class-root src)) ;; Copy all other reachable objects + (format t "Copying the root:~%") (map-btree (lambda (key value) (let ((newval (migrate dst value))) (unless (eq key *elephant-properties-label*) @@ -165,9 +168,12 @@ dst) (defun copy-cindex-contents (new old) - (let ((sc (get-con new))) + (let ((sc (get-con new)) + (count 1)) (map-btree (lambda (oldoid oldinst) (declare (ignore oldoid)) + (when (= (mod (1- (incf count)) 1000) 0) + (format t "~A objects copied~%" count)) (let ((newinst (migrate sc oldinst))) (ensure-transaction (:store-controller sc) ;; This isn't redundant in most cases, but we may have @@ -243,10 +249,10 @@ (defun copy-persistent-slots (dstsc class src dst) "Copy only persistent slots from src to dst" - (loop for slot-def in (persistent-slot-defs class) do - (when (slot-boundp-using-class class src slot-def) - (let ((value (migrate dstsc (slot-value-using-class class src slot-def)))) - (ensure-transaction (:store-controller dstsc) + (ensure-transaction (:store-controller dstsc) + (loop for slot-def in (persistent-slot-defs class) do + (when (slot-boundp-using-class class src slot-def) + (let ((value (migrate dstsc (slot-value-using-class class src slot-def)))) (setf (slot-value-using-class class dst slot-def) value)))))) @@ -282,7 +288,6 @@ (defmethod copy-btree-contents ((sc store-controller) dst src) (map-btree (lambda (key value) - (format t "Migrating btree entry: ~A ~A~%" key value) (let ((newval (migrate sc value)) (newkey (migrate sc key))) (setf (get-value newkey dst) newval))) @@ -304,7 +309,6 @@ :rehash-size (hash-table-rehash-size src) :rehash-threshold (hash-table-rehash-threshold src)))) (maphash (lambda (key value) - (format t "Migrating hash entry: ~A ~A~%" key value) (setf (gethash key newhash) (migrate dst value))) src))) --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/16 23:02:53 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/17 12:13:19 1.8 @@ -78,10 +78,20 @@ "Get the store that owns the transaction from a transaction record" (car txnrec)) +(define-compiler-macro transaction-store (&whole form arg) + (if (atom arg) + `(car ,arg) + form)) + (defun transaction-object (txnrec) "Get the backend-specific transaction object" (cdr txnrec)) +(define-compiler-macro transaction-object (&whole form arg) + (if (atom arg) + `(cdr ,arg) + form)) + (defun transaction-object-p (txnrec) (consp txnrec)) From rread at common-lisp.net Sat Feb 17 16:48:17 2007 From: rread at common-lisp.net (rread) Date: Sat, 17 Feb 2007 11:48:17 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070217164817.8EEF850021@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv30705/src/elephant Modified Files: serializer2.lisp Log Message: Fixing typo -- uft to utf --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/16 23:02:53 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/17 16:48:17 1.25 @@ -355,7 +355,7 @@ (,+nil+ . "null") (,+utf8-string+ . "UTF8 string") (,+utf16-string+ . "UTF16le string") - (,+uft32-string+ . "UTF32le string") + (,+utf32-string+ . "UTF32le string") (,+symbol+ . "symbol") (,+pathname+ . "pathname") (,+persistent+ . "persistent object") From ieslick at common-lisp.net Sat Feb 17 19:28:53 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 14:28:53 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070217192853.4F765710D2@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv32211 Modified Files: TODO Log Message: Fixed unquoted macro in BDB --- /project/elephant/cvsroot/elephant/TODO 2007/02/17 12:13:18 1.52 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/17 19:28:53 1.53 @@ -16,7 +16,7 @@ BDB Features/Cleanup: - Always support locks that timeout? Tradeoffs? - Perform checkpoints (prep for DCM functionality) -- Derived indices used to fail on re-connect, verify this +- Derived indices used to fail on re-connect, verify that this is fixed Lisp Support: - Win32 builds @@ -36,8 +36,6 @@ - Migration: Validate that graph structures with loop are copied properly - Migration: Improve printing and informative messages -TASKS TO GET TO FINAL RELEASE: - 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 @@ -46,6 +44,10 @@ - Test with UTF-16 and UTF-32 strings (construct with char-code?) - Ensure that variable length UTF-8 is automatically stored as UTF-16 +TASKS TO GET TO FINAL RELEASE: + +Fix any bugs in BETA: + Documentation: - Add document section about backend interface: - Add notes about with/ensure-transaction usage (abort & commit behavior on exit) From ieslick at common-lisp.net Sat Feb 17 19:28:53 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 14:28:53 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070217192853.A551071119@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv32211/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Fixed unquoted macro in BDB --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/17 12:13:19 1.28 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/17 19:28:53 1.29 @@ -63,10 +63,11 @@ ;; (defmacro my-current-transaction (sc) - (let ((txn-rec *current-transaction*)) - (if (and txn-rec (eq (transaction-store txn-rec) sc)) - (transaction-object txn-rec) - +NULL-VOID+))) + (let ((txn-rec (gensym))) + `(let ((,txn-rec *current-transaction*)) + (if (and ,txn-rec (eq (transaction-store ,txn-rec) ,sc)) + (transaction-object ,txn-rec) + +NULL-CHAR+)))) ;; ;; Open/close ;; From ieslick at common-lisp.net Sat Feb 17 19:28:53 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 14:28:53 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070217192853.E95E61E010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv32211/src/elephant Modified Files: transactions.lisp Log Message: Fixed unquoted macro in BDB --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/17 12:13:19 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/17 19:28:53 1.9 @@ -78,19 +78,19 @@ "Get the store that owns the transaction from a transaction record" (car txnrec)) -(define-compiler-macro transaction-store (&whole form arg) - (if (atom arg) - `(car ,arg) - form)) +;;(define-compiler-macro transaction-store (&whole form arg) +;; (if (atom arg) +;; `(car ,arg) +;; form)) (defun transaction-object (txnrec) "Get the backend-specific transaction object" (cdr txnrec)) -(define-compiler-macro transaction-object (&whole form arg) - (if (atom arg) - `(cdr ,arg) - form)) +;;(define-compiler-macro transaction-object (&whole form arg) +;; (if (atom arg) +;; `(cdr ,arg) +;; form)) (defun transaction-object-p (txnrec) (consp txnrec)) From ieslick at common-lisp.net Sat Feb 17 20:37:23 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 17 Feb 2007 15:37:23 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070217203723.E48B51E003@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv11090/src/utils Modified Files: convenience.lisp Log Message: Bug fix in subsets function that shows up under SBCL --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/14 04:38:56 1.1 +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/17 20:37:23 1.2 @@ -15,10 +15,10 @@ (defun subsets (size list) "Generate subsets of size n from the list; the last subset has the remaining elements if size does not represent an equal division" - (let ((subsets nil)) - (loop for elt in list + (let ((subsets (cons nil nil))) + (loop for elt in list for i from 0 do - (when (= 0 (mod i size)) + (when (and (= 0 (mod i size)) (car subsets)) (setf (car subsets) (nreverse (car subsets))) (push nil subsets)) (push elt (car subsets))) From ieslick at common-lisp.net Sun Feb 18 10:58:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 05:58:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070218105858.61BFC3201F@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv3903 Modified Files: TODO Log Message: Provide checkpoint function --- /project/elephant/cvsroot/elephant/TODO 2007/02/17 19:28:53 1.53 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/18 10:58:58 1.54 @@ -14,8 +14,6 @@ TASKS TO GET TO BETA: BDB Features/Cleanup: -- Always support locks that timeout? Tradeoffs? -- Perform checkpoints (prep for DCM functionality) - Derived indices used to fail on re-connect, verify that this is fixed Lisp Support: @@ -49,22 +47,21 @@ Fix any bugs in BETA: Documentation: +- License and copyright file headers - Add document section about backend interface: - Add notes about with/ensure-transaction usage (abort & commit behavior on exit) - Add notes about optimize-storage - Add notes about deadlock-detect - Add notes about checkpoint (null in SQL?) -- Add notes about new BDB 4.5 *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. - More notes about transaction performance 0.6.1 - Features COMPLETED to date ---------------------------------- +February + February 13-17th, 2007: +x Allow checkpoint of BDB via db-bdb::checkpoint x Fix BDB migration 0.6.0->0.6.1, improve nested transaction/store interactions x Legacy conversions issue for SQL (and BDB?) due to package rename (both) x Figure out how to compact a specific btree and/or key-range using optimize-storage. @@ -173,6 +170,9 @@ (log these in Track) Features: + - Backup function: allow users to specify a backup function to archive the database contents + and checkpoint any active functions (how to lock out other threads?) In BDB this means + running checkpoint and copying the DB files and any active log files. - 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? From ieslick at common-lisp.net Sun Feb 18 10:58:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 05:58:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070218105858.B558A38010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv3903/src/db-bdb Modified Files: bdb-controller.lisp package.lisp Log Message: Provide checkpoint function --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/17 19:28:53 1.29 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/18 10:58:58 1.30 @@ -258,7 +258,20 @@ (defmethod stop-deadlock-detector ((ctrl bdb-store-controller)) (when (controller-deadlock-pid ctrl) (kill-background-program (controller-deadlock-pid ctrl)))) + +;; +;; Enable program-based checkpointing +;; +(defmethod checkpoint ((sc bdb-store-controller) &key force (time 0) (log-size 0)) + "Forces a checkpoint of the db and flushes the memory pool to disk. + Use keywords ':force t' to write the checkpoint under any + condition, ':time N' to checkpoint based on if the number of + minutes since the last checkpoint is greater than time and + ':log-size N' to checkpoint if the data written to the log is + greater than N kilobytes" + (db-env-txn-checkpoint (controller-environment sc) log-size time :force force)) + ;; ;; Take advantage of release 4.4's compact storage feature. Feature of BDB only ;; --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/16 23:02:51 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/18 10:58:58 1.7 @@ -45,4 +45,5 @@ (:import-from :ccl #:byte-length) (:export - #:optimize-layout)) + #:optimize-layout + #:checkpoint)) From ieslick at common-lisp.net Sun Feb 18 10:58:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 05:58:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070218105858.02A5838010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv3903/src/elephant Modified Files: transactions.lisp Log Message: Provide checkpoint function --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/17 19:28:53 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/18 10:58:58 1.10 @@ -147,7 +147,7 @@ ,@(remove-keywords '(:store-controller :parent :transaction :retries) keyargs)))))) -(defmacro with-batched-transaction ((batch size list &rest txn-options) &body body) +(defmacro with-batch-transaction ((batch size list &rest txn-options) &body body) "Perform a set of DB operations over a list of elements in batches of size 'size'. Pass specific transaction options after the list reference." `(loop for ,batch in (subsets ,size ,list) do From rread at common-lisp.net Sun Feb 18 21:08:16 2007 From: rread at common-lisp.net (rread) Date: Sun, 18 Feb 2007 16:08:16 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070218210816.78DDA49032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv13893 Modified Files: sql-controller.lisp Log Message: Fixing kevalue typo, and trying to make SQLite3 warnings less painful. --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/14 22:39:10 1.19 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/18 21:08:16 1.20 @@ -290,27 +290,38 @@ ;; the table, as long as we have the rights we need! (clsql:table-exists-p [version] :database con :owner :all) ) - +(defun sqlite3-harmless-read (sc) + (let ((con (controller-db sc))) + (if + (equal + (car (cadr (controller-spec sc))) + :sqlite3) + (handler-case + (clsql:query "select count(*) from keyvalue") + ((clsql-sys::sql-database-error () nil) + ) + ) + ) + )) (defun create-version-table (sc) (let ((con (controller-db sc))) (clsql::create-table [version] - '( - ([dbversion] text :not-null) - ) :database con - ) - (if (and (clsql:table-exists-p [keyvlaue] :database con :owner :all) - (= 0 (caar (clsql:query "select count(*) from keyvalue")))) - (clsql::insert-records :into [version] - :attributes '(dbversion) - :values (list (format nil "~A" *elephant-code-version*)) - :database con) - (clsql::insert-records :into [version] - :attributes '(dbversion) - :values (list (format nil "~A" '(0 6 0))) - :database con) - ) - ) - ) + '( + ([dbversion] text :not-null) + ) :database con + ) + (sqlite3-harmless-read sc) + (let ((version + (if (clsql:table-exists-p [keyvlaue] :database con :owner :all) + (if (= 0 (caar (clsql:query "select count(*) from keyvalue"))) + *elephant-code-version* + '(0 6 0)) + *elephant-code-version*))) + (clsql::insert-records :into [version] + :attributes '(dbversion) + :values (list (format nil "~A" version)) + :database con) + ))) ;; These functions are probably not cross-database portable... (defun keyvalue-table-exists (con) @@ -358,6 +369,7 @@ (if (supports-sequence sc) (progn (clsql::create-sequence [serial] :database con) + (sqlite3-harmless-read sc) (clsql::query (format nil "create table keyvalue ( pk integer PRIMARY KEY DEFAULT nextval('serial'), @@ -376,7 +388,7 @@ ) :database con) ) - + (sqlite3-harmless-read sc) ;; :constraints '("PRIMARY KEY (clctn_id key)" ;; "UNIQUE (clctn_id,key)") @@ -402,6 +414,7 @@ (clsql:create-index [idx_both] :on [keyvalue] :attributes '([clctn_id] [key]) :database con) + (sqlite3-harmless-read sc) ;;) )) @@ -420,7 +433,6 @@ (read-from-string (caar tuples)) nil)))) - (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key From ieslick at common-lisp.net Sun Feb 18 22:09:01 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 17:09:01 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070218220901.CF59C38010@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv26211 Modified Files: sql-controller.lisp Log Message: Fixed two typos --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/18 21:08:16 1.20 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/02/18 22:09:01 1.21 @@ -312,7 +312,7 @@ ) (sqlite3-harmless-read sc) (let ((version - (if (clsql:table-exists-p [keyvlaue] :database con :owner :all) + (if (clsql:table-exists-p [keyvalue] :database con :owner :all) (if (= 0 (caar (clsql:query "select count(*) from keyvalue"))) *elephant-code-version* '(0 6 0)) @@ -655,7 +655,7 @@ ) ) ) - (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q :sc sc)) x)) + (mapcar #'(lambda (x) (mapcar #'(lambda (q) (deserialize-from-base64-string q sc)) x)) tuples))) (defun sql-from-root-existsp (key sc) From ieslick at common-lisp.net Sun Feb 18 22:45:39 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 17:45:39 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070218224539.BC99E4E00F@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv392 Modified Files: elephant.asd Log Message: Fixed typo (again:) that Henrik pointed out --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/16 03:43:47 1.30 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/18 22:45:39 1.31 @@ -110,7 +110,7 @@ #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" #+(and X86-64 (or macosx darwin darwin-host)) "-arch x86_64" - #+(and X86-64 linux) "-march x86-64" + #+(and X86-64 linux) "-march=x86-64" "-Wall" "-fPIC" "-O3" From ieslick at common-lisp.net Sun Feb 18 23:38:18 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Feb 2007 18:38:18 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070218233818.7B1F61A007@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9012 Modified Files: classes.lisp classindex-utils.lisp classindex.lisp Log Message: Fix reconnect to derived index bug under :class synchronization policy --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/14 04:36:10 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/18 23:38:18 1.14 @@ -130,14 +130,14 @@ (let* ((class (find-class (class-name (class-of instance)))) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) - (flet ((persistent-slot-p (item) + (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits - (if (eq slot-names t) + (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/02 23:51:58 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/18 23:38:18 1.5 @@ -12,6 +12,8 @@ (in-package :elephant) +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) + ;; ;; Simple utilities for managing synchronization between class ;; definitions and database state @@ -226,7 +228,6 @@ (simple-match-set (synch-rule-lhs rule) features)) (defun simple-match-set (a b) - (declare (optimize (speed 3) (safety 1))) (cond ((null a) t) ((and (not (null a)) (null b)) nil) ((member (first a) b :test #'equal) @@ -252,7 +253,6 @@ (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) (defun apply-synch-rules (class records rule-set) - (declare (optimize (speed 3) (safety 1))) (labels ((slotname (rec) (car rec)) (feature-set (rec) (cdr rec))) (loop for record in records do @@ -267,8 +267,7 @@ (let* ((*store-controller* store-controller) ;; db info (db-indices (find-inverted-index-names class)) - (db-derived (mapcar #'get-derived-name-root - (remove-if-not #'derived-name? db-indices))) + (db-derived (remove-if-not #'derived-name? db-indices)) (db-slot (set-difference db-indices db-derived)) ;; class info (marked-slots (indexing-record-slots (indexed-record class))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/14 04:36:10 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18 @@ -266,7 +266,8 @@ (defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) (remove-class-slot-index (find-class class) slot-name :sc sc)) -(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) +(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key + (sc *store-controller*) (update-class t)) ;; NOTE: Write routines to recover BDB storage when you've wiped an index... ;; NOTE: If the transaction aborts we should not update class slots? (if (find-inverted-index class slot-name :null-on-fail t) @@ -282,7 +283,8 @@ (defmethod add-class-derived-index ((class symbol) name derived-defun &key (sc *store-controller*) (populate t)) (add-class-derived-index (find-class class) name derived-defun :sc sc :populate populate)) -(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key (populate t) (sc *store-controller*) (update-class t)) +(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key + (populate t) (sc *store-controller*) (update-class t)) (let ((class-idx (find-class-index class :sc sc))) (if (find-inverted-index class (make-derived-name name) :null-on-fail t) (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) @@ -297,7 +299,8 @@ (defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) (remove-class-derived-index (find-class class) name :sc sc)) -(defmethod remove-class-derived-index ((class persistent-metaclass) name &key (sc *store-controller*) (update-class t)) +(defmethod remove-class-derived-index ((class persistent-metaclass) name &key + (sc *store-controller*) (update-class t)) (if (find-inverted-index class name :null-on-fail t) (progn (when update-class (unregister-derived-index class name)) From ieslick at common-lisp.net Tue Feb 20 02:34:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 19 Feb 2007 21:34:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070220023400.44333310C1@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv7106a/db-clsql Modified Files: sql-transaction.lisp Log Message: Enable with-transaction to return multiple values in both backends --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2007/02/02 23:51:58 1.4 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2007/02/20 02:33:59 1.5 @@ -31,10 +31,17 @@ (funcall txn-fn) (progn (clsql::set-autocommit nil) - (unwind-protect - (clsql::with-transaction (:database (controller-db sc)) - (funcall txn-fn)) - (clsql::set-autocommit t))))) + (let ((db (controller-db sc))) + (unwind-protect + (multiple-value-prog1 + (progn + (clsql-sys::database-start-transaction db) + (funcall txn-fn)) + (clsql-sys::mark-transaction-committed db)) + (if (eq (clsql-sys::transaction-status (clsql-sys::transaction db)) :committed) + (clsql-sys::database-commit-transaction db) + (clsql-sys::database-abort-transaction db)) + (clsql::set-autocommit t)))))) (defmethod controller-start-transaction ((sc sql-store-controller) &key &allow-other-keys) (clsql:start-transaction :database (controller-db sc)) From ieslick at common-lisp.net Tue Feb 20 02:33:59 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 19 Feb 2007 21:33:59 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070220023359.DEE8B310C0@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv7106a/db-bdb Modified Files: bdb-transactions.lisp Log Message: Enable with-transaction to return multiple values in both backends --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/16 23:02:51 1.8 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 02:33:59 1.9 @@ -45,7 +45,7 @@ (declare (special *current-transaction* *store-controller*)) (catch 'transaction (unwind-protect - (prog1 + (multiple-value-prog1 (funcall txn-fn) (db-transaction-commit txn :txn-nosync txn-nosync :txn-sync txn-sync) From ieslick at common-lisp.net Tue Feb 20 15:48:14 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 10:48:14 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070220154814.DC41B2F054@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv1677 Modified Files: testbdb.lisp Log Message: Fix idempotence problem in prepares-bdb --- /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/03 00:57:35 1.4 +++ /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/20 15:48:14 1.5 @@ -18,6 +18,11 @@ (defvar db) (defun prepare-bdb () + (ignore-errors + (delete-file (make-pathname :defaults (cdr *bdb-spec*) + :name "testsbdb")) + (delete-file (make-pathname :defaults (cdr *bdb-spec*) + :name "log.0000000001"))) (setq env (db-bdb::db-env-create)) (db-bdb::db-env-open env (cdr *bdb-spec*) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread t From rread at common-lisp.net Tue Feb 20 15:54:21 2007 From: rread at common-lisp.net (rread) Date: Tue, 20 Feb 2007 10:54:21 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/contrib/rread/dcm Message-ID: <20070220155421.CB5483E053@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm In directory clnet:/tmp/cvs-serv2139 Modified Files: dcm-macros.lisp dcm-package.lisp dcm-tests.lisp dcm.asd dcm.lisp gdcm.lisp Log Message: Latest version of DCM --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2007/02/20 15:54:21 1.2 @@ -1,22 +1,7 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; dcm-macros -;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read - (in-package "DCM") +(use-package "SB-THREAD") + (defmacro init-director (cls dirclass &rest x) `(let ((dir (make-instance ,cls , at x))) (initialize dir ,cls ,dirclass) @@ -31,3 +16,30 @@ ;; (load-all dir) dir)) +(defvar *dcm-mutexes* (make-hash-table :test 'equal)) + +(defvar *a-mutex* (sb-thread::make-mutex :name "my lock")) + +(defun insure-mutex (name) + (let ((mtx (gethash name *dcm-mutexes*)) + ) + (or mtx (setf (gethash name *dcm-mutexes*) (sb-thread:make-mutex :name name))) + ) + ) + +;; This assumes that the the variable "dir" is being defined and that we can can +;; create +(defmacro defmethodex (mname dir args &body body) + `(defmethod ,mname ,(cons dir args) +;; (format t "Thread ~A running ~%" sb-thread::*current-thread*) + (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" ,(car dir)))) +;; (format t "Thread ~A got the lock~%" sb-thread::*current-thread*) + (let ((ret + , at body)) +;; (format t "Thread ~A dropping lock~%" sb-thread::*current-thread*) + ret + ) + ) + ) + ) + --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2007/02/20 15:54:21 1.2 @@ -1,19 +1,9 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; dcm-package.lisp +;;; dcm-package.asd -- package definition for DCM ;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read +;;; Copyright (c) 2005 Robert L. Read +;;; All rights reserverd. (defpackage dcm (:documentation @@ -31,6 +21,7 @@ #:*DEF-STORE-NAME* #:key + #:mtype #:key-equal #:dcm-equal #:max-key-value @@ -98,6 +89,7 @@ #:get-all-cur-objects #:get-all-objects-gen #:retire + #:promote #:find-generation #:GenDir ) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2007/02/20 15:54:21 1.2 @@ -1,23 +1,23 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; dcm-tests.lisp -;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read - (in-package "DCM") - +(defclass UserObject (managed-object) + ((username :type 'string :initform "" :initarg :uname :accessor :username) + (password :type 'string :initform "" :initarg :pword :accessor :password) + (email :type 'string :initform "" :initarg :email :accessor :eml) + (fullname :type 'string :initform "" :initarg :fullname :accessor :fllnm) + (profile :type 'string :initform "" :initarg :profile :accessor :prfl) + (motto :type 'string :initform "" :initarg :motto :accessor :mtt) + (privileges :type 'list :initform '() :initarg :privileges :accessor :prvlgs) + (preflang :type 'string :initform "en" :initarg :preflang :accessor :prflng) +;; For now, this will just be a nice big association list, and +;; the only prefs I have right now are gridconfigurations + (prefs :type 'list :initform '() :initarg :prefs :accessor :prfs) +;; These controls the markets that a user is a allowed to read or create an offer in +;; (keys identifying markets are stored here.) +;; We DO NOT give privilege to the public market; We don't want to +;; store more than necessary. If a market is public, it is not represented here +;; (in the read list!) +)) (defclass ExObjectDirector (hash-ele-director) ((mtype :initform 'ExObject @@ -99,6 +99,15 @@ ((null dirs)) (setf s (+ s (length (get-all-objects (car dirs)))))) (assert (= s 1)))) + +(defun many-threads () + (let ( + (ed (init-director 'ExObjectDirector 'ExObjectDirector)) + ) + (dotimes (x 100) + (sb-thread:make-thread + #'(lambda () (format t "YYY~A~%" (get-unused-key-value ed))))) +)) ;; This command should test everything so far.... @@ -108,4 +117,5 @@ (tm-register-then-lookup dt) (tm-get-all-objects dt) (tm-test-elephant dt) + (many-threads) )) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 15:27:36 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2007/02/20 15:54:21 1.3 @@ -2,25 +2,14 @@ ;;; ;;; dcm.asd -- ASDF system definition for DCM ;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read - +;;; Copyright (c) 2005 Robert L. Read +;;; All rights reserverd. (defsystem dcm :name "dcm" :author "Robert L. Read " :version "0.1" :maintainer "Robert L. Read + +;; It seems silly to have to do this, but I suspect it +;; will make the inheritance work better. +;; An open question is do we want to have to subclass keys +;; or not; certainly a common error is to pass in the +;; wrong key. + +;; I'm currently not sure how to load this file properly +;; and how to run ALL the test with a single command. + +;; Note: as of Jun. 12, 2006, I am trying to make this thread safe. +;; according to my understanding and experiments there are two +;; problems: SBCL itself is not threadsafe (hash tables are mentioned +;; in particular) although it is probably improving with every release. +;; By my experiments, I have specifically duplicated a terrible, unrecoverable +;; hang in the CLSQL connection both through elephant and with direct queries. +;; +;; Therefore, since everything I personally do is built on top +;; of DCM, I am imposing thread-safety at the DCM level (even though in +;; the best case this probably does not allow as much concurrency as one might like.) +;; (in-package "DCM") @@ -23,10 +30,12 @@ (defparameter *ELEPHANT-CAT* "elephant director") (defparameter *DEF-STORE-NAME* "DefaultStoreX") + (asdf:operate 'asdf:load-op :elephant) (use-package "ELEPHANT") ;; (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :ele-clsql) +(use-package "SB-THREAD") (defclass key () ((id :type 'integer @@ -80,13 +89,17 @@ (k (mid a)) (if (typep a 'key) (k a) - a))) + (if (typep a 'string) + (parse-integer a) + a)))) (kb (if (typep b 'managed-object) (k (mid b)) (if (typep b 'key) (k b) - b)))) + (if (typep a 'string) + (parse-integer a) + b))))) (and ka kb (= ka kb)) ) @@ -188,7 +201,10 @@ (defgeneric register-obj (director managed-object) ) -(defgeneric lookup-obj (director key) +(defgeneric lookup-obj (director obj) + + ) +(defgeneric lookup-obj-key (director key) ) (defgeneric delete-obj (director key) @@ -197,6 +213,18 @@ (defgeneric get-all-objects (director) ) +(defmethod lookup-obj ((dir director) (id key)) + (lookup-obj-key dir id) +) + +(defmethod lookup-obj ((dir director) (id integer)) + (lookup-obj-key dir (make-instance 'key :id id)) +) + +(defmethod lookup-obj ((dir director) (id string)) + (lookup-obj-key dir (make-instance 'key :id (parse-integer id))) +) + (defmethod get-all-cur-objects ((dir director)) (get-all-objects dir)) @@ -213,6 +241,14 @@ (delete-obj dir (mid mo))) (get-all-objects dir))) + +;; (defmethodex delete-all-objects-from-director (dir director) (tp) +;; (mapc +;; #'(lambda (mo) +;; (delete-obj dir (mid mo))) +;; (get-all-objects dir))) + + ;; Create a hash-based subclass (defparameter *HASH-CAT* "hash director") @@ -227,7 +263,9 @@ (defmethod get-all-objects ((dir hash-director)) (get-all-objects-type dir 'managed-object)) -(defmethod get-all-objects-type ((dir hash-director) tp) + +(defmethodex get-all-objects-type (dir hash-director) (tp) + ;; (defmethod get-all-objects-type ((dir hash-director) tp) (let ((objs '())) (maphash #'(lambda (k v) (if (typep v tp) @@ -235,7 +273,8 @@ (slot-value dir 'key-to-mo)) objs)) -(defmethod get-all-objects-owned-by ((dir hash-director) (o key)) +(defmethodex get-all-objects-owned-by (dir hash-director) ((o key)) + ;; (defmethod get-all-objects-owned-by ((dir hash-director) (o key)) (let ((objs '())) (maphash #'(lambda (key v) (if (equal (k (:ownr v)) (k o)) @@ -248,7 +287,10 @@ ;; There does not appear to be a "hash-reduce". ;; That would be an elegant function to have for ;; this and other purposes. -(defmethod get-unused-key-value ((dir hash-director)) +(defmethodex get-unused-key-value (dir hash-director) () + (get-unused-key-value-naked dir)) + +(defmethod get-unused-key-value-naked ((dir hash-director)) (the integer (+ 1 (hash-keys-reduce #'max (slot-value dir 'key-to-mo) @@ -280,14 +322,17 @@ (setf r (funcall fun r key))))) r)) -(defmethod register-obj ((dir hash-director) (mo managed-object)) - (unless (mid mo) - (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir)))) + +(defmethodex register-obj (dir hash-director) ((mo managed-object)) + (progn + (unless (mid mo) + (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir)))) (with-slots (key-to-mo) dir - (setf (gethash (k (mid mo)) key-to-mo) mo))) + (setf (gethash (k (mid mo)) key-to-mo) mo)))) -(defmethod lookup-obj ((dir hash-director) (id key)) +;; (defmethodex lookup-obj-key (dir hash-director) ((id key)) +(defmethod lookup-obj-key ((dir hash-director) (id key)) (with-slots (key-to-mo) dir (gethash (k id) key-to-mo))) @@ -295,7 +340,8 @@ ;; I would really like to insist on create-read-update-delete functions ;; for the abstract class of director. -(defmethod delete-obj ((dir hash-director) (id key)) +(defmethodex delete-obj (dir hash-director) ((id key)) + ;; (defmethod delete-obj ((dir hash-director) (id key)) (with-slots (key-to-mo) dir (remhash (k id) key-to-mo))) @@ -310,14 +356,16 @@ ;; These functions will have to be expanded later to include ;; multiple controllers. It would be really nice if I could tie ;; this to garabase collection instead. -(defvar *basic-store-controller* (open-store *DCM-DEFAULT*)) +;; (defvar *basic-store-controller* (open-store *DCM-DEFAULT*)) +(defvar *basic-store-controller* nil) (defun reconnect-db () (reconnect-controller *basic-store-controller*)) (defun init-elephant-controllers (dcm-default) - (setq *basic-store-controller* (open-store dcm-default))) + (setq *basic-store-controller* (open-store dcm-default)) + (setq elephant::*store-controller* *basic-store-controller*)) (defun release-elephant-controllers () (close-controller *basic-store-controller*)) @@ -346,6 +394,7 @@ (let* ((name (format nil "DCM-SPECIAL-~A" c)) (sc (slot-value dir 'root)) (bt (get-from-root name :store-controller sc))) + (format t "bt of name ~A is: ~A~%" name bt) (unless bt (setf bt (add-to-root name (make-btree sc) :store-controller sc))) (setf (slot-value dir 'dcm-btree) bt)) @@ -359,11 +408,13 @@ ;; and in fact, pushing this into Elephant), would be an ;; excellent idea. ;; (defun empty-out-corrupted-btree (c sc) -;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c))) -;; (bt (get-from-root name :store-controller sc))) -;; ; "delete from keyvalue where clct_id = ") -;; )) -(defmethod register-many-random ((dir director) n) +;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c))) +;; (bt (get-from-root name :store-controller sc))) +;; "delete from keyvalue where clct_id = ") +;; ) + +(defmethodex register-many-random (dir director) (n) + ;; (defmethod register-many-random ((dir director) n) (with-slots (mtype) dir @@ -374,15 +425,30 @@ (make-instance mtype)))))) ;; I'm goint to try using the ele::next-oid fuction here: -(defmethod get-unused-key-value ((dir elephant-director)) +(defmethodex get-unused-key-value (dir elephant-director) () + (get-unused-key-value-naked dir)) + +(defmethod get-unused-key-value-naked ((dir elephant-director)) (the integer (with-slots (root) dir (ELEPHANT::next-oid root)))) +;; (defmethodex get-all-objects (dir elephant-director) () (defmethod get-all-objects ((dir elephant-director)) (get-all-objects-type dir 'managed-object)) -(defmethod get-all-objects-type ((dir elephant-director) tp) +(defmethodex get-all-objects-type (dir elephant-director) (tp) + ;; (defmethod get-all-objects-type ((dir elephant-director) tp) + (with-slots (dcm-btree) dir + (let ((objs '())) + (map-btree #'(lambda (k x) + (declare (ignore k)) + (if (typep x (:mtype dir)) + (push x objs))) + dcm-btree) + objs))) + +(defmethod get-all-objects-type-xxxx ((dir elephant-director) tp) (with-slots (dcm-btree) dir (let ((objs '())) (map-btree #'(lambda (k x) @@ -392,7 +458,8 @@ dcm-btree) objs))) -(defmethod get-all-objects-owned-by ((dir elephant-director) (o key)) +(defmethodex get-all-objects-owned-by (dir elephant-director) ((o key)) + ;; (defmethod get-all-objects-owned-by ((dir elephant-director) (o key)) (with-slots (dcm-btree) dir (let ((objs '())) (map-btree #'(lambda (k x) @@ -414,18 +481,23 @@ x) :accessor :elefdir))) -(defmethod register-obj ((dir elephant-director) (mo managed-object)) +(defmethodex register-obj (dir elephant-director) ((mo managed-object)) + ;; (defmethod register-obj ((dir elephant-director) (mo managed-object)) + (progn (unless (mid mo) - (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir)))) + (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir)))) + ;; (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" dir))) (with-slots (dcm-btree) dir (progn - (setf (get-value (mid mo) dcm-btree) mo)))) + (setf (get-value (mid mo) dcm-btree) mo))))) -(defmethod lookup-obj ((dir elephant-director) (id key)) +(defmethodex lookup-obj-key (dir elephant-director) ((id key)) + ;; (defmethod lookup-obj-key ((dir elephant-director) (id key)) (with-slots (dcm-btree) dir (get-value id dcm-btree))) -(defmethod delete-obj ((dir elephant-director) (id key)) +(defmethodex delete-obj (dir elephant-director) ((id key)) + ;; (defmethod delete-obj ((dir elephant-director) (id key)) (with-slots (dcm-btree) dir (remove-kv id dcm-btree))) @@ -449,11 +521,11 @@ ((hed :initform (make-instance 'hash-ele-director) :accessor :hed))) -(defmethod load-all ((dir hash-ele-director)) - (let ((obs (get-all-objects (:ed dir)))) - (mapc #'(lambda (x) (register-obj (:hd dir) x)) - obs) - )) +(defmethodex load-all (dir hash-ele-director) () + (let ((obs (get-all-objects (:ed dir)))) + (mapc #'(lambda (x) (register-obj (:hd dir) x)) + obs) + )) (defmethod register-obj ((dir hash-ele-director) (mo managed-object)) (register-obj (:ed dir) mo) @@ -465,8 +537,8 @@ (get-unused-key-value (:ed dir)))) -(defmethod lookup-obj ((dir hash-ele-director) (id key)) - (lookup-obj (:hd dir) id)) +(defmethod lookup-obj-key ((dir hash-ele-director) (id key)) + (lookup-obj-key (:hd dir) id)) (defmethod delete-obj ((dir hash-ele-director) (id key)) (delete-obj (:hd dir) id) @@ -487,7 +559,7 @@ (defparameter *DIR-STRATEGIES* '(hash hash-ele elephant simple)) -o ;; I might have to rehabilitate this function... +;; I might have to rehabilitate this function... (defun directory-factory (strategy btreeclassname type repos) (case strategy (hash (init-director 'hash-director btreeclassname :managed-type type)) @@ -538,7 +610,7 @@ (let ((mo (make-instance 'managed-object))) (register-obj dir mo) (assert (key-equal (mid mo) - (mid (lookup-obj dir (mid mo)))))))) + (mid (lookup-obj-key dir (mid mo)))))))) dirs)) ) @@ -580,7 +652,7 @@ (time (and (mapcar #'(lambda (k) - (not (lookup-obj dir (make-instance 'key :id k)))) + (not (lookup-obj-key dir (make-instance 'key :id k)))) key-values))))) ) dirs)) @@ -624,7 +696,7 @@ (time (and (mapcar #'(lambda (k) - (not (lookup-obj dir (make-instance 'key :id k)))) + (not (lookup-obj-key dir (make-instance 'key :id k)))) key-values))))) )))) dirs)) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2007/02/20 15:54:21 1.2 @@ -1,35 +1,20 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; gdcm.lisp -- This file implements generational data collection management -;;; based on the basic data collection management functionality. -;;; The basic idea is that every object in the collection exists -;;; within a generation. Each generation can have a different storage -;;; strategy --- in general, the lower the generation number, the -;;; faster and smaller the storage strategy. -;;; Increasing the generation is a fundamental operation. - -;;; One fundamental feature of a GenDir is that the -;;; objects managed retain their identities across these issue. - -;;; A GenDir is a kind of director, but it offers generational -;;; aware operations that it's superclass does not. - -;;; Given an object with it's id, how do you efficiently find -;;; its generation? --- you always have an index, so in theory -;;; it can't take that long to find what generation it's in. - -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read +;; gdcm.lisp -- This file implements generational data collection management +;; based on the basic data collection management functionality. +;; The basic idea is that every object in the collection exists +;; within a generation. Each generation can have a different storage +;; strategy --- in general, the lower the generation number, the +;; faster and smaller the storage strategy. +;; Increasing the generation is a fundamental operation. + +;; One fundamental feature of a GenDir is that the +;; objects managed retain their identities across these issue. + +;; A GenDir is a kind of director, but it offers generational +;; aware operations that it's superclass does not. + +;; Given an object with it's id, how do you efficiently find +;; its generation? --- you always have an index, so in theory +;; it can't take that long to find what generation it's in. (in-package "DCM") @@ -40,7 +25,7 @@ (defclass GenDir (director) ((strategy - :initform '((0 . hash-ele)) ;; This means that 0 and anything less is hash-ele + :initform '((0 . hash-ele) (1 . elephant)) ;; This means that 0 and anything less is hash-ele :accessor strategy) (final-strategy :initform 'elephant :accessor final-strategy) @@ -58,6 +43,11 @@ "Increment the generation number of a object, making number is properly stored there.") ) +(defgeneric promote (GenDir key) + (:documentation + "Decrement the generation number of a object, making number is properly stored there.") +) + (defgeneric find-generation (GenDir key) ) @@ -77,6 +67,20 @@ ) ) +(defmethod promote ((gdcm GenDir) (mid key)) + (multiple-value-bind (obj gen) + (lookup-obj-aux gdcm mid) + (unless (= gen 0) + (let ((ndir (nth (- gen 1) (subdirs gdcm))) + (odir (nth gen (subdirs gdcm))) + ) + (register-obj ndir obj) + (delete-obj odir mid) + ) + ) + ) + ) + (defmethod load-all ((dir GenDir)) (do ((i 0 (1+ i)) (dirs (subdirs dir) (rest dirs))) @@ -124,7 +128,7 @@ (delete-obj (nth gen (subdirs dir)) id)) ) ) -(defmethod lookup-obj ((dir GenDir) (mid key)) +(defmethod lookup-obj-key ((dir GenDir) (mid key)) (multiple-value-bind (obj gen) (lookup-obj-aux dir mid) obj) From ieslick at common-lisp.net Tue Feb 20 19:12:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 14:12:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070220191258.0D5DE3201F@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv13701 Modified Files: TODO elephant.asd Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/TODO 2007/02/18 10:58:58 1.54 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/20 19:12:57 1.55 @@ -6,15 +6,13 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -TASKS TO GET TO ALPHA: +TASKS TO GET TO BETA: Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) -TASKS TO GET TO BETA: - -BDB Features/Cleanup: -- Derived indices used to fail on re-connect, verify that this is fixed +Ian todo: +- Apply Robert's package translation changes Lisp Support: - Win32 builds @@ -35,12 +33,15 @@ - Migration: Improve printing and informative messages Test coverage: +- Make tests idempotent, clean up interface to tests - 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 (Henrik's code) - 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 +- Map tests +- Class index sychronization tests TASKS TO GET TO FINAL RELEASE: @@ -58,7 +59,20 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- -February +POST ALPHA CHECKINS: + +Major Bugs: +x Derived indices fail to re-connect after reopening a database under :class synchronization policy (Ian) + +Minor Bugs: +x Enable with-transactions to properly process forms returning multiple values (Ian) +x Fixed typos in SQL backend (Ian/Robert/Henrik) +x Fixed build bug for linux (Henrik) +x Fixed error condition while opening SQLITE3 in SQL backend (Robert) +x Fixed idempotence problem in PREPARE-BDB test + +Feature tweaking: +x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) February 13-17th, 2007: x Allow checkpoint of BDB via db-bdb::checkpoint @@ -152,6 +166,8 @@ 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. +- Can we do automatic join cursors? +- Add lazy deserialize to map functions? Performance: - Implement unicode performance hacks for various lisps; validate UTF8 works everywhere @@ -167,15 +183,12 @@ - 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 (no love on first attempt) - (log these in Track) + (log these in Track; not part of 0.6.2) Features: - Backup function: allow users to specify a backup function to archive the database contents and checkpoint any active functions (how to lock out other threads?) In BDB this means running checkpoint and copying the DB files and any active log files. - - 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 - A wrapper around migration that emulates a stop-and-copy GC @@ -191,32 +204,53 @@ 0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------ + +Major features: + - Native Lisp Backend + - All in common-lisp + - Page-based architecture + - Cheap copy-on-write transaction policy w/ concurrent transaction commits + in non-conflicting transactions + - Fast in-memory operations / prevalence like features + - Make storage policy decisions on per-class (or per-instance) basis + - Concurrent mode + - Current default + - For backends that allow multiple processes to connect + - Full ACID functionality + - Single-threaded objects + - Cache values in instance slots for fast reads + - Writes update slots and write to disk as normal + - Violates consistency and isolation; users must enforce single operator + - Prevalence mode + - Standard object model (user enforced ACID properties) + - Read/write to normal slots + - Backup slot values on object creation and explicit synch calls on class or instances + - In-memory slot indexing, write-through disk class indexing + - NoSynch controller switch + - Violates durability + - Offline garbage collection (via migration) + - Class schemas + - Improve synchronization, support class and instance versioning + - POBJs encoded by OID/CID and CID's are cached in working memory + This way we can issue conditions if an object is out of date so the + user can determine how/if to upgrade the reference to the current schema + - From Ben's e-mail: + We are storing persistent objects incorrectly. They should be stored only as OIDs, + and we should have a separate OID->class table. This way change-class can be + handled correctly. This also non-trivially compresses storage in the + database as we only need to store oids rather than serialized class names. + [Ian comment: only problem with this is an extra access to oid table each time a + class is deserialized and overall storage is constant. Would make it easy to + invalidate objects though!] + - 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? + - Support a simple object query language + +Details: - Revisit duplicate sorting on primary key (artifact of btree index storage order) - - Full support for DCM or integration of DCM functionality - - Integrate prevalence-like in-memory database system for single image, - multiple-thread operation - - Richer set of policy decisions on per-class basis - - Concurrent mode (for backends that allow multiple processes to connect, current default) - - Single-user mode (cache values in instance slots for fast reads, write-through) - - Backing store mode (read/write to normal slots except on object creation or synch) - (in-memory slot indexing, on disk class) - (works for any backend) - - Backing-store mode - - Controller 'switches' - - NoSynch - allow transactions to be lost on failure but maintains consistency - instead of performance - - Upgrade overall functionality - - Solid garbage collection strategy - - 64-bit oids / 64-bit file sizes? - - class templates stored and cached - - (From Ben's e-mail) We are storing persistent objects incorrectly. They should be - stored only as OIDs, and we should have a separate OID->class table. This way - change-class can be handled correctly. This also non-trivially compresses storage - in the database as we only need to store oids rather than serialized class names. - [Ian comment: only problem with this is an extra access to oid table each time a - class is deserialized and overall storage is constant. Would make it easy to - invalidate objects though!] - - Usage model examples + - Usage model examples for new features + - 64-bit oids / 64-bit file sizes 0.7.1 - Elephant BDB/SQL/Lisp Production Release -------------------------------------------------- @@ -224,20 +258,19 @@ - Intent is for this to be a major, long-term supported release prior to work on the new backend (i.e. patches against this release for bugs rather than only available in latest development tree) + - Online GC for lisp backend? 0.8.0 - Supporting Tools Release -------------------------------------------------- - - Add special support (if any) for persistent graph structures & queries - (ala AllegroCache) - - Support for cheap persistent sets (medium? can do on SQL?) - - Native persistent hashes (easy for BDB; can do on SQL backends?) - - Persistent aggregates for better conceptual integration with lisp? - - pcons, parray, pstruct, etc - - Support a simple object query language over the database + - Richer query language and compiler - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful for long-lived repositories or if you've forgotten a variable name + - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) + - Support for cheap persistent sets (medium? can do on SQL?) + - Persistent aggregates for better conceptual integration with lisp? + - pcons, parray, pstruct, etc 1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------ --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/18 22:45:39 1.31 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/20 19:12:57 1.32 @@ -118,6 +118,31 @@ input-file "-lm")) +;;(defmethod compiler-options ((compiler (eql :gcc-cygwin)) (c elephant-c-source) &key input-file output-file) +;; (unless (and input-file output-file) +;; (error "Must specify both input and output files")) +;; (list +;; "-shared" +;; "-mno-cygwin" +;; "-mwindows" +;; "-std=c99" +;; input-file +;; "-o" output-file +;; "--export-symbols" +;; (namestring (make-pathname :defaults output-file :type "def")))) + +;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c +;;dlltool -z libmeutil.def --export-all-symbols -e exports.o -l libmemutil.lib libmemutil.o +;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll + +;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll + +;;And this is the script for libsleepycat.dll: +;; +;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c +;;dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o +;;gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll + (defmethod compiler-options ((compiler (eql :msvc)) (c elephant-c-source) &key input-file output-file) (error "MSVC compiler option not supported yet")) From ieslick at common-lisp.net Tue Feb 20 19:12:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 14:12:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20070220191258.9226C32020@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv13701/src/db-bdb Modified Files: bdb-collections.lisp bdb-transactions.lisp libberkeley-db.def Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/17 12:13:19 1.20 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/20 19:12:58 1.21 @@ -113,13 +113,16 @@ (symbolp index-name) (or (symbolp key-form) (listp key-form))) ;; Can it be that this fails? - (let ((ht (indices bt)) - (index (build-btree-index sc - :primary bt - :key-form key-form))) - (setf (gethash index-name (indices-cache bt)) index) - (setf (gethash index-name ht) index) - (setf (indices bt) ht) + (let ((index + (ensure-transaction (:store-controller sc) + (let ((ht (indices bt)) + (index (build-btree-index sc + :primary bt + :key-form key-form))) + (setf (gethash index-name (indices-cache bt)) index) + (setf (gethash index-name ht) index) + (setf (indices bt) ht) + index)))) (when populate (populate bt index)) index) (error "Invalid index initargs!")))) @@ -150,7 +153,7 @@ (if last-key (cursor-set cursor last-key) (cursor-first cursor)) - (loop for i from 0 upto 1000 + (loop for i from 0 upto 1000 while continue do (multiple-value-bind (valid? k v) (cursor-current cursor) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 02:33:59 1.9 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 19:12:58 1.10 @@ -47,7 +47,8 @@ (unwind-protect (multiple-value-prog1 (funcall txn-fn) - (db-transaction-commit txn :txn-nosync txn-nosync + (db-transaction-commit txn + :txn-nosync txn-nosync :txn-sync txn-sync) (setq success t)) (unless success --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/01/20 22:12:17 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/02/20 19:12:58 1.3 @@ -67,8 +67,11 @@ db_env_get_timeout db_env_set_lk_detect db_env_get_lk_detect + db_env_txn_checkpoint db_env_lock_detect + db_set_error_file db_associate + db_compact never_index db_fake_associate next_counter \ No newline at end of file From ieslick at common-lisp.net Tue Feb 20 19:12:59 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 14:12:59 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070220191259.2B32B32020@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv13701/src/elephant Modified Files: classindex.lisp collections.lisp package.lisp Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 19:12:58 1.19 @@ -345,35 +345,56 @@ (cursor-close ,var)))) -;; ========================= -;; User-level lisp API -;; ========================= +;; ==================================== +;; User level Mapping API +;; ==================================== + +(defun map-class (fn class) + "Perform a map operation across all instances of class. Takes a + function of one argument, the class instance" + (let* ((class (if (symbolp class) + (find-class class) + class)) + (class-idx (find-class-index class))) + (flet ((map-fn (k v) + (declare (ignore k)) + (funcall fn v))) + (declare (dynamic-extent map-fn)) + (map-btree #'map-fn class-idx)))) + +(defun map-instances (fn class index start end) + "If you want to map over a subset of instances, pick an index + and specify bounds for the traversal. Otherwise use map-class + for all instances" + (let* ((index (if (symbolp index) + (find-inverted-index class index) + index))) + (flet ((wrapper (key value pkey) + (declare (ignore key pkey)) + (funcall fn value))) + (declare (dynamic-extent wrapper)) + (map-index #'wrapper index :start start :end end)))) + + +;; =============================== +;; User-level LIST-oriented API +;; =============================== (defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) -;; map instances -;; iterate over instances - (defmethod get-instances-by-class ((class symbol)) (get-instances-by-class (find-class class))) (defmethod get-instances-by-class ((class persistent-metaclass)) - (let ((instances nil) - (cidx (find-class-index class))) - (with-btree-cursor (cur cidx) - (multiple-value-bind (exists? key val) (cursor-first cur) - (declare (ignore key)) - (when exists? - (push val instances) - (loop - (multiple-value-bind (exists? key val) (cursor-next cur) - (declare (ignore key)) - (if exists? - (push val instances) - (return-from get-instances-by-class instances))))))))) + (let ((instances nil)) + (flet ((accum (c) + (declare (dynamic-extent c)) + (push c instances))) + (map-class #'accum class) + (nreverse instances)))) (defmethod get-instances-by-value ((class symbol) slot-name value) (get-instances-by-value (find-class class) slot-name value)) @@ -381,17 +402,14 @@ (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) (declare (type (or string symbol) slot-name)) (let ((instances nil)) - (with-btree-cursor (cur (find-inverted-index class slot-name)) - (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) - (declare (ignore skey pkey)) - (when exists? - (push val instances) - (loop - (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) - (declare (ignorable skey pkey)) - (if exists? - (push val instances) - (return-from get-instances-by-value instances))))))))) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class slot-name) + :start value :end value)) + (nreverse instances))) (defmethod get-instance-by-value ((class symbol) slot-name value) (let ((list (get-instances-by-value (find-class class) slot-name value))) @@ -409,27 +427,16 @@ (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (declare (type fixnum start end) (type string idx-name)) - (with-inverted-cursor (cur class idx-name) - (labels ((next-range (instances) - (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) - (declare (ignore pkey)) - (if (and exists? (<= skey end)) - (next-in-range skey (cons val instances)) - (nreverse instances)))) - (next-in-range (key instances) - (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) - (declare (ignore pkey skey)) - (if exists? - (next-in-range key (cons val instances)) - (progn - (cursor-pset-range cur key) - (next-range instances)))))) - (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start) - (declare (ignore pkey)) - (if (and exists? (<= skey end)) - (next-in-range skey (cons val nil)) - nil))))) - + (let ((instances nil)) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class idx-name) + :start start :end end)) + (nreverse instances))) + (defun drop-instances (instances &key (sc *store-controller*)) (when instances (assert (consp instances)) @@ -440,5 +447,3 @@ (drop-pobject instance)) subset))))) - - --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/16 07:11:02 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 19:12:58 1.10 @@ -314,27 +314,71 @@ primary key.")) -;; -;; Some generic utility functions -;; +;; ======================================= +;; Generic Mapping Functions +;; ======================================= (defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." `(let ((,var (make-cursor ,bt))) - (unwind-protect - (progn , at body) - (cursor-close ,var)))) + (unwind-protect + (progn , at body) + (cursor-close ,var)))) (defmethod map-btree (fn (btree btree)) - "Like maphash. Default implementation - overridable" - (with-transaction (:store-controller (get-con btree)) + "Like maphash. Default implementation - overridable + Function of two arguments key and value" + (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) + (declare (dynamic-extent more k v)) (unless more (return nil)) (funcall fn k v)))))) +(defmethod map-index (fn (index btree-index) &rest args &key start end) + "Like map-btree, but takes a function of three arguments key, value and primary key + if you want to get at the primary key value, otherwise use map-btree" + (declare (dynamic-extent args)) + (let ((sc (get-con index))) + (ensure-transaction (:store-controller sc) + (with-btree-cursor (cur index) + (labels ((next-range () + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + (return-from map-index nil)))) + (next-in-range (key) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (if exists? + (progn + (funcall fn skey val pkey) + (next-in-range key)) + (progn + (cursor-pset-range cur key) + (next-range)))))) + (declare (dynamic-extent next-range next-in-range)) + (multiple-value-bind (exists? skey val pkey) + (if start + (cursor-pset-range cur start) + (cursor-pfirst cur)) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + nil))))))) + + + +;; =============================== +;; Some generic utility functions +;; =============================== + (defmethod empty-btree-p ((btree btree)) (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (cur btree) @@ -345,10 +389,9 @@ (eq k *elephant-properties-label*)) ;; has properties (not (cursor-next cur))) (t nil)))))) - -(defun print-btree-node (k v) - (format t "k ~A / v ~A~%" k v)) +(defun print-btree-entry (k v) + (format t "key: ~A / value: ~A~%" k v)) (defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil)) "Print the contents of a btree for easy inspection & debugging" @@ -361,13 +404,16 @@ (funcall print-fn k v)) bt))) -(defun btree-keys (bt) - (format t "BTREE keys for ~A~%" bt) - (map-btree #'(lambda (k v) - (format t "key ~A / value type ~A~%" k (type-of v))) - bt)) +(defun print-btree-key-and-type (k v) + (format t "key ~A / value type ~A~%" k (type-of v))) -(defun btree-differ (x y) +(defun btree-keys (bt &key (print-fn #'print-btree-key-and-type) (count nil)) + (format t "BTREE keys and types for ~A~%" bt) + (dump-btree bt :print-fn print-fn :count count)) + +(defmethod btree-differ-p ((x btree) (y btree)) + (assert (eq (get-con x) (get-con y))) + (ensure-transaction (:store-controller (get-con x)) (let ((cx1 (make-cursor x)) (cy1 (make-cursor y)) (done nil) @@ -402,4 +448,4 @@ (cursor-close cx1) (cursor-close cy1) rv - )) + ))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/16 07:11:02 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15 @@ -55,7 +55,7 @@ #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass - #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree + #:btree #:make-btree #:get-value #:remove-kv #:existp #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key @@ -69,7 +69,7 @@ #:int-byte-spec #:cursor #:secondary-cursor #:make-cursor - #:with-btree-cursor #:cursor-close #:cursor-init + #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup @@ -95,6 +95,21 @@ #:make-inverted-cursor #:make-class-cursor #:with-inverted-cursor #:with-class-cursor + ;; Primitive mapping API + #:with-btree-cursor + #:map-btree + #:map-index + + ;; BTREE Utilities + #:empty-btree-p + #:dump-btree + #:btree-keys + #:btree-differ-p + + ;; Class mapping API + #:map-class + #:map-instances + ;; Instance query API #:get-instances-by-class #:get-instance-by-value From ieslick at common-lisp.net Tue Feb 20 19:12:59 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 14:12:59 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070220191259.C3C3D34053@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv13701/tests Modified Files: MigrationTests.lisp testcollections.lisp testindexing.lisp Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/23 14:42:16 1.2 +++ /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2007/02/20 19:12:59 1.3 @@ -34,9 +34,9 @@ ;; use for the migration tests. ;; This this configuration for testing between BDB and SQL.... -(setq *test-path-primary* *testpg-spec*) +;;(setq *test-path-primary* *testpg-spec*) ;; (setq *test-path-primary* *testsqlite3-path*) -(setq *test-path-secondary* *testbdb-spec*) +;;(setq *test-path-secondary* *testbdb-spec*) ;; This this configuration for testing from one BDB repository to another... @@ -45,5 +45,5 @@ (setq *test-path-secondary* *testbdb-spec2*) (do-migration-tests *testbdb-spec* *testbdb-spec2*) -(do-migration-tests *testbdb-spec2* *testpg-spec*) +;;(do-migration-tests *testbdb-spec2* *testpg-spec*) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/04 10:08:28 1.16 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/20 19:12:59 1.17 @@ -312,6 +312,17 @@ (= (slot2 v) 600)))) t) +(deftest map-indexed-index + (let ((sum 0)) + (flet ((collector (key value pkey) + (incf sum (slot1 value)))) + (map-index #'collector index1 :start nil :end 10) + (map-index #'collector index1 :start 690 :end nil) + (map-index #'collector index1 :start 400 :end 410)) + sum) + 267299) + + (deftest rem-kv (with-transaction (:store-controller *store-controller*) (let ((ibt (make-indexed-btree *store-controller*))) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/08 22:33:35 1.26 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/20 19:12:59 1.27 @@ -428,6 +428,13 @@ (push val objects))))) objects))) +(defun normal-lookup () + (let ((normal-check nil)) + (dotimes (i *range-size*) + (push (length (normal-range-lookup *stress-count* *range-size*)) + normal-check)) + normal-check)) + (defun indexed-range-lookup (class count size) (let* ((start (/ count 2)) (end (1- (+ start size))) @@ -436,8 +443,13 @@ res )) - - +(defun index-lookup () + (let ((index-check nil)) + (dotimes (i *range-size*) + (push (length (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + index-check)) + index-check)) + (deftest indexing-timing (progn (make-stress-classes) @@ -458,18 +470,12 @@ (indexed-stress-setup *stress-count* 'stress-index :stress2 10)) (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (push (length (normal-range-lookup *stress-count* *range-size*)) - normal-check)) + (setf normal-check (normal-lookup)) (setf end (get-internal-run-time)) (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (push (length (indexed-range-lookup 'stress-index *stress-count* *range-size*)) - index-check)) + (setf index-check (index-lookup)) (setf end (get-internal-run-time)) (setf index-time (/ (- end start 0.0) internal-time-units-per-second)) (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%" From ieslick at common-lisp.net Tue Feb 20 20:03:45 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 15:03:45 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070220200345.5BDA32E1C9@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv26098/src/elephant Modified Files: classindex.lisp collections.lisp Log Message: Allow map-instances over string indices as well as numeric --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 19:12:58 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 20:03:45 1.20 @@ -425,7 +425,7 @@ (get-instances-by-range (find-class class) slot-name start end)) (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) - (declare (type fixnum start end) + (declare (type (or fixnum null) start end) (type string idx-name)) (let ((instances nil)) (declare (type list instances)) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 19:12:58 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 20:03:45 1.11 @@ -337,6 +337,12 @@ (unless more (return nil)) (funcall fn k v)))))) +(defun lisp-compare<= (a b) + (etypecase a + (number (<= a b)) + (string (string<= a b)) + (persistent (<= (oid a) (oid b))))) + (defmethod map-index (fn (index btree-index) &rest args &key start end) "Like map-btree, but takes a function of three arguments key, value and primary key if you want to get at the primary key value, otherwise use map-btree" @@ -347,7 +353,7 @@ (labels ((next-range () (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) (if (or (and exists? (not end)) - (and exists? (<= skey end))) + (and exists? (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) @@ -367,7 +373,7 @@ (cursor-pset-range cur start) (cursor-pfirst cur)) (if (or (and exists? (not end)) - (and exists? (<= skey end))) + (and exists? (lisp-compare<= skey end))) (progn (funcall fn skey val pkey) (next-in-range skey)) From ieslick at common-lisp.net Tue Feb 20 20:03:45 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 15:03:45 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070220200345.BABC62F054@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26098/tests Modified Files: testcollections.lisp Log Message: Allow map-instances over string indices as well as numeric --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/20 19:12:59 1.17 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/20 20:03:45 1.18 @@ -317,11 +317,13 @@ (flet ((collector (key value pkey) (incf sum (slot1 value)))) (map-index #'collector index1 :start nil :end 10) - (map-index #'collector index1 :start 690 :end nil) + (map-index #'collector index1 :start 990 :end nil) (map-index #'collector index1 :start 400 :end 410)) sum) - 267299) - + (+ 55 ;; sum 1-10 inclusive + 4455 ;; sum 690-700 inclusive + 10945 ;; sum 990 to 1000 inclusive + )) (deftest rem-kv (with-transaction (:store-controller *store-controller*) From ieslick at common-lisp.net Wed Feb 21 04:47:41 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 23:47:41 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070221044741.E7BDE7E0E1@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv4595 Modified Files: TODO Log Message: Fix to map-index test; a tweaked version of Robert's symbol/pakage conversion diff and misc changes to serializer --- /project/elephant/cvsroot/elephant/TODO 2007/02/20 19:12:57 1.55 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/21 04:47:41 1.56 @@ -11,9 +11,6 @@ Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) -Ian todo: -- Apply Robert's package translation changes - Lisp Support: - Win32 builds - Windows support for asdf-based library builds? Include 32-bit dll in release? @@ -63,6 +60,7 @@ Major Bugs: x Derived indices fail to re-connect after reopening a database under :class synchronization policy (Ian) +x Package translation to properly upgrade databases where packages were renamed (Robert) Minor Bugs: x Enable with-transactions to properly process forms returning multiple values (Ian) @@ -184,6 +182,11 @@ support additional lisps and to seriously clean up metaclasses.lisp and classes.lisp protocols (no love on first attempt) (log these in Track; not part of 0.6.2) + - Serious work to integrate a proper condition system and potential restarts + for various errors (especially recoverable ones) while accessing db data + - deserialize fubar / diagnose & return value + - missing package / add package/symbol translation + - others? Features: - Backup function: allow users to specify a backup function to archive the database contents From ieslick at common-lisp.net Wed Feb 21 04:47:47 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 23:47:47 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070221044747.6A3EE471E1@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv4595/src/elephant Modified Files: classindex.lisp controller.lisp package.lisp serializer1.lisp serializer2.lisp Log Message: Fix to map-index test; a tweaked version of Robert's symbol/pakage conversion diff and misc changes to serializer --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 20:03:45 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/21 04:47:42 1.21 @@ -164,13 +164,15 @@ (defmethod close-controller :before ((sc store-controller)) "Ensure the classes don't have stale references to closed stores!" (when (controller-class-root sc) - (with-transaction (:store-controller sc :txn-sync t :retries 2) - (map-btree (lambda (class-name index) - (declare (ignore index)) - (let ((class (find-class class-name nil))) - (when class - (setf (%index-cache class) nil)))) - (controller-class-root sc))))) + (handler-case + (with-transaction (:store-controller sc :txn-sync t :retries 2) + (map-btree (lambda (class-name index) + (declare (ignore index)) + (let ((class (find-class class-name nil))) + (when class + (setf (%index-cache class) nil)))) + (controller-class-root sc))) + (t (e) (warn "Unable to clear class index caches ~A" e))))) ;; ============================= --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/16 23:02:53 1.35 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/21 04:47:42 1.36 @@ -153,8 +153,7 @@ (let ((obj (get-cache oid (instance-cache sc)))) (if obj obj ;; Should get cached since make-instance calls cache-instance - (make-instance (handle-legacy-classes class-name nil) - :from-oid oid :sc sc)))) + (make-instance class-name :from-oid oid :sc sc)))) (defmethod flush-instance-cache ((sc store-controller)) "Reset the instance cache (flush object lookups). Useful @@ -253,30 +252,69 @@ ;; Handling package changes in legacy databases ;; -(defparameter *legacy-conversions-db* - '(;; 0.5.0 support +(defvar *always-convert* nil) + +(defparameter *legacy-symbol-conversions* + '(;; 0.5.0 support (("elephant" . "bdb-btree") . ("sleepycat" . "bdb-btree")) (("elephant" . "bdb-indexed-btree") . ("sleepycat" . "bdb-indexed-btree")) - (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")) - ;; 0.6.0 support - (("sleepycat" . "bdb-btree") . ("db-bdb" . "bdb-btree")) - (("sleepycat" . "bdb-indexed-btree") . ("db-bdb" . "bdb-indexed-btree")) - (("sleepycat" . "bdb-btree-index") . ("db-bdb" . "bdb-btree-index")))) - - -(defun handle-legacy-classes (name version) - (declare (ignore version)) - (let ((entry (assoc (symbol->string-pair name) *legacy-conversions-db* :test #'equal))) + (("elephant" . "bdb-btree-index") . ("sleepycat" . "bdb-btree-index")))) + +(defun add-symbol-conversion (old-name old-package new-name new-package old-version) + "Users can specify specific symbol conversions on upgrade prior to + migrating old databases" + (declare (ignore old-version)) + (push (cons (cons old-name old-package) (cons new-name new-package)) *legacy-symbol-conversions*)) + +(defun map-legacy-symbols (symbol-string package-string old-version) + (declare (ignore old-version)) + (let ((entry (assoc (cons (string-upcase symbol-string) (string-upcase package-string)) + *legacy-symbol-conversions* :test #'equal))) (if entry - (string-pair->symbol (cdr entry)) - name))) + (values t (cadr entry) (cddr entry)) + nil))) -(defun symbol->string-pair (name) - (cons (string-downcase (package-name (symbol-package name))) - (string-downcase (symbol-name name)))) -(defun string-pair->symbol (name) - (intern (string-upcase (cdr name)) (car name))) +(defparameter *legacy-package-conversions* + '(("ELEPHANT-CLSQL" . "DB-CLSQL") + ("SLEEPYCAT" . "DB-BDB"))) + +(defun add-package-conversion (old-package-string new-package-string old-version) + "Users can specify wholesale package name conversions on upgrade + prior to migrating old databases" + (declare (ignore old-version)) + (push (cons old-package-string new-package-string) *legacy-package-conversions*)) + +(defun map-legacy-package-names (package-string old-version) + (declare (ignore old-version)) + (let ((entry (assoc (string-upcase package-string) *legacy-package-conversions* :test #'equal))) + (if entry + (cdr entry) + package-string))) + +(defun map-legacy-names (symbol-name package-name old-version) + (multiple-value-bind (mapped? new-name new-package) + (map-legacy-symbols symbol-name package-name old-version) + (if mapped? + (values new-name new-package) + (values new-name (map-legacy-package-names package-name old-version))))) + +(defun translate-and-intern-symbol (symbol-name package-name db-version) + "Service for the serializer to translate any renamed packages or symbols + and then intern the decoded symbol." + (if package-name + (multiple-value-bind (sname pname) + (if (or *always-convert* (not (equal db-version *elephant-code-version*))) + (map-legacy-names symbol-name package-name db-version) + (values symbol-name package-name)) + (let ((package (find-package pname))) + (if package + (intern sname package) + (progn + (warn "Couldn't deserialize the package: ~A based on ~A~% + An uninterred symbol will be created" pname package-name) + (make-symbol sname))))) + (make-symbol symbol-name))) ;; ================================================================================ ;; --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/21 04:47:42 1.16 @@ -61,8 +61,9 @@ #:btree-index #:get-primary-key #:primary #:key-form #:key-fn - #:btree-differ - #:migrate #:*inhibit-slot-copy* + #:migrate #:*inhibit-slot-copy* + #:add-symbol-conversion #:add-package-conversion + #:*always-convert* #:lookup-persistent-symbol #:lookup-persistent-symbol-id --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/16 23:02:53 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/21 04:47:42 1.10 @@ -33,7 +33,9 @@ oid int-byte-spec array-type-from-byte - byte-from-array-type)) + byte-from-array-type + database-version + translate-and-intern-symbol)) (in-package :elephant-serializer1) @@ -345,24 +347,17 @@ ((= tag +ucs1-symbol+) (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) #+(or lispworks (and allegro ics)) ((= tag +ucs2-symbol+) (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) #+(and sbcl sb-unicode) ((= tag +ucs4-symbol+) (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) -;; (format t "ouput name = ~A~%" name) - (if maybe-package-name - (intern name (find-package maybe-package-name)) - (make-symbol name)))) + (translate-and-intern-symbol name maybe-package-name (database-version sc)))) ((= tag +ucs1-string+) (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) #+(or lispworks (and allegro ics)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/17 16:48:17 1.25 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/21 04:47:42 1.26 @@ -32,7 +32,9 @@ oid int-byte-spec array-type-from-byte - byte-from-array-type)) + byte-from-array-type + database-version + translate-and-intern-symbol)) (in-package :elephant-serializer2) @@ -164,7 +166,7 @@ ((%next-object-id () (incf lisp-obj-id)) (%serialize (frob) - (etypecase frob + (typecase frob (fixnum (if (< #.most-positive-fixnum +2^31+) ;; should be compiled away (progn @@ -306,10 +308,10 @@ (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) - ))) - (%serialize frob) - (release-circularity-hash circularity-hash) - bs))) + (t (format t "Can't serialize a object: ~A of type ~A~%" frob (type-of frob)))))) + (%serialize frob) + (release-circularity-hash circularity-hash) + bs))) (defun serialize-bignum (frob bs) "Serialize bignum to buffer stream" @@ -418,10 +420,7 @@ ((= tag +symbol+) (let ((name (%deserialize bs)) (package (%deserialize bs))) - (declare (dynamic-extent name package)) - (if package - (intern name (find-package package)) - (make-symbol name)))) + (translate-and-intern-symbol name package (database-version sc)))) ((= tag +persistent+) (get-cached-instance sc (buffer-read-fixnum32 bs) @@ -444,8 +443,7 @@ ((= tag +cons+) (let* ((id (buffer-read-fixnum bs)) (maybe-cons (lookup-id id))) - (declare (dynamic-extent id maybe-cons) - (type fixnum id)) + (declare (type fixnum id)) (if maybe-cons maybe-cons (let ((c (cons nil nil))) (add-object c) @@ -455,8 +453,7 @@ ((= tag +hash-table+) (let* ((id (buffer-read-fixnum bs)) (maybe-hash (lookup-id id))) - (declare (dynamic-extent id maybe-hash) - (type fixnum id)) + (declare (type fixnum id)) (if maybe-hash maybe-hash (let* ((test (%deserialize bs)) (rehash-size (%deserialize bs)) @@ -480,7 +477,7 @@ ;; now, depending on what typedesig is, we might ;; or might not need to specify the store controller here.. (let ((o - (or (ignore-errors + (or (handler-case (if (subtypep typedesig 'persistent) (make-instance typedesig :sc sc) ;; if the this type doesn't exist in our object @@ -490,7 +487,8 @@ ;; prefer an abort here, but I prefer surviving... (make-instance typedesig) ) - ) + (error (v) (format t "got typedesig error: ~A ~A ~%" v typedesig) + (list 'caught-error v typedesig))) (list 'uninstantiable-object-of-type typedesig) ) )) @@ -525,16 +523,13 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) - (t (error "deserialize fubar!"))) -;; (print-post-deserialize-tag value) -;; value) - ))) - (etypecase buf-str - (null (return-from deserialize nil)) - (buffer-stream - (let ((result (%deserialize buf-str))) - (release-circularity-vector circularity-vector) - result)))))) + (t (error (format nil "deserialize of object tagged with ~A failed" tag))))))) + (etypecase buf-str + (null (return-from deserialize nil)) + (buffer-stream + (let ((result (%deserialize buf-str))) + (release-circularity-vector circularity-vector) + result)))))) (defun deserialize-bignum (bs length positive) (declare (type buffer-stream bs) @@ -545,7 +540,7 @@ (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 allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) #+(or allegro sbcl cmu lispworks openmcl) (byte 32 (* 32 i)) with num integer = 0 do From ieslick at common-lisp.net Wed Feb 21 04:47:47 2007 From: ieslick at common-lisp.net (ieslick) Date: Tue, 20 Feb 2007 23:47:47 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070221044747.D567047081@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv4595/tests Modified Files: testcollections.lisp Log Message: Fix to map-index test; a tweaked version of Robert's symbol/pakage conversion diff and misc changes to serializer --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/20 20:03:45 1.18 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/21 04:47:47 1.19 @@ -320,10 +320,10 @@ (map-index #'collector index1 :start 990 :end nil) (map-index #'collector index1 :start 400 :end 410)) sum) - (+ 55 ;; sum 1-10 inclusive - 4455 ;; sum 690-700 inclusive - 10945 ;; sum 990 to 1000 inclusive - )) + #.(+ 49 ;; sum 4-10 inclusive (1-3 removed by here) + 4455 ;; sum 690-700 inclusive + 10945 ;; sum 990 to 1000 inclusive + )) (deftest rem-kv (with-transaction (:store-controller *store-controller*) From ieslick at common-lisp.net Wed Feb 21 06:29:32 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 21 Feb 2007 01:29:32 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070221062932.5965D7D163@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv26319/src/elephant Modified Files: classes.lisp classindex.lisp Log Message: Fix to slot-makunbound handling for indexed slots and a regression test to validate --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/18 23:38:18 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/21 06:29:31 1.15 @@ -263,11 +263,10 @@ (call-next-method))))) (defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) - "Deletes the slot from the database." - ;; NOTE: call remove-indexed-slot here instead? -;; (when (indexed slot-def) -;; (unregister-indexed-slot class (slot-definition-name slot-def))) - (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def))) + "Removes the slot value from the database." + (if (indexed class) + (indexed-slot-makunbound class instance slot-def) + (persistent-slot-makunbound (get-con instance) instance (slot-definition-name slot-def)))) ;; ====================================================== ;; Handling metaclass overrides of normal slot operation --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/21 04:47:42 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/21 06:29:31 1.22 @@ -76,14 +76,23 @@ (if (no-indexing-needed? class instance slot-def oid) (persistent-slot-writer con new-value instance slot-name) (let ((class-idx (find-class-index class))) -;; (format t "Indexing object: ~A oid: ~A~%" instance oid) (ensure-transaction (:store-controller con) ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement + (when (get-value oid class-idx) (remove-kv oid class-idx)) (persistent-slot-writer con new-value instance slot-name) (setf (get-value oid class-idx) instance)))))) +(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) + (let ((class-idx (find-class-index class)) + (oid (oid instance)) + (sc (get-con instance))) + (ensure-transaction (:store-controller sc) + (let ((obj (get-value oid class-idx))) + (remove-kv oid class-idx) + (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) + (setf (get-value oid class-idx) obj))))) (defun no-indexing-needed? (class instance slot-def oid) (declare (ignore instance)) From ieslick at common-lisp.net Wed Feb 21 06:29:31 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 21 Feb 2007 01:29:31 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070221062931.35F1D7D002@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv26319 Modified Files: TODO Log Message: Fix to slot-makunbound handling for indexed slots and a regression test to validate --- /project/elephant/cvsroot/elephant/TODO 2007/02/21 04:47:41 1.56 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/21 06:29:31 1.57 @@ -37,8 +37,7 @@ - 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 -- Map tests -- Class index sychronization tests +- Class / DB sychronization tests TASKS TO GET TO FINAL RELEASE: @@ -61,6 +60,8 @@ Major Bugs: x Derived indices fail to re-connect after reopening a database under :class synchronization policy (Ian) x Package translation to properly upgrade databases where packages were renamed (Robert) +x Fix a bug where slot-makunbound on a persistent object failed to remove secondary index references + for class and slot indices. Made a test to validate this. Minor Bugs: x Enable with-transactions to properly process forms returning multiple values (Ian) @@ -71,6 +72,9 @@ Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) +x Tests to validate new map interfaces on top of existing tests + +DEVELOPMENT CHECKINS: February 13-17th, 2007: x Allow checkpoint of BDB via db-bdb::checkpoint @@ -157,6 +161,10 @@ 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? +- If a class inherits an indexed slot, is it also indexed for that class? This means a + proliferation of indexes, or requires user to explicitly add an index as a derived slot. +- What if we want an index to index into a range of different subclasses or objects sharing + a generic function? (roll your own?) - 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? @@ -177,16 +185,18 @@ global remove/add in order to maintain consistency (Ian) Design: + - Move secondary index maintenance to backend; decison on how to call update fn's + Will make lisp backend cheaper due to ability to life tree manipulation ops - Use SWIG and CFFI to better track changes in defconstant? (too expensive to be useful) - 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 (no love on first attempt) - (log these in Track; not part of 0.6.2) - - Serious work to integrate a proper condition system and potential restarts + - Work to integrate a proper condition system and potential restarts for various errors (especially recoverable ones) while accessing db data - deserialize fubar / diagnose & return value - missing package / add package/symbol translation - others? + (log these in Track; not part of 0.6.2?) Features: - Backup function: allow users to specify a backup function to archive the database contents From ieslick at common-lisp.net Wed Feb 21 06:29:32 2007 From: ieslick at common-lisp.net (ieslick) Date: Wed, 21 Feb 2007 01:29:32 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070221062932.9E16F7D167@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv26319/tests Modified Files: testindexing.lisp Log Message: Fix to slot-makunbound handling for indexed slots and a regression test to validate --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/20 19:12:59 1.27 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/21 06:29:32 1.28 @@ -186,6 +186,28 @@ ) t t t) +(deftest indexing-slot-makunbound + (progn + (when (class-indexedp-by-name 'idx-unbound-del) + (disable-class-indexing 'idx-unbound-del :errorp nil) + (setf (find-class 'idx-five-del) nil)) + + (defclass idx-unbound-del () + ((slot1 :initarg :slot1 :initform 1 :accessor slot1 :index t)) + (:metaclass persistent-metaclass)) + + (with-transaction (:store-controller *store-controller*) + (make-instance 'idx-unbound-del :slot1 10)) + + (let ((orig-len (length (get-instances-by-class 'idx-unbound-del))) + (orig-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) + (slot-makunbound orig-obj 'name) + (let ((new-len (length (get-instances-by-class 'idx-unbound-del))) + (index-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) + (values orig-len new-len index-obj)))) + 1 1 nil) + + (deftest indexing-wipe-index (progn (when (class-indexedp-by-name 'idx-five-del ) From ieslick at common-lisp.net Thu Feb 22 20:19:57 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 22 Feb 2007 15:19:57 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070222201957.9730660035@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv5389 Modified Files: TODO config.sexp ele-bdb.asd elephant.asd Log Message: Bug fix in drop instances; preliminary cygwin build in asd fils --- /project/elephant/cvsroot/elephant/TODO 2007/02/21 06:29:31 1.57 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/22 20:19:57 1.58 @@ -11,26 +11,26 @@ Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) -Lisp Support: -- Win32 builds - - Windows support for asdf-based library builds? Include 32-bit dll in release? -- 64-bit lisp verification -- Validate OpenMCL 1.1 on Mac OS X -- Validate Lispworks -- Verify db_deadlock for other lisps (launch and kill background program I/F) - Stability and Performance: - Review and address all NOTE comments in the code - Review SBCL string serialization performance -- Improve SQL base-64 serializer performance? - Migration: Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Migration: Improve support for nested persistent objects inside standard objects, arrays, etc? - Migration: Improve scaling properties of migration so all objects do not need to be resident in memory? - Migration: Validate that graph structures with loop are copied properly - Migration: Improve printing and informative messages +Lisp Support: +- Win32 builds + - Windows support for asdf-based library builds? Include 32-bit dll in release? +- Validate Lispworks +- Validate OpenMCL pre-1.1 on Mac OS X +- Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? +- Verify db_deadlock for other lisps (launch and kill background program I/F) +- 64-bit lisp verification + Test coverage: -- Make tests idempotent, clean up interface to tests +- Clean up interface to tests - 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 (Henrik's code) @@ -41,16 +41,19 @@ TASKS TO GET TO FINAL RELEASE: -Fix any bugs in BETA: +Fix any bugs found in BETA Documentation: - License and copyright file headers -- Add document section about backend interface: -- Add notes about with/ensure-transaction usage (abort & commit behavior on exit) -- Add notes about optimize-storage -- Add notes about deadlock-detect -- Add notes about checkpoint (null in SQL?) -- More notes about transaction performance +- Add document section about backend interface & developer decisions +- Performance and design issues + - More notes about transaction performance + - Serious discussion of threading implications + - Add notes about with/ensure-transaction usage (abort & commit behavior on exit) + - Add notes about optimize-storage + - Add notes about deadlock-detect + - Add notes about checkpoint (null in SQL?) +- Upgrade, migration and other system level issues 0.6.1 - Features COMPLETED to date ---------------------------------- @@ -176,6 +179,7 @@ - Add lazy deserialize to map functions? Performance: +- Improve SQL base-64 serializer 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 --- /project/elephant/cvsroot/elephant/config.sexp 2007/02/14 04:36:08 1.6 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/02/22 20:19:57 1.7 @@ -3,7 +3,8 @@ (:berkeley-db-lib . "/opt/local/BerkeleyDB.4.5/lib/libDB-4.5.dylib") (:berkeley-db-deadlock . "/opt/local/bin/db45_deadlock") (:pthread-lib . nil) - (:clsql-lib . nil)) + (:clsql-lib . nil) + (:compiler . :gcc)) ;; Berkeley 4.5 is required, each system will have different settings for ;; these directories, use this as an indication of what each key means @@ -13,4 +14,9 @@ ;; nil means that the library in question is not loaded ;; ;; 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 +;; it is statically linked against it now with the new thread support +;; +;; :compiler options are +;; :gcc (default: for unix platforms with /usr/bin/gcc) +;; :cygwin (for windows platforms with cygwin/gcc) +;; :msvc (unsupported) \ No newline at end of file --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/31 20:05:37 1.16 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/02/22 20:19:57 1.17 @@ -29,13 +29,18 @@ (defclass bdb-c-source (elephant-c-source) ()) -(defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) - (let* ((include (make-pathname :directory (get-config-option :berkeley-db-include-dir c))) - (lib (make-pathname :directory (get-config-option :berkeley-db-lib-dir c)))) +(defmethod compiler-options (compiler (c bdb-c-source) &key &allow-other-keys) + (let ((include (make-pathname :directory (get-config-option :berkeley-db-include-dir c))) + (lib (make-pathname :directory (get-config-option :berkeley-db-lib-dir c)))) (append (list (format nil "-L~A" lib) (format nil "-I~A" include)) (call-next-method) (list "-ldb")))) +;;Cygwin script: +;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c +;;dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o +;;gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll + (defmethod foreign-libraries-to-load-first ((c bdb-c-source)) (remove-if #'(lambda (x) (null (car x))) (list --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/20 19:12:57 1.32 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/22 20:19:57 1.33 @@ -28,22 +28,12 @@ ;; Simple lisp/asdf-based make utility for elephant c files ;; -(defvar *c-compilers* - '((:gcc . "/usr/bin/gcc") - (:msvc . "")) - "Associate compilers with platforms for compiling libmemutil/libsleepycat") - -(defvar *compiler* - #-(or win32 windows) :gcc - #+(or win32 windows) :msvc) - (defgeneric compiler-options (compiler c-source-file &key input-file output-file) (:documentation "Returns a list of options to pass to ")) (defgeneric foreign-libraries-to-load-first (c-source-file) (:documentation "Provides an alist of foreign-libraries to load and the modules to load them into. Similar to (input-files load-op), but much more specific")) - (defun uffi-funcall (fn &rest args) "Simplify uffi funcall, first ensure uffi is loaded" (unless (find-package :uffi) @@ -54,8 +44,6 @@ ;; User parameters (bdb root and pthread, if necessary) ;; -(defparameter *elephant-user-config* nil) - (defun get-config-option (option component) (let ((filespec (make-pathname :defaults (asdf:component-pathname (asdf:component-system component)) :name "my-config" @@ -67,6 +55,27 @@ (cdr (assoc option (read config)))))) ;; +;; Supported C compilers +;; + + +(defvar *c-compilers* + '((:gcc . "/usr/bin/gcc") + (:cygwin . "c:\\cygwin\\usr\\bin\\gcc") + (:msvc . "")) + "Associate compilers with platforms for compiling libmemutil/libsleepycat") + +(defun c-compiler (comp) + (get-config-option :compiler comp)) + +(defun c-compiler-path (comp) + (let* ((compiler (get-config-option :compiler comp)) + (entry (assoc compiler *c-compilers*))) + (if entry + (cdr entry) + (error "Cannot find compiler path for config.sexp :compiler option: ~A" compiler)))) + +;; ;; Basic utilities for elephant c files ;; @@ -85,63 +94,89 @@ "Run the appropriate compiler for this platform on the source, getting the specific options from 'compiler-options method. Default options can be overridden or augmented by subclass methods" + #+windows + (progn + (let ((pathname (component-pathname c))) + (unless (zerop (run-shell-command + (format nil "~A ~{~A ~}" + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-file (namestring pathname) + :output-file nil + :library nil)))) + (error 'operation-error :component c :operation o)) + (unless (zerop (run-shell-command + (format nil "dlltool -z ~A --export-all-symbols -e exports.o -l ~A ~A" + (namestring (make-pathname :type "def" :defaults pathname)) + (namestring (make-pathname :type "lib" :defaults pathname)) + (namestring (make-pathname :type "o" :defaults pathname))))) + (error 'operation-error :component c :operation o)) + (unless (zerop (run-shell-command + (format nil "~A ~{~A ~} -I~A -L~A -l~A" + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-files + (list (namestring + (make-pathname :type "o" :defaults pathname)) + "exports.o") + :output-file (first (output-files o c)) + :library t)))) + (error 'operation-error :component c :operation o)))) + #-windows (unless (zerop (run-shell-command "~A ~{~A ~}" - (cdr (assoc *compiler* *c-compilers*)) - (compiler-options - *compiler* - c - :input-file (namestring (component-pathname c)) - :output-file (namestring (first (output-files o c)))))) + (c-compiler-path c) + (compiler-options (c-compiler c) c + :input-file (namestring (component-pathname c)) + :output-file (namestring (first (output-files o c)))))) (error 'operation-error :component c :operation o))) + +gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c +dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o +gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll + + (defmethod operation-done-p ((o compile-op) (c elephant-c-source)) "Is the first generated library more recent than the source file?" - (let ((lib (first (output-files o c)))) + (let ((lib (first (output-files o c))) (and (probe-file (component-pathname c)) (probe-file lib) - (> (file-write-date lib) (file-write-date (component-pathname c)))))) + (> (file-write-date lib) (file-write-date (component-pathname c))))))) -(defmethod compiler-options ((compiler (eql :gcc)) (c elephant-c-source) &key input-file output-file) +(defmethod compiler-options ((compiler (eql :gcc)) (c elephant-c-source) &key input-file output-file &allow-other-keys) "Default compile and link options to create a library; no -L or -I options included; math lib as default" (unless (and input-file output-file) (error "Must specify both input and output files")) - (list + (list #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" #+(and X86-64 (or macosx darwin darwin-host)) "-arch x86_64" #+(and X86-64 linux) "-march=x86-64" - "-Wall" "-fPIC" + "-Wall" "-O3" - "-o" output-file input-file + "-o" output-file "-lm")) -;;(defmethod compiler-options ((compiler (eql :gcc-cygwin)) (c elephant-c-source) &key input-file output-file) -;; (unless (and input-file output-file) -;; (error "Must specify both input and output files")) -;; (list -;; "-shared" -;; "-mno-cygwin" -;; "-mwindows" -;; "-std=c99" -;; input-file -;; "-o" output-file -;; "--export-symbols" -;; (namestring (make-pathname :defaults output-file :type "def")))) +(defmethod compiler-options ((compiler (eql :cygwin)) (c elephant-c-source) &key input-file output-file library &allow-other-keys) + (unless input-file + (error "Must specify both input and output files")) + `(,@(when library (list "-shared")) + "-mno-cygwin" + "-mwindows" + "-Wall" + ,@(unless library (list "-c -std=c99")) + "-std=c99" + ,@(when (symbolp input-file) (list input-file) input-file) + ,@(when output-file (list "-o" output-file)))) +;;Cygwin script: ;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c ;;dlltool -z libmeutil.def --export-all-symbols -e exports.o -l libmemutil.lib libmemutil.o ;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll -;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll - -;;And this is the script for libsleepycat.dll: -;; -;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c -;;dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o -;;gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll (defmethod compiler-options ((compiler (eql :msvc)) (c elephant-c-source) &key input-file output-file) (error "MSVC compiler option not supported yet")) From ieslick at common-lisp.net Thu Feb 22 20:19:58 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 22 Feb 2007 15:19:58 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070222201958.1B6BA60035@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv5389/src/elephant Modified Files: classindex.lisp package.lisp serializer1.lisp Log Message: Bug fix in drop instances; preliminary cygwin build in asd fils --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/21 06:29:31 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/22 20:19:57 1.23 @@ -454,7 +454,7 @@ (do-subsets (subset 500 instances) (ensure-transaction (:store-controller sc) (mapc (lambda (instance) - (remove-kv (oid instance) (find-class-index (class-of instance))) - (drop-pobject instance)) + (drop-pobject instance) + (remove-kv (oid instance) (find-class-index (class-of instance)))) subset))))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/21 04:47:42 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/22 20:19:57 1.17 @@ -37,6 +37,7 @@ #:controller-fast-symbols-p #:optimize-layout #:get-user-configuration-parameter + #:database-version #:upgrade --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/21 04:47:42 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/22 20:19:57 1.11 @@ -25,7 +25,6 @@ (:import-from :sb-bignum %bignum-ref) (:import-from :elephant - *resourced-byte-spec* get-cached-instance slot-definition-allocation slot-definition-name From ieslick at common-lisp.net Thu Feb 22 20:24:11 2007 From: ieslick at common-lisp.net (ieslick) Date: Thu, 22 Feb 2007 15:24:11 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070222202411.CD4904E018@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv8239 Modified Files: ele-bdb.asd elephant.asd Log Message: oops in last checkin --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/02/22 20:19:57 1.17 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/02/22 20:24:11 1.18 @@ -29,12 +29,21 @@ (defclass bdb-c-source (elephant-c-source) ()) -(defmethod compiler-options (compiler (c bdb-c-source) &key &allow-other-keys) +(defmethod compiler-options ((compiler (eql :gcc)) (c bdb-c-source) &key &allow-other-keys) + (append (library-directories c) + (call-next-method) + (list "-ldb"))) + +(defmethod compiler-options ((compiler (eql :cygwin)) (c bdb-c-source) &key &allow-other-keys) + (append (library-directories c) + (call-next-method) + (list "-ldb"))) + +(defun library-directories (c) (let ((include (make-pathname :directory (get-config-option :berkeley-db-include-dir c))) (lib (make-pathname :directory (get-config-option :berkeley-db-lib-dir c)))) - (append (list (format nil "-L~A" lib) (format nil "-I~A" include)) - (call-next-method) - (list "-ldb")))) + (list (format nil "-L~A" lib) (format nil "-I~A" include)))) + ;;Cygwin script: ;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/22 20:19:57 1.33 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/22 20:24:11 1.34 @@ -131,18 +131,12 @@ :output-file (namestring (first (output-files o c)))))) (error 'operation-error :component c :operation o))) - -gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c -dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o -gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll - - (defmethod operation-done-p ((o compile-op) (c elephant-c-source)) "Is the first generated library more recent than the source file?" - (let ((lib (first (output-files o c))) + (let ((lib (first (output-files o c)))) (and (probe-file (component-pathname c)) (probe-file lib) - (> (file-write-date lib) (file-write-date (component-pathname c))))))) + (> (file-write-date lib) (file-write-date (component-pathname c)))))) (defmethod compiler-options ((compiler (eql :gcc)) (c elephant-c-source) &key input-file output-file &allow-other-keys) "Default compile and link options to create a library; no -L or -I options included; math lib as default" @@ -179,6 +173,7 @@ (defmethod compiler-options ((compiler (eql :msvc)) (c elephant-c-source) &key input-file output-file) + (declare (ignore input-file output-file)) (error "MSVC compiler option not supported yet")) ;; LOAD From ieslick at common-lisp.net Sat Feb 24 14:51:59 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 09:51:59 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070224145159.A96334E008@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv9022 Modified Files: TODO Log Message: Remove or document NOTE comments in Elephant & BDB code --- /project/elephant/cvsroot/elephant/TODO 2007/02/22 20:19:57 1.58 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/24 14:51:59 1.59 @@ -12,7 +12,6 @@ - Validate SQL migration 0.6.0->0.6.1 (Robert) Stability and Performance: -- Review and address all NOTE comments in the code - Review SBCL string serialization performance - Migration: Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Migration: Improve support for nested persistent objects inside standard objects, arrays, etc? @@ -23,11 +22,11 @@ Lisp Support: - Win32 builds - Windows support for asdf-based library builds? Include 32-bit dll in release? -- Validate Lispworks +- Validate Lispworks on PC - Validate OpenMCL pre-1.1 on Mac OS X - Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? + - 64-bit lisp verification - Verify db_deadlock for other lisps (launch and kill background program I/F) -- 64-bit lisp verification Test coverage: - Clean up interface to tests @@ -72,6 +71,7 @@ x Fixed build bug for linux (Henrik) x Fixed error condition while opening SQLITE3 in SQL backend (Robert) x Fixed idempotence problem in PREPARE-BDB test +x Review and document or address all NOTE comments in the code Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) @@ -166,6 +166,9 @@ based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? - If a class inherits an indexed slot, is it also indexed for that class? This means a proliferation of indexes, or requires user to explicitly add an index as a derived slot. + (Proposal: any subclass must have an :index specifier that is the same as the base class) + (Imp. option: one index for all instances of primary and subclasses; or index per set?) + (Perhaps slot indices should not be secondary so they can point to different class types?) - What if we want an index to index into a range of different subclasses or objects sharing a generic function? (roll your own?) - Reclaim table storage on index drop? It's nice to be able to reconnect sometimes! @@ -174,7 +177,7 @@ - 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. + value by default? - Can we do automatic join cursors? - Add lazy deserialize to map functions? From ieslick at common-lisp.net Sat Feb 24 14:52:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 09:52:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070224145200.0D5FD586AA@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9022/src/elephant Modified Files: classes.lisp classindex-utils.lisp classindex.lisp controller.lisp migrate.lisp package.lisp serializer2.lisp unicode2.lisp Log Message: Remove or document NOTE comments in Elephant & BDB code --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/21 06:29:31 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/24 14:51:59 1.16 @@ -184,8 +184,6 @@ ;; (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; NOTE: probably should delete discarded slots, but we'll worry about that later - ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) @@ -215,7 +213,7 @@ (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) - ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) + ;; Copy values from old class (updates class index) (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) @@ -270,7 +268,6 @@ ;; ====================================================== ;; Handling metaclass overrides of normal slot operation -;; NOTE: Closer to MOP should replace this need... ;; ====================================================== ;; --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/18 23:38:18 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/24 14:51:59 1.6 @@ -190,18 +190,21 @@ (mapcar #'(lambda (rule-specs) (cons (car rule-specs) (mapcar #'make-synch-rule (cdr rule-specs)))) - '((:class ;; class changes db + '((:class ;; class overwrites db ((not db-slot) class-indexed => add-slot-index) (db-slot (not class-indexed) => remove-slot-index) (db-derived (not class-indexed) (not class-persistent) (not class-transient) => register-derived-index)) - (:union ;; merge both sides + (:union ;; merge both sides - conflicts favor class (db-slot (not class-indexed) => register-indexed-slot) ((not db-slot) class-indexed => add-slot-index) (db-derived (not class-derived) => register-derived-index) (db-derived class-persistent => remove-derived-index warn)) - ;; NOTE: What about cases where we need to remove things as below? - (:db ;; db changes class + (:db + ;; :db updates indexing in classes when indexes and + ;; slots overlapped there may still be problems with + ;; derived indices that refer to missing slots or + ;; conflict with new slotnames ((not db-slot) class-indexed => unregister-indexed-slot) ((not db-derived) class-derived => unregister-derived-index) (db-slot class-persistent => register-indexed-slot) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/22 20:19:57 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/24 14:51:59 1.24 @@ -68,7 +68,10 @@ (defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) "Anything that side effects a persistent-object slot should call this to keep the dependant indices in synch. Only classes with derived indices need to - update on writes to non-indexed slots." + update on writes to non-indexed slots. This is a side effect of user-managed + indices in Elephant - a necessity because we allow arbitrary lisp expressions to + determine index value so without bi-directional pointers, the indices cannot + automatically update a changed indexed value in derived slots" (let ((slot-name (slot-definition-name slot-def)) (oid (oid instance)) (con (get-con instance))) @@ -77,8 +80,6 @@ (persistent-slot-writer con new-value instance slot-name) (let ((class-idx (find-class-index class))) (ensure-transaction (:store-controller con) - ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement - (when (get-value oid class-idx) (remove-kv oid class-idx)) (persistent-slot-writer con new-value instance slot-name) @@ -279,8 +280,6 @@ (defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) - ;; NOTE: Write routines to recover BDB storage when you've wiped an index... - ;; NOTE: If the transaction aborts we should not update class slots? (if (find-inverted-index class slot-name :null-on-fail t) (progn (when update-class (unregister-indexed-slot class slot-name)) @@ -357,7 +356,7 @@ ;; ==================================== -;; User level Mapping API +;; Low Level Mapping API ;; ==================================== (defun map-class (fn class) @@ -373,7 +372,7 @@ (declare (dynamic-extent map-fn)) (map-btree #'map-fn class-idx)))) -(defun map-instances (fn class index start end) +(defun map-class-index (fn class index start end) "If you want to map over a subset of instances, pick an index and specify bounds for the traversal. Otherwise use map-class for all instances" --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/21 04:47:42 1.36 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/24 14:51:59 1.37 @@ -82,9 +82,8 @@ (setf (gethash spec *dbconnection-spec*) sc)) sc))) - -;; NOTE: Check for asdf loaded rather than rely on asdf to? (defun load-backend (type) + (assert (find-package :asdf)) (let ((record (assoc type *elephant-backends*))) (when (or (null record) (not (consp record))) (error "Unknown backend type ~A, cannot load" type)) @@ -177,9 +176,9 @@ then it should return nil")) (defmethod database-version :around (sc) - "Default version assumption for unmarked databases is 0.6.0" -;; NOTE: It is possible to check for 0.5.0 databases, but it is not -;; implemented now due to the low (none?) number of users still on 0.5.0" + "Default version assumption for unmarked databases is 0.6.0. + It is possible to check for 0.5.0 databases, but it is not implemented + now due to the low (none?) number of users still on 0.5.0" (declare (ignorable sc)) (let ((db-version (call-next-method))) (if db-version db-version @@ -497,7 +496,8 @@ ;; Callback hooks for persistent variables ;; -;; NOTE: Design sketch; not sure I'll promote this... +;; Design sketch; not sure I'll promote this. +;; To be looked at again for 0.6.2 or 0.7.0 ;;(defvar *variable-hooks* nil ;; "An alist (specs -> varlist) where varlist is tuple of --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/17 12:13:19 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/24 14:51:59 1.8 @@ -24,7 +24,7 @@ ;; repositories and is used by the upgrade interface. ;; -;; NOTES AND LIMITATIONS: +;; LIMITATIONS: ;; - Migrate currently will not handle circular list objects ;; - Migrate does not support arrays or standard objects with nested persistent objects ;; - There are potential problems with graphs and other deep structures --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/22 20:19:57 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/24 14:51:59 1.18 @@ -110,7 +110,7 @@ ;; Class mapping API #:map-class - #:map-instances + #:map-class-index ;; Instance query API #:get-instances-by-class --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/21 04:47:42 1.26 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/24 14:51:59 1.27 @@ -89,14 +89,6 @@ (defconstant +adjustable-p+ #x40) ;; -;; NOTE: Used bad coding practice here: without-interrupts is a single-CPU -;; construct, but most lisps are not native multi-CPU capable so -;; no problems in near term. I used it to avoid general locking overhead -;; as queues are an effective lock-free structure when combined with -;; an allocate-on-empty policy -;; - -;; ;; Circularity Hash for Serializer ;; --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/03 04:09:13 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/24 14:51:59 1.5 @@ -13,7 +13,7 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; -;;; NOTE: Here UTF8 means 8-bit < #x79 only for efficiency, UTF16 means UTF16 format +;;; Here UTF8 means 8-bit < #x79 only for efficiency, UTF16 means UTF16 format ;;; but only for values < #xFFFF. In the odd cases of non-0 unicode planes we just ;;; use UTF-32 to avoid the time cost of translation. Only when converting from a ;;; serialized UTF-X do we worry about encoding (UTF32->UTF16). If an ascii/utf8 lisp From ieslick at common-lisp.net Sat Feb 24 14:52:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 09:52:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/utils Message-ID: <20070224145200.45FC6586A9@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/utils In directory clnet:/tmp/cvs-serv9022/src/utils Modified Files: convenience.lisp package.lisp Log Message: Remove or document NOTE comments in Elephant & BDB code --- /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/17 20:37:23 1.2 +++ /project/elephant/cvsroot/elephant/src/utils/convenience.lisp 2007/02/24 14:52:00 1.3 @@ -7,6 +7,12 @@ (in-package :elephant-utils) +(defmacro with-gensyms (syms &body body) + `(let ,(mapcar #'(lambda (s) + `(,s (gensym))) + syms) + , at body)) + (defmacro do-subsets ((subset subset-size list) &body body) "Look over subsets of the list" `(loop for ,subset in (subsets ,subset-size ,list) do --- /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/14 04:36:13 1.3 +++ /project/elephant/cvsroot/elephant/src/utils/package.lisp 2007/02/24 14:52:00 1.4 @@ -31,4 +31,5 @@ #:kill-background-program #:do-subsets #:subsets - #:remove-keywords)) + #:remove-keywords + #:with-gensyms)) From ieslick at common-lisp.net Sun Feb 25 03:37:39 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 22:37:39 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070225033739.7AF583002E@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16484 Modified Files: classindex.lisp package.lisp serializer.lisp serializer2.lisp Log Message: Support for struct serialization --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/24 14:51:59 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/25 03:37:37 1.25 @@ -3,25 +3,28 @@ ;;; classindex.lisp -- use btree collections to track objects by slot values ;;; via metaclass options or accessor :after methods ;;; -;;; Initial version 1/24/2006 Ian Eslick -;;; eslick at alum mit edu +;;; Copyright (c) 2006,2007 Ian Eslick +;;; ;;; -;;; License: Lisp Limited General Public License -;;; http://www.franz.com/preamble.html +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Limited General Public License +;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. ;;; (in-package "ELEPHANT") (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) +;; ================================= +;; LOW-LEVEL API SPECIFICATION +;; ================================= + ;; -;; User level class indexing control protocol +;; Operates against the current *store-controller* but many +;; accept a :sc keyword to change the controller. The specific +;; indices created can be specialized on the controller type. +;; See the internal implementor protocol below ;; -;; Operates against the current *store-controller* -;; but many accept a :sc keyword to change the controller -;; The specific indices created can be specialized on the -;; controller type. See the internal implementor protocol -;; below. (defgeneric find-class-index (persistent-metaclass &rest rest) (:documentation "This method is the way to access the class index via @@ -60,50 +63,9 @@ (:documentation "Remove a derived index by providing the derived name used to name the derived index")) - -;; =========================== -;; INDEX UPDATE ROUTINE -;; =========================== - -(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) - "Anything that side effects a persistent-object slot should call this to keep - the dependant indices in synch. Only classes with derived indices need to - update on writes to non-indexed slots. This is a side effect of user-managed - indices in Elephant - a necessity because we allow arbitrary lisp expressions to - determine index value so without bi-directional pointers, the indices cannot - automatically update a changed indexed value in derived slots" - (let ((slot-name (slot-definition-name slot-def)) - (oid (oid instance)) - (con (get-con instance))) - (declare (type fixnum oid)) - (if (no-indexing-needed? class instance slot-def oid) - (persistent-slot-writer con new-value instance slot-name) - (let ((class-idx (find-class-index class))) - (ensure-transaction (:store-controller con) - (when (get-value oid class-idx) - (remove-kv oid class-idx)) - (persistent-slot-writer con new-value instance slot-name) - (setf (get-value oid class-idx) instance)))))) - -(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((class-idx (find-class-index class)) - (oid (oid instance)) - (sc (get-con instance))) - (ensure-transaction (:store-controller sc) - (let ((obj (get-value oid class-idx))) - (remove-kv oid class-idx) - (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) - (setf (get-value oid class-idx) obj))))) - -(defun no-indexing-needed? (class instance slot-def oid) - (declare (ignore instance)) - (or (and (not (indexed slot-def)) ;; not indexed - (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes - (member oid *inhibit-indexing-list*))) ;; currently inhibited - -;; =========================== -;; CLASS INDEX INTERFACE -;; =========================== +;; ================================== +;; LOW-LEVEL CLASS INDEXING API +;; ================================== (defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t)) (find-class-index (find-class class-name) :sc sc :errorp errorp)) @@ -148,7 +110,6 @@ :format-control "Class ~A is not enabled for indexing" :format-arguments (list (class-name class))))) - (defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) (find-inverted-index (find-class class) slot :null-on-fail null-on-fail)) @@ -185,9 +146,49 @@ (t (e) (warn "Unable to clear class index caches ~A" e))))) -;; ============================= -;; INDEXING INTERFACE -;; ============================= +;; ============================ +;; METACLASS PROTOCOL HOOKS +;; ============================ + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-indexed slots. This is a side effect of user-managed + indices in Elephant - a necessity because we allow arbitrary lisp expressions to + determine index value so without bi-directional pointers, the indices cannot + automatically update a changed indexed value in derived slots" + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance)) + (con (get-con instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (persistent-slot-writer con new-value instance slot-name) + (let ((class-idx (find-class-index class))) + (ensure-transaction (:store-controller con) + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer con new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + +(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) + (let ((class-idx (find-class-index class)) + (oid (oid instance)) + (sc (get-con instance))) + (ensure-transaction (:store-controller sc) + (let ((obj (get-value oid class-idx))) + (remove-kv oid class-idx) + (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) + (setf (get-value oid class-idx) obj))))) + +(defun no-indexing-needed? (class instance slot-def oid) + (declare (ignore instance)) + (or (and (not (indexed slot-def)) ;; not indexed + (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes + (member oid *inhibit-indexing-list*))) ;; currently inhibited + +;; ============================ +;; EXPLICIT INDEX MGMT API +;; ============================ (defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) (let ((croot (controller-class-root sc))) @@ -321,9 +322,9 @@ (warn "Derived index ~A does not exist in ~A" name (class-name class)) nil))) -;; ========================= -;; Low level cursor API -;; ========================= +;; =================== +;; USER CURSOR API +;; =================== (defgeneric make-inverted-cursor (persistent-metaclass name) (:documentation "Define a cursor on the inverted (slot or derived) index")) @@ -331,13 +332,6 @@ (defgeneric make-class-cursor (persistent-metaclass) (:documentation "Define a cursor over all class instances")) -;; TODO! -;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) -;; (:documentation "Make a join cursor using the slot-value pairs in -;; the specification assoc-list. Support for complex queries -;; requiring new access to db-functions and a new cursor type")) - -;; implementation (defmethod make-inverted-cursor ((class persistent-metaclass) name) (make-cursor (find-inverted-index class name))) @@ -355,9 +349,9 @@ (cursor-close ,var)))) -;; ==================================== -;; Low Level Mapping API -;; ==================================== +;; ====================== +;; USER MAPPING API +;; ====================== (defun map-class (fn class) "Perform a map operation across all instances of class. Takes a @@ -386,9 +380,9 @@ (map-index #'wrapper index :start start :end end)))) -;; =============================== -;; User-level LIST-oriented API -;; =============================== +;; ================= +;; USER SET API +;; ================= (defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/24 14:51:59 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 03:37:37 1.19 @@ -62,6 +62,8 @@ #:btree-index #:get-primary-key #:primary #:key-form #:key-fn + #:struct-constructor + #:migrate #:*inhibit-slot-copy* #:add-symbol-conversion #:add-package-conversion #:*always-convert* @@ -121,6 +123,7 @@ ;; Utilities #:slots-and-values + #:struct-slots-and-values ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/04 04:34:57 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 03:37:37 1.22 @@ -29,6 +29,20 @@ (funcall (symbol-function (controller-deserialize sc)) bs sc)) ;; +;; Special structure support +;; + +(defgeneric struct-constructor (class) + (:documentation "Called to get the constructor name for a struct class. Users + should overload this when they want to serialize non-standard + constructor names. The default constructor make-xxx will work by + default. The argument is an eql style type: i.e. of type (eql 'my-struct)")) + +(defmethod struct-constructor ((class t)) + (symbol-function (intern (concatenate 'string "MAKE-" (symbol-name class)) + (symbol-package class)))) + +;; ;; SQL encoding support ;; @@ -167,10 +181,8 @@ ;;;; Common utilities ;;;; -;; slot names and values for ordinary objects - (defun slots-and-values (o) - (declare (optimize (speed 3) (safety 0))) + "List of slot names followed by values for object" (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () @@ -182,6 +194,25 @@ (push slot-name ret)) finally (return ret))) +(defun struct-slots-and-values (object) + "List of slot names followed by values for structure object" + (let ((result nil) + (slots + #+openmcl + (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + #+cmu + (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) + #+lispworks + (structure:structure-class-slot-names (class-of object)) + #+allegro + (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))) + (loop for slot in slots do + (push (slot-value object slot) result) + (push slot result)) + result)) + ;; array type tags (declaim (type hash-table array-type-to-byte byte-to-array-type)) @@ -229,8 +260,7 @@ (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)) + (declare (type (unsigned-byte 24) position)) #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/24 14:51:59 1.27 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:37:37 1.28 @@ -218,7 +218,6 @@ (setf (gethash frob circularity-hash) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) - (declare (dynamic-extent svs)) (%serialize (/ (length svs) 2)) (loop for item in svs do (%serialize item))))))) @@ -261,21 +260,8 @@ (loop for key being the hash-key of frob using (hash-value value) do - (%serialize key) - (%serialize value)))))) - ;; (structure-object - ;; (buffer-write-byte +struct+ bs) - ;; (let ((idp (gethash frob circularity-hash))) - ;; (if idp (buffer-write-int32 idp bs) - ;; (progn - ;; (buffer-write-int32 (incf lisp-obj-id) bs) - ;; (setf (gethash frbo circularity-hash) lisp-obj-id) - ;; (%serialize (type-of frob)) - ;; (let ((svs (slots-and-values frob))) - ;; (declare (dynamic-extent svs)) - ;; (%serialize (/ (length svs) 2)) - ;; (loop for item in svs - ;; do (%serialize item))))))) + (%serialize key) + (%serialize value)))))) (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob circularity-hash))) @@ -300,6 +286,18 @@ (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) + (structure-object + (buffer-write-byte +struct+ bs) + (let ((idp (gethash frob circularity-hash))) + (if idp (buffer-write-int32 idp bs) + (progn + (buffer-write-int32 (incf lisp-obj-id) bs) + (setf (gethash frob circularity-hash) lisp-obj-id) + (%serialize (type-of frob)) + (let ((svs (struct-slots-and-values frob))) + (%serialize (/ (length svs) 2)) + (loop for item in svs + do (%serialize item))))))) (t (format t "Can't serialize a object: ~A of type ~A~%" frob (type-of frob)))))) (%serialize frob) (release-circularity-hash circularity-hash) @@ -515,6 +513,24 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) + ((= tag +struct+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-o (lookup-id id))) + (if maybe-o maybe-o + (let ((typedesig (%deserialize bs))) + (let ((o (or (handler-case + (funcall (struct-constructor (find-class typedesig))) + (error (v) (format t "got typedesig error for struct: ~A ~A ~%" v typedesig) + (list 'caught-error v typedesig))) + (list 'uninstantiable-object-of-type typedesig)))) + (if (listp o) o + (progn + (add-object o) + (loop for i fixnum from 0 below (%deserialize bs) do + (let ((name (%deserialize bs)) + (value (%deserialize bs))) + (setf (slot-value o name) value))) + o))))))) (t (error (format nil "deserialize of object tagged with ~A failed" tag))))))) (etypecase buf-str (null (return-from deserialize nil)) From ieslick at common-lisp.net Sun Feb 25 03:40:18 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 22:40:18 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070225034018.F2FF73D009@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv17542 Modified Files: TODO Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/TODO 2007/02/24 14:51:59 1.59 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 03:40:18 1.60 @@ -12,7 +12,6 @@ - Validate SQL migration 0.6.0->0.6.1 (Robert) Stability and Performance: -- Review SBCL string serialization performance - Migration: Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Migration: Improve support for nested persistent objects inside standard objects, arrays, etc? - Migration: Improve scaling properties of migration so all objects do not need to be resident in memory? @@ -72,6 +71,7 @@ x Fixed error condition while opening SQLITE3 in SQL backend (Robert) x Fixed idempotence problem in PREPARE-BDB test x Review and document or address all NOTE comments in the code +x Review SBCL string serialization performance (fals alarm, comparable to allegro) Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) @@ -156,8 +156,8 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.6.2 - Advanded work, low-hanging fruit (Summer '07) --------------------------------------------------- +0.7.0 - Advanded work, low-hanging fruit (Summer '07) +----------------------------------------------------- Migrate code base to Darcs and create feature/bug tickets in TRAC @@ -180,6 +180,7 @@ value by default? - Can we do automatic join cursors? - Add lazy deserialize to map functions? +- First-cut query interface Performance: - Improve SQL base-64 serializer performance? @@ -190,6 +191,7 @@ - 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) +- Track derived indices across classes Design: - Move secondary index maintenance to backend; decison on how to call update fn's @@ -222,7 +224,7 @@ - A guide to performance - An overview of licensing issues... -0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations +0.8.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------ Major features: @@ -272,7 +274,7 @@ - Usage model examples for new features - 64-bit oids / 64-bit file sizes -0.7.1 - Elephant BDB/SQL/Lisp Production Release +0.8.1 - Elephant BDB/SQL/Lisp Pre-production Release -------------------------------------------------- - More work on testing, examples and documentation - Intent is for this to be a major, long-term supported release prior @@ -281,9 +283,9 @@ - Online GC for lisp backend? -0.8.0 - Supporting Tools Release +0.9.0 - Supporting Tools Release -------------------------------------------------- - - Richer query language and compiler + - Richer query language and query compiler - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful for long-lived repositories or if you've forgotten a variable name @@ -291,11 +293,12 @@ - Support for cheap persistent sets (medium? can do on SQL?) - Persistent aggregates for better conceptual integration with lisp? - pcons, parray, pstruct, etc + - push/pop elements from a list defined on a persistent slot? 1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------ - Significant work on test cases & testing framework - - Final pass of performance enhancements + - Final pass of performance enhancements and review - Invite community review and testing ======================================================== From ieslick at common-lisp.net Sun Feb 25 03:40:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 22:40:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070225034019.337783D009@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv17542/src/elephant Modified Files: serializer2.lisp Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:37:37 1.28 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:40:19 1.29 @@ -519,7 +519,7 @@ (if maybe-o maybe-o (let ((typedesig (%deserialize bs))) (let ((o (or (handler-case - (funcall (struct-constructor (find-class typedesig))) + (funcall (struct-constructor typedesig)) (error (v) (format t "got typedesig error for struct: ~A ~A ~%" v typedesig) (list 'caught-error v typedesig))) (list 'uninstantiable-object-of-type typedesig)))) From ieslick at common-lisp.net Sun Feb 25 03:40:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Sat, 24 Feb 2007 22:40:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070225034019.AEB713D009@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv17542/tests Modified Files: testserializer.lisp Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/04 10:08:28 1.17 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/25 03:40:19 1.18 @@ -332,7 +332,10 @@ (gethash key s2))))) (standard-object (%deep-equalp (ele::slots-and-values s1) - (ele::slots-and-values s2))) + (ele::slots-and-values s2))) + (structure-object + (%deep-equalp (ele::struct-slots-and-values s1) + (ele::struct-slots-and-values s2))) (t (equalp s1 s2)))))))) (%deep-equalp thing another)))) @@ -389,6 +392,26 @@ :slot2 "foo bar")))) t t) +(defstruct struct1 ss1 ss2) + +(deftest structs + (are-not-null + (in-out-deep-equalp (make-struct1)) + (in-out-deep-equalp (make-struct1 :ss1 "test" :ss2 (make-struct1 :ss1 "bottom" :ss2 nil)))) + t t) + +(defstruct (struct2 (:constructor make-a-struct2)) ss3 ss4) + +(defmethod struct-constructor ((class (eql 'struct2))) + #'make-a-struct2) + +(deftest struct-non-std-construct + (are-not-null + (in-out-deep-equalp (make-a-struct2)) + (in-out-deep-equalp (make-a-struct2 :ss3 (make-a-struct2 :ss4 "foo")))) + t t) + + (deftest circular (let ((c1 (cons nil nil)) (c2 (cons nil nil)) From ieslick at common-lisp.net Sun Feb 25 09:12:47 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 04:12:47 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070225091247.CAA7C2F04F@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv20086 Modified Files: TODO Log Message: Fix SBCL struct serialization; cleanup TODO after Trac conversion; remove persistant aggregate stubs --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 03:40:18 1.60 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:12:47 1.61 @@ -1,7 +1,10 @@ -Last updated: February 4, 2007 +Last updated: February 25th, 2007 -Ongoing release plan notes: +Ongoing release plan notes. + +(Note: use of this file is deprecated after 0.6.1, see Trac site at + http://trac.common-lisp.net/elephant) 0.6.1 - performance, safety and portability -------------------------------------------- @@ -75,7 +78,8 @@ Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) -x Tests to validate new map interfaces on top of existing tests +x Tests to validate new map interfaces on top of existing tests (Ian) +x Added support and tests for serializing structure objects on all supported platforms (Ian) DEVELOPMENT CHECKINS: @@ -156,151 +160,6 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.7.0 - Advanded work, low-hanging fruit (Summer '07) ------------------------------------------------------ - -Migrate code base to Darcs and create feature/bug tickets in TRAC - -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? -- If a class inherits an indexed slot, is it also indexed for that class? This means a - proliferation of indexes, or requires user to explicitly add an index as a derived slot. - (Proposal: any subclass must have an :index specifier that is the same as the base class) - (Imp. option: one index for all instances of primary and subclasses; or index per set?) - (Perhaps slot indices should not be secondary so they can point to different class types?) -- What if we want an index to index into a range of different subclasses or objects sharing - a generic function? (roll your own?) -- 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? -- Can we do automatic join cursors? -- Add lazy deserialize to map functions? -- First-cut query interface - -Performance: -- Improve SQL base-64 serializer 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) -- Track derived indices across classes - -Design: - - Move secondary index maintenance to backend; decison on how to call update fn's - Will make lisp backend cheaper due to ability to life tree manipulation ops - - Use SWIG and CFFI to better track changes in defconstant? (too expensive to be useful) - - 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 (no love on first attempt) - - Work to integrate a proper condition system and potential restarts - for various errors (especially recoverable ones) while accessing db data - - deserialize fubar / diagnose & return value - - missing package / add package/symbol translation - - others? - (log these in Track; not part of 0.6.2?) - -Features: - - Backup function: allow users to specify a backup function to archive the database contents - and checkpoint any active functions (how to lock out other threads?) In BDB this means - running checkpoint and copying the DB files and any active log files. - - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - - 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. - - Finish serious update and review of users manual (building on 0.6.0 update) - - A guide to dealing with transactions - - A guide to dealing with multiple open stores - - A guide to performance - - An overview of licensing issues... - -0.8.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------- - -Major features: - - Native Lisp Backend - - All in common-lisp - - Page-based architecture - - Cheap copy-on-write transaction policy w/ concurrent transaction commits - in non-conflicting transactions - - Fast in-memory operations / prevalence like features - - Make storage policy decisions on per-class (or per-instance) basis - - Concurrent mode - - Current default - - For backends that allow multiple processes to connect - - Full ACID functionality - - Single-threaded objects - - Cache values in instance slots for fast reads - - Writes update slots and write to disk as normal - - Violates consistency and isolation; users must enforce single operator - - Prevalence mode - - Standard object model (user enforced ACID properties) - - Read/write to normal slots - - Backup slot values on object creation and explicit synch calls on class or instances - - In-memory slot indexing, write-through disk class indexing - - NoSynch controller switch - - Violates durability - - Offline garbage collection (via migration) - - Class schemas - - Improve synchronization, support class and instance versioning - - POBJs encoded by OID/CID and CID's are cached in working memory - This way we can issue conditions if an object is out of date so the - user can determine how/if to upgrade the reference to the current schema - - From Ben's e-mail: - We are storing persistent objects incorrectly. They should be stored only as OIDs, - and we should have a separate OID->class table. This way change-class can be - handled correctly. This also non-trivially compresses storage in the - database as we only need to store oids rather than serialized class names. - [Ian comment: only problem with this is an extra access to oid table each time a - class is deserialized and overall storage is constant. Would make it easy to - invalidate objects though!] - - 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? - - Support a simple object query language - -Details: - - Revisit duplicate sorting on primary key (artifact of btree index storage order) - - Usage model examples for new features - - 64-bit oids / 64-bit file sizes - -0.8.1 - Elephant BDB/SQL/Lisp Pre-production Release --------------------------------------------------- - - More work on testing, examples and documentation - - Intent is for this to be a major, long-term supported release prior - to work on the new backend (i.e. patches against this release for - bugs rather than only available in latest development tree) - - Online GC for lisp backend? - - -0.9.0 - Supporting Tools Release --------------------------------------------------- - - Richer query language and query compiler - - Repository browser - a simple REPL tool like the Slime inspector - to see what classes are in a repository and what state they're in...useful - for long-lived repositories or if you've forgotten a variable name - - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) - - Support for cheap persistent sets (medium? can do on SQL?) - - Persistent aggregates for better conceptual integration with lisp? - - pcons, parray, pstruct, etc - - push/pop elements from a list defined on a persistent slot? - -1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------- - - Significant work on test cases & testing framework - - Final pass of performance enhancements and review - - Invite community review and testing - ======================================================== ======================================================== From ieslick at common-lisp.net Sun Feb 25 09:12:48 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 04:12:48 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070225091248.253B13201A@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv20086/src/elephant Modified Files: controller.lisp serializer.lisp Log Message: Fix SBCL struct serialization; cleanup TODO after Trac conversion; remove persistant aggregate stubs --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/24 14:51:59 1.37 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/25 09:12:47 1.38 @@ -492,54 +492,6 @@ (when entry (cdr entry)))) -;; -;; Callback hooks for persistent variables -;; - -;; Design sketch; not sure I'll promote this. -;; To be looked at again for 0.6.2 or 0.7.0 - -;;(defvar *variable-hooks* nil -;; "An alist (specs -> varlist) where varlist is tuple of -;; lisp name, store name (auto) and policy") - -;;(defun add-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (push name (assoc spec *variable-hooks* :test #'equal)) -;; (push (cons spec (list name)) *variable-hooks*))) - -;;(defun remove-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (setf (assoc spec *variable-hooks* :test #'equal) -;; (remove name (assoc spec *variable-hooks* :test #'equal))) -;; (error "No hooks declared on ~A" spec))) - -;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) -;; `(progn -;; (defvar ,name ,initial-value ,documentation) -;; (add-hook ,name ,spec) -;; ,(case policy -;; (:wrap-mutators -;; `(progn -;; ,(loop for accessor in accessors do -;; (let ((gf (ensure-generic-function -;; `(defmethod ,accessor :after ( - -;; (defpvar *agencies* (:wrap-mutators -;; 'add-agent -;; 'remove-agent -;; 'clear-agents) -;; nil -;; "test") - -;; (defmethod add-agent (agent) -;; (push agent *agencies*)) - -;; (defmethod remove-agent (agent) -;; (setf *agencies* (remove agent *agencies*))) - -;; (defmethod clear-agents (agent) -;; (setf *agencies* nil)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 03:37:37 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 09:12:47 1.23 @@ -198,16 +198,14 @@ "List of slot names followed by values for structure object" (let ((result nil) (slots - #+openmcl + #+(or sbcl cmu allegro) + (mapcar #'slot-definition-name (class-slots (class-of object))) + #+openmcl (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) (slots (if sd (ccl::sd-slots sd)))) (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) - #+cmu - (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) #+lispworks - (structure:structure-class-slot-names (class-of object)) - #+allegro - (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))) + (structure:structure-class-slot-names (class-of object)))) (loop for slot in slots do (push (slot-value object slot) result) (push slot result)) From ieslick at common-lisp.net Sun Feb 25 09:37:00 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 04:37:00 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070225093700.D19A73201A@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv24359 Modified Files: TODO Log Message: Fix bug in testindexing; more TODO tweaks --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:12:47 1.61 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:36:59 1.62 @@ -72,9 +72,9 @@ x Fixed typos in SQL backend (Ian/Robert/Henrik) x Fixed build bug for linux (Henrik) x Fixed error condition while opening SQLITE3 in SQL backend (Robert) -x Fixed idempotence problem in PREPARE-BDB test -x Review and document or address all NOTE comments in the code -x Review SBCL string serialization performance (fals alarm, comparable to allegro) +x Fixed idempotence problem in PREPARE-BDB test (Ian) +x Review and document or address all NOTE comments in the code (Ian) +x Review SBCL string serialization performance (false alarm, comparable to allegro) Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) From ieslick at common-lisp.net Sun Feb 25 09:37:02 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 04:37:02 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070225093702.1F53D3C00B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv24359/tests Modified Files: testindexing.lisp Log Message: Fix bug in testindexing; more TODO tweaks --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/21 06:29:32 1.28 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/25 09:37:01 1.29 @@ -201,7 +201,7 @@ (let ((orig-len (length (get-instances-by-class 'idx-unbound-del))) (orig-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) - (slot-makunbound orig-obj 'name) + (slot-makunbound orig-obj 'slot1) (let ((new-len (length (get-instances-by-class 'idx-unbound-del))) (index-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) (values orig-len new-len index-obj)))) From ieslick at common-lisp.net Sun Feb 25 20:02:32 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 15:02:32 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070225200232.18BBA2F049@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv31080 Modified Files: TODO Log Message: Fixed serialization of char codes > #x7F; added appropriate test; fixed symbol export problem --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:36:59 1.62 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 20:02:29 1.63 @@ -36,7 +36,6 @@ - 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 (Henrik's code) - 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 - Class / DB sychronization tests @@ -65,7 +64,8 @@ x Derived indices fail to re-connect after reopening a database under :class synchronization policy (Ian) x Package translation to properly upgrade databases where packages were renamed (Robert) x Fix a bug where slot-makunbound on a persistent object failed to remove secondary index references - for class and slot indices. Made a test to validate this. + for class and slot indices. Made a test to validate this. (Ian) +x Fixed a bug in string serialization for char-code > #x7F (Henrik, Ties) Minor Bugs: x Enable with-transactions to properly process forms returning multiple values (Ian) @@ -75,8 +75,10 @@ x Fixed idempotence problem in PREPARE-BDB test (Ian) x Review and document or address all NOTE comments in the code (Ian) x Review SBCL string serialization performance (false alarm, comparable to allegro) +x Fixed a missing package export: translate-and-intern-symbol from elephant (Ties) Feature tweaking: +x Enabled 8-bit encoding of char-codes between #x7F and #xFF; enabled by earlier rewrite of memutil (Ian) x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) x Tests to validate new map interfaces on top of existing tests (Ian) x Added support and tests for serializing structure objects on all supported platforms (Ian) From ieslick at common-lisp.net Sun Feb 25 20:02:32 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 15:02:32 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070225200232.A3B9B32022@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv31080/src/elephant Modified Files: package.lisp unicode2.lisp Log Message: Fixed serialization of char codes > #x7F; added appropriate test; fixed symbol export problem --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 03:37:37 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 20:02:32 1.20 @@ -68,6 +68,7 @@ #:add-symbol-conversion #:add-package-conversion #:*always-convert* + #:translate-and-intern-symbol #:lookup-persistent-symbol #:lookup-persistent-symbol-id #:int-byte-spec --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/24 14:51:59 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/25 20:02:32 1.6 @@ -35,11 +35,12 @@ "Try to write each format type and bail if code is too big" (declare (type buffer-stream bstream) (type string string)) - (cond ((and (not (equal "" string)) (< (char-code (char string 0)) #x7F)) - (serialize-to-utf8 string bstream)) + (cond ((and (not (equal "" string)) (> (char-code (char string 0)) #xFFFF)) + (serialize-to-utf32le string bstream)) ;; Accelerate the common case where a character set is not Latin-1 - ((and (not (equal "" string)) (< (char-code (char string 0)) #xFFFF)) - (serialize-to-utf16le string bstream)) + ((and (not (equal "" string)) (> (char-code (char string 0)) #xFF)) + (or (serialize-to-utf16le string bstream) + (serialize-to-utf32le string bstream))) ;; Actually code pages > 0 are rare; so we can pay an extra cost (t (or (serialize-to-utf8 string bstream) (serialize-to-utf16le string bstream) @@ -73,13 +74,13 @@ (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (declare (type fixnum code)) - (when (> code #x7F) (fail)) + (when (> code #xFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code)))) (string (loop for i fixnum from 0 below characters do (let ((code (char-code (char string i)))) (declare (type fixnum code)) - (when (> code #x7F) (fail)) + (when (> code #xFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code))))) (setf (buffer-stream-size bstream) needed) (succeed)))))) @@ -251,7 +252,6 @@ (setf code (dpb (next-byte 1) (byte 8 16) code)) (setf code (dpb (next-byte 2) (byte 8 8) code)) (setf code (dpb (next-byte 3) (byte 8 0) code)) - (print code) (setf (char string i) (code-char code))) (incf (elephant-memutil::buffer-stream-position bstream) (+ pos (* length 4))) From ieslick at common-lisp.net Sun Feb 25 20:02:33 2007 From: ieslick at common-lisp.net (ieslick) Date: Sun, 25 Feb 2007 15:02:33 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070225200233.7C5873406B@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv31080/tests Modified Files: testserializer.lisp Log Message: Fixed serialization of char codes > #x7F; added appropriate test; fixed symbol export problem --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/25 03:40:19 1.18 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/25 20:02:32 1.19 @@ -189,6 +189,14 @@ (in-out-equal (make-string 400 :initial-element (code-char 254)))) t t t) +(deftest hard-strings + (are-not-null + (in-out-equal (format nil "Mot~arhead is a hard rock band." (code-char 246))) + (in-out-equal (format nil "M~atley cr~ae is a hard string and was a hard rock band." + (code-char 246) (code-char 252))) + (in-out-equal (format nil "High c~ade p~ages." (code-char #xFFFF) (code-char #x1FFFF)))) + t t t) + (defun in-out-uninterned-equal (var) (with-buffer-streams (out-buf) (serialize var out-buf *store-controller*) From ieslick at common-lisp.net Mon Feb 26 19:12:18 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:12:18 -0500 (EST) Subject: [elephant-cvs] CVS elephant Message-ID: <20070226191218.3EC76A186@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv1238 Modified Files: TODO elephant.asd Log Message: Tweaks for lispworks compatability --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 20:02:29 1.63 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/26 19:12:18 1.64 @@ -29,6 +29,7 @@ - Validate OpenMCL 1.1 and/or 64-bit on Mac OS X? - 64-bit lisp verification - Verify db_deadlock for other lisps (launch and kill background program I/F) + sbcl and allegro are OK Test coverage: - Clean up interface to tests --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/22 20:24:11 1.34 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/26 19:12:18 1.35 @@ -60,8 +60,8 @@ (defvar *c-compilers* - '((:gcc . "/usr/bin/gcc") - (:cygwin . "c:\\cygwin\\usr\\bin\\gcc") + '((:gcc . "gcc") + (:cygwin . "gcc") (:msvc . "")) "Associate compilers with platforms for compiling libmemutil/libsleepycat") @@ -94,32 +94,32 @@ "Run the appropriate compiler for this platform on the source, getting the specific options from 'compiler-options method. Default options can be overridden or augmented by subclass methods" - #+windows + #+(or mswindows windows) (progn (let ((pathname (component-pathname c))) (unless (zerop (run-shell-command (format nil "~A ~{~A ~}" (c-compiler-path c) (compiler-options (c-compiler c) c - :input-file (namestring pathname) + :input-file (format nil "\"~A\"" (namestring pathname)) :output-file nil :library nil)))) (error 'operation-error :component c :operation o)) (unless (zerop (run-shell-command (format nil "dlltool -z ~A --export-all-symbols -e exports.o -l ~A ~A" - (namestring (make-pathname :type "def" :defaults pathname)) - (namestring (make-pathname :type "lib" :defaults pathname)) - (namestring (make-pathname :type "o" :defaults pathname))))) + (format nil "\"~A\"" (namestring (make-pathname :type "def" :defaults pathname))) + (format nil "\"~A\"" (namestring (make-pathname :type "lib" :defaults pathname))) + (format nil "\"~A\"" (namestring (make-pathname :type "o" :defaults pathname)))))) (error 'operation-error :component c :operation o)) (unless (zerop (run-shell-command (format nil "~A ~{~A ~} -I~A -L~A -l~A" (c-compiler-path c) (compiler-options (c-compiler c) c :input-files - (list (namestring - (make-pathname :type "o" :defaults pathname)) + (list (format nil "\"~A\"" (namestring + (make-pathname :type "o" :defaults pathname))) "exports.o") - :output-file (first (output-files o c)) + :output-file (format nil "\"~A\"" (first (output-files o c))) :library t)))) (error 'operation-error :component c :operation o)))) #-windows @@ -156,15 +156,16 @@ (defmethod compiler-options ((compiler (eql :cygwin)) (c elephant-c-source) &key input-file output-file library &allow-other-keys) (unless input-file - (error "Must specify both input and output files")) - `(,@(when library (list "-shared")) - "-mno-cygwin" - "-mwindows" - "-Wall" - ,@(unless library (list "-c -std=c99")) - "-std=c99" - ,@(when (symbolp input-file) (list input-file) input-file) - ,@(when output-file (list "-o" output-file)))) + (error "Must specify both input files")) + (append + (when library (list "-shared")) + (list + "-mno-cygwin" + "-mwindows" + "-Wall") + (unless library (list "-c -std=c99")) + (if (listp input-file) input-file (list input-file)) + (when output-file (list "-o" output-file)))) ;;Cygwin script: ;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c From ieslick at common-lisp.net Mon Feb 26 19:12:18 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:12:18 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070226191218.82EB21E001@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv1238/src/db-clsql Modified Files: sql-collections.lisp Log Message: Tweaks for lispworks compatability --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/08 22:33:35 1.10 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/26 19:12:18 1.11 @@ -45,8 +45,8 @@ ;; to implement the cursor semantics. Clearly, passing ;; in a different ordering is a nice feature to have here. (defclass sql-cursor (cursor) - ((keys :accessor :sql-crsr-ks :initarg :sql-cursor-keys :initform '()) - (curkey :accessor :sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type (or null integer))) + ((keys :accessor sql-crsr-ks :initarg :sql-cursor-keys :initform '()) + (curkey :accessor sql-crsr-ck :initarg :sql-cursor-curkey :initform -1 :type (or null integer))) (:documentation "A SQL cursor for traversing (primary) BTrees.")) (defmethod make-cursor ((bt sql-btree)) @@ -59,7 +59,7 @@ (defmethod cursor-close ((cursor sql-cursor)) - (setf (:sql-crsr-ck cursor) nil) + (setf (sql-crsr-ck cursor) nil) (setf (cursor-initialized-p cursor) nil)) ;; Maybe this will still work? @@ -71,8 +71,8 @@ :initialized-p (cursor-initialized-p cursor) :oid (cursor-oid cursor) ;; Do we need to so some kind of copy on this collection? - :keys (:sql-crsr-ks cursor) - :curkey (:sql-crsr-ck cursor))) + :keys (sql-crsr-ks cursor) + :curkey (sql-crsr-ck cursor))) ;; :handle (db-cursor-duplicate ;; (cursor-handle cursor) ;; :position (cursor-initialized-p cursor)))) @@ -129,14 +129,14 @@ (len (length tuples))) ;; now we somehow have to load the keys into the array... ;; actually, this should be an adjustable vector... - (setf (:sql-crsr-ks cursor) (make-array (length tuples))) + (setf (sql-crsr-ks cursor) (make-array (length tuples))) (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) + (sort (sql-crsr-ks cursor) #'my-generic-less-than) + (setf (sql-crsr-ck cursor) 0) (setf (cursor-initialized-p cursor) t) )) @@ -144,9 +144,9 @@ ;; we're assuming here that nil is not a legitimate key. (defmethod get-current-key ((cursor sql-cursor)) - (let ((x (:sql-crsr-ck cursor))) - (if (and (>= x 0) (< x (length (:sql-crsr-ks cursor)))) - (svref (:sql-crsr-ks cursor) x) + (let ((x (sql-crsr-ck cursor))) + (if (and (>= x 0) (< x (length (sql-crsr-ks cursor)))) + (svref (sql-crsr-ks cursor) x) '() )) ) @@ -180,8 +180,8 @@ (defmethod cursor-last ((cursor sql-cursor) ) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (setf (:sql-crsr-ck cursor) - (- (length (:sql-crsr-ks cursor)) 1)) + (setf (sql-crsr-ck cursor) + (- (length (sql-crsr-ks cursor)) 1)) (setf (cursor-initialized-p cursor) t) (has-key-value cursor)) @@ -190,7 +190,7 @@ (defmethod cursor-next ((cursor sql-cursor)) (if (cursor-initialized-p cursor) (progn - (incf (:sql-crsr-ck cursor)) + (incf (sql-crsr-ck cursor)) (has-key-value cursor)) (cursor-first cursor))) @@ -198,27 +198,27 @@ (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (progn - (decf (:sql-crsr-ck cursor)) + (decf (sql-crsr-ck cursor)) (has-key-value cursor)) (cursor-last cursor))) (defmethod cursor-set ((cursor sql-cursor) key) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) - (let ((p (position key (:sql-crsr-ks cursor) :test #'equal))) + (let ((p (position key (sql-crsr-ks cursor) :test #'equal))) (if p (progn - (setf (:sql-crsr-ck cursor) p) + (setf (sql-crsr-ck cursor) p) (setf (cursor-initialized-p cursor) t) (has-key-value cursor) ) (setf (cursor-initialized-p cursor) nil))) (progn (cursor-init cursor) - (let ((p (position key (:sql-crsr-ks cursor) :test #'equal))) + (let ((p (position key (sql-crsr-ks cursor) :test #'equal))) (if p (progn - (setf (:sql-crsr-ck cursor) p) + (setf (sql-crsr-ck cursor) p) (has-key-value cursor) ) (setf (cursor-initialized-p cursor) nil)))) @@ -231,7 +231,7 @@ ;; the initialized state... (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((len (length (:sql-crsr-ks cursor))) + (let ((len (length (sql-crsr-ks cursor))) (vs '())) (do ((i 0 (1+ i))) ((or (= i len) @@ -299,7 +299,7 @@ ;; Secondary Cursors (defclass sql-secondary-cursor (sql-cursor) ( - (dup-number :accessor :dp-nmbr :initarg :dup-number :initform 0 :type integer) + (dup-number :accessor dp-nmbr :initarg :dup-number :initform 0 :type integer) ) (:documentation "Cursor for traversing bdb secondary indices.")) @@ -314,14 +314,14 @@ (defmethod has-key-value-scnd ((cursor sql-secondary-cursor) &key (returnpk nil)) - (let ((ck (:sql-crsr-ck cursor))) - (if (and (>= ck 0) (< ck (length (:sql-crsr-ks cursor)))) - (let* ((cur-pk (aref (:sql-crsr-ks cursor) - (:sql-crsr-ck cursor))) + (let ((ck (sql-crsr-ck cursor))) + (if (and (>= ck 0) (< ck (length (sql-crsr-ks cursor)))) + (let* ((cur-pk (aref (sql-crsr-ks cursor) + (sql-crsr-ck cursor))) (sc (get-con (cursor-btree cursor))) (indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk sc - (:dp-nmbr cursor)))) + (dp-nmbr cursor)))) (if indexed-pk (let ((v (get-value indexed-pk (primary (cursor-btree cursor))))) (if v @@ -359,11 +359,11 @@ (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((idx (position key (:sql-crsr-ks cursor) :test #'equal))) + (let ((idx (position key (sql-crsr-ks cursor) :test #'equal))) (if idx (progn - (setf (:sql-crsr-ck cursor) idx) - (setf (:dp-nmbr cursor) 0) + (setf (sql-crsr-ck cursor) idx) + (setf (dp-nmbr cursor) 0) (cursor-current-x cursor :returnpk t)) (cursor-un-init cursor) ))) @@ -381,11 +381,11 @@ (declare (optimize (speed 3))) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (let ((idx (array-index-if #'(lambda (x) (my-generic-at-most key x)) (:sql-crsr-ks cursor)))) + (let ((idx (array-index-if #'(lambda (x) (my-generic-at-most key x)) (sql-crsr-ks cursor)))) (if (<= 0 idx) (progn - (setf (:sql-crsr-ck cursor) idx) - (setf (:dp-nmbr cursor) 0) + (setf (sql-crsr-ck cursor) idx) + (setf (dp-nmbr cursor) 0) (cursor-current-x cursor :returnpk t) ) (cursor-un-init cursor :returnpk t) @@ -456,15 +456,15 @@ (cursor-current-x cursor :returnpk t) (declare (ignore m k v)) (remove-kv p (primary (cursor-btree cursor))) - (let ((ck (:sql-crsr-ck cursor)) - (dp (:dp-nmbr cursor))) + (let ((ck (sql-crsr-ck cursor)) + (dp (dp-nmbr cursor))) (declare (ignorable dp)) (cursor-next cursor) ;; Now that we point to the old slot, remove the old slot from the array... - (setf (:sql-crsr-ks cursor) + (setf (sql-crsr-ks cursor) (remove-indexed-element-and-adjust ck - (:sql-crsr-ks cursor))) + (sql-crsr-ks cursor))) ;; now move us back to where we were (cursor-prev cursor) )) @@ -496,7 +496,7 @@ (defmethod cursor-first-x ((cursor sql-secondary-cursor) &key (returnpk nil)) (declare (optimize (speed 3))) - (setf (:dp-nmbr cursor) 0) + (setf (dp-nmbr cursor) 0) (cursor-init cursor) (has-key-value-scnd cursor :returnpk returnpk) ) @@ -509,10 +509,10 @@ (if (cursor-initialized-p cursor) (progn (let ((cur-pk (get-current-key cursor))) - (incf (:sql-crsr-ck cursor)) + (incf (sql-crsr-ck cursor)) (if (equal cur-pk (get-current-key cursor)) - (incf (:dp-nmbr cursor)) - (setf (:dp-nmbr cursor) 0)) + (incf (dp-nmbr cursor)) + (setf (dp-nmbr cursor) 0)) (has-key-value-scnd cursor :returnpk returnpk))) (cursor-first-x cursor :returnpk returnpk))) @@ -524,10 +524,10 @@ (if (cursor-initialized-p cursor) (progn (let ((cur-pk (get-current-key cursor))) - (decf (:sql-crsr-ck cursor)) + (decf (sql-crsr-ck cursor)) (if (equal cur-pk (get-current-key cursor)) - (setf (:dp-nmbr cursor) (max 0 (- (:dp-nmbr cursor) 1))) - (setf (:dp-nmbr cursor) + (setf (dp-nmbr cursor) (max 0 (- (dp-nmbr cursor) 1))) + (setf (dp-nmbr cursor) (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) (get-con (cursor-btree cursor)) @@ -546,22 +546,22 @@ (defmethod cursor-next-dup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) ;; (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) - (let* ((cur-pk (aref (:sql-crsr-ks cursor) - (:sql-crsr-ck cursor))) - (nint (+ 1 (:sql-crsr-ck cursor))) - (nxt-pk (if (array-in-bounds-p (:sql-crsr-ks cursor) nint) - (aref (:sql-crsr-ks cursor) + (let* ((cur-pk (aref (sql-crsr-ks cursor) + (sql-crsr-ck cursor))) + (nint (+ 1 (sql-crsr-ck cursor))) + (nxt-pk (if (array-in-bounds-p (sql-crsr-ks cursor) nint) + (aref (sql-crsr-ks cursor) nint) -1 )) ) (if (equal cur-pk nxt-pk) (progn - (incf (:dp-nmbr cursor)) - (incf (:sql-crsr-ck cursor)) + (incf (dp-nmbr cursor)) + (incf (sql-crsr-ck cursor)) (has-key-value-scnd cursor :returnpk returnpk)) (progn - (setf (:dp-nmbr cursor) 0) + (setf (dp-nmbr cursor) 0) (cursor-un-init cursor :returnpk returnpk) ))))) @@ -571,15 +571,15 @@ (defmethod cursor-next-nodup-x ((cursor sql-secondary-cursor) &key (returnpk nil)) (if (cursor-initialized-p cursor) (let ((n - (do ((i (:sql-crsr-ck cursor) (1+ i))) + (do ((i (sql-crsr-ck cursor) (1+ i))) ((or - (not (array-in-bounds-p (:sql-crsr-ks cursor) (+ i 1))) + (not (array-in-bounds-p (sql-crsr-ks cursor) (+ i 1))) (not - (equal (aref (:sql-crsr-ks cursor) i) - (aref (:sql-crsr-ks cursor) (+ 1 i))))) + (equal (aref (sql-crsr-ks cursor) i) + (aref (sql-crsr-ks cursor) (+ 1 i))))) (+ 1 i))))) - (setf (:sql-crsr-ck cursor) n) - (setf (:dp-nmbr cursor) 0) + (setf (sql-crsr-ck cursor) n) + (setf (dp-nmbr cursor) 0) (has-key-value-scnd cursor :returnpk returnpk)) (cursor-first-x cursor :returnpk returnpk) )) @@ -590,9 +590,9 @@ (defmethod cursor-last-x ((cursor sql-secondary-cursor) &key (returnpk nil)) (unless (cursor-initialized-p cursor) (cursor-init cursor)) - (setf (:sql-crsr-ck cursor) - (- (length (:sql-crsr-ks cursor)) 1)) - (setf (:dp-nmbr cursor) + (setf (sql-crsr-ck cursor) + (- (length (sql-crsr-ks cursor)) 1)) + (setf (dp-nmbr cursor) (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) @@ -600,7 +600,7 @@ (get-con (cursor-btree cursor)) ) 1))) - (assert (>= (:dp-nmbr cursor) 0)) + (assert (>= (dp-nmbr cursor) 0)) (setf (cursor-initialized-p cursor) t) (has-key-value-scnd cursor :returnpk returnpk) ) @@ -614,8 +614,8 @@ (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (progn - (setf (:sql-crsr-ck cursor) (- (:sql-crsr-ck cursor) (+ 1 (:dp-nmbr cursor)))) - (setf (:dp-nmbr cursor) + (setf (sql-crsr-ck cursor) (- (sql-crsr-ck cursor) (+ 1 (dp-nmbr cursor)))) + (setf (dp-nmbr cursor) (max 0 (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) From ieslick at common-lisp.net Mon Feb 26 19:12:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:12:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070226191219.21FDA1F00F@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv1238/src/elephant Modified Files: classes.lisp classindex.lisp controller.lisp metaclasses.lisp migrate.lisp package.lisp serializer.lisp serializer1.lisp serializer2.lisp Log Message: Tweaks for lispworks compatability --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/24 14:51:59 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/26 19:12:18 1.17 @@ -33,7 +33,7 @@ (if from-oid (setf (oid instance) from-oid) (setf (oid instance) (next-oid sc))) - (setf (:dbcn-spc-pst instance) (controller-spec sc)) + (setf (dbcn-spc-pst instance) (controller-spec sc)) (cache-instance sc instance)) (defclass persistent-object (persistent) () --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/25 03:37:37 1.25 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/26 19:12:18 1.26 @@ -99,7 +99,7 @@ btree)) (define-condition persistent-class-not-indexed (error) - ((class-obj :initarg :class :initarg nil :reader :unindexed-class-obj))) + ((class-obj :initarg :class :initarg nil :reader unindexed-class-obj))) (defun cache-new-class-index (class sc) "If not cached or persistent then this is a new class, make the new index" --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/25 09:12:47 1.38 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/26 19:12:18 1.39 @@ -47,7 +47,7 @@ we re-open the controller from the spec if it's not cached? That might be dangerous so for now we error" (declare (ignore sc)) - (let ((con (gethash (:dbcn-spc-pst instance) *dbconnection-spec*))) + (let ((con (gethash (dbcn-spc-pst instance) *dbconnection-spec*))) (cond ((not con) ;; ISE NOTE: Create a new one here & warn instead? ;; (get-controller spec) --- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/02/14 04:36:10 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/02/26 19:12:18 1.9 @@ -24,7 +24,7 @@ (defclass persistent () ((%oid :accessor oid :initarg :from-oid) - (dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst)) + (dbonnection-spec-pst :type (or list string) :accessor dbcn-spc-pst :initarg :dbconnection-spec-pst)) (:documentation "Abstract superclass for all persistent classes (common to user-defined classes and collections.)")) @@ -239,7 +239,8 @@ '(:instance :class :database)) (defmethod slot-definition-allocation ((slot-definition persistent-slot-definition)) - :database) + #-lispworks :database + #+lispworks nil) (defmethod direct-slot-definition-class ((class persistent-metaclass) &rest initargs) "Checks for the transient tag (and the allocation type) --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/24 14:51:59 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/26 19:12:18 1.9 @@ -117,7 +117,7 @@ (unless (object-was-copied-p src) (typecase src (store-controller (assert (not (equal dst-spec (controller-spec src))))) - (persistent (assert (not (equal dst-spec (:dbcn-spc-pst src))))))))) + (persistent (assert (not (equal dst-spec (dbcn-spc-pst src))))))))) ;; WHOLE STORE MIGRATION @@ -225,7 +225,7 @@ (gethash (oid src) *migrate-copied-oids*))) (defun register-copied-object (src dst) - (assert (not (equal (:dbcn-spc-pst src) (:dbcn-spc-pst dst)))) + (assert (not (equal (dbcn-spc-pst src) (dbcn-spc-pst dst)))) (setf (gethash (oid src) *migrate-copied-oids*) dst)) (defun retrieve-copied-object (src) @@ -245,7 +245,7 @@ (defun inhibit-indexed-slot-copy? (sc class) (and (indexed class) (not (equal (controller-spec sc) - (:dbcn-spc-pst (%index-cache class)))))) + (dbcn-spc-pst (%index-cache class)))))) (defun copy-persistent-slots (dstsc class src dst) "Copy only persistent slots from src to dst" --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 20:02:32 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/26 19:12:18 1.21 @@ -21,7 +21,7 @@ (defpackage elephant (:use :common-lisp :elephant-memutil :elephant-utils) - (:nicknames ele :ele) + (:nicknames :ele) (:documentation "Elephant: an object-oriented database for Common Lisp with multiple backends for Berkeley DB, SQL and others.") @@ -275,6 +275,7 @@ %slot-definition-type) #+lispworks (:import-from :clos + class-finalized-p compute-class-precedence-list validate-superclass ensure-class-using-class --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 09:12:47 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/26 19:12:18 1.24 @@ -259,10 +259,10 @@ "Shared byte-spec peformance hack; not thread safe so removed from use for serializer2" (declare (type (unsigned-byte 24) position)) - #+(or cmu sbcl allegro) - (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) - *resourced-byte-spec*) - #-(or cmu sbcl allegro) +;; #+(or cmu sbcl allegro) +;; (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) +;; *resourced-byte-spec*) +;; #-(or cmu sbcl allegro) (byte 32 (* 32 position)) ) --- /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/22 20:19:57 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/02/26 19:12:18 1.12 @@ -488,7 +488,7 @@ (type boolean positive)) (loop for i from 0 below (/ length 4) for byte-spec = (int-byte-spec i) - with num integer = 0 + with num of-type integer = 0 do (setq num (dpb (buffer-read-uint bs) byte-spec num)) finally (return (if positive num (- num))))) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:40:19 1.29 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/26 19:12:18 1.30 @@ -550,7 +550,7 @@ for byte-spec = ;; #+(or allegro) (progn (setf (cdr int-byte-spec) (* 32 i)) int-byte-spec) #+(or allegro sbcl cmu lispworks openmcl) (byte 32 (* 32 i)) - with num integer = 0 + with num of-type integer = 0 do (setq num (dpb (buffer-read-uint bs) byte-spec num)) finally From ieslick at common-lisp.net Mon Feb 26 19:12:19 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:12:19 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20070226191219.71DB32B032@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv1238/src/memutil Modified Files: memutil.lisp Log Message: Tweaks for lispworks compatability --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/14 04:36:13 1.23 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/02/26 19:12:19 1.24 @@ -79,7 +79,7 @@ (def-type pointer-int (* :int)) (def-type pointer-void :pointer-void) (def-foreign-type array-or-pointer-char - #+allegro (:array :unsigned-char) + #+(or allegro lispworks) (:array :unsigned-char) #+(or cmu sbcl scl openmcl) (* :unsigned-char)) (def-type array-or-pointer-char array-or-pointer-char) @@ -828,8 +828,9 @@ ;; This code is an attempt to allow compilation under bothe SBCL 8 and SBCL 9. ;; Thanks to Juho Snellman for this idiom. (eval-when (:compile-toplevel) + #+(and sbcl sb-unicode) (defun new-style-copy-p () - (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL") + (if (find-symbol "COPY-UB8-FROM-SYSTEM-AREA" "SB-KERNEL") '(:and) '(:or))) ) @@ -846,14 +847,14 @@ :length byte-length :null-terminated-p nil) #+(and sbcl sb-unicode) (let ((res (make-string byte-length :element-type 'base-char))) -#+#.(elephant-memutil::new-style-copy-p) + #+#.(elephant-memutil::new-style-copy-p) (sb-kernel:copy-ub8-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) position res 0 byte-length) -#-#.(elephant-memutil::new-style-copy-p) + #-#.(elephant-memutil::new-style-copy-p) (sb-kernel:copy-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) (* position sb-vm:n-byte-bits) @@ -888,14 +889,14 @@ (let ((position (buffer-stream-position bs))) (setf (buffer-stream-position bs) (+ position byte-length)) (let ((res (make-string (/ byte-length 4) :element-type 'character))) -#+#.(elephant-memutil::new-style-copy-p) + #+#.(elephant-memutil::new-style-copy-p) (sb-kernel:copy-ub8-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) position res 0 byte-length) -#-#.(elephant-memutil::new-style-copy-p) + #-#.(elephant-memutil::new-style-copy-p) (sb-kernel:copy-from-system-area (sb-alien:alien-sap (buffer-stream-buffer bs)) (* position sb-vm:n-byte-bits) From ieslick at common-lisp.net Mon Feb 26 19:12:24 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:12:24 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070226191224.0CE9830021@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv1238/tests Modified Files: elephant-tests.lisp testindexing.lisp Log Message: Tweaks for lispworks compatability --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/07 22:54:13 1.25 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/02/26 19:12:19 1.26 @@ -17,8 +17,8 @@ ;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. (defpackage elephant-tests - (:nicknames ele-tests :ele-tests) - (:use common-lisp elephant rt) + (:nicknames :ele-tests) + (:use :common-lisp :elephant :regression-test) (:import-from :ele with-buffer-streams serialize --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/25 09:37:01 1.29 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/26 19:12:20 1.30 @@ -2,8 +2,8 @@ (in-package :ele-tests) (defun setup-testing () - (setf rt::*debug* t) - (setf rt::*catch-errors* nil) + (setf regression-test::*debug* t) + (setf regression-test::*catch-errors* nil) ;; (trace elephant::indexed-slot-writer) (trace ((method initialize-instance :before (persistent)))) (trace ((method initialize-instance (persistent-object)))) From ieslick at common-lisp.net Mon Feb 26 19:55:12 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:55:12 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/db-clsql Message-ID: <20070226195512.DE6BD59085@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv9966/src/db-clsql Modified Files: sql-collections.lisp Log Message: Further lispworks tweaks; fix bug in wipe-class-indexing --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/26 19:12:18 1.11 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/02/26 19:55:11 1.12 @@ -298,9 +298,7 @@ ;; Secondary Cursors (defclass sql-secondary-cursor (sql-cursor) - ( - (dup-number :accessor dp-nmbr :initarg :dup-number :initform 0 :type integer) - ) + ((dup-number :accessor dp-nmbr :initarg :dup-number :initform 0 :type integer)) (:documentation "Cursor for traversing bdb secondary indices.")) From ieslick at common-lisp.net Mon Feb 26 19:55:13 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:55:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20070226195513.3116562013@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9966/src/elephant Modified Files: classes.lisp Log Message: Further lispworks tweaks; fix bug in wipe-class-indexing --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/26 19:12:18 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/26 19:55:12 1.18 @@ -96,7 +96,7 @@ (call-next-method) (when (class-finalized-p instance) (update-persistent-slots instance (persistent-slot-names instance)) - (update-indexed-record instance (indexed-slot-names-from-defs instance)) +;; (update-indexed-record instance (indexed-slot-names-from-defs instance)) (if (removed-indexing? instance) (progn (let ((class-idx (find-class-index (class-name instance)))) From ieslick at common-lisp.net Mon Feb 26 19:55:13 2007 From: ieslick at common-lisp.net (ieslick) Date: Mon, 26 Feb 2007 14:55:13 -0500 (EST) Subject: [elephant-cvs] CVS elephant/tests Message-ID: <20070226195513.EC7F163088@common-lisp.net> Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv9966/tests Modified Files: testindexing.lisp Log Message: Further lispworks tweaks; fix bug in wipe-class-indexing --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/26 19:12:20 1.30 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/26 19:55:13 1.31 @@ -219,6 +219,7 @@ (:metaclass persistent-metaclass)) (with-transaction (:store-controller *store-controller*) + (drop-instances (get-instances-by-class 'idx-five-del)) (make-instance 'idx-five-del)) (let ((r1 (get-instances-by-value 'idx-five-del 'slot1 1)))