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

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 31 Jan '07

31 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv9434/src/db-bdb Modified Files: bdb-controller.lisp berkeley-db.lisp Log Message: Unsure why this doesn't compile, probably due to strings, but I'll comment it out for now --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/31 20:05:37 1.17 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/31 22:24:16 1.18 @@ -136,8 +136,8 @@ (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 errfile +;; (db-set-error-file (controller-db sc) errfile)) (when deadlock-detect (start-deadlock-detector sc)) --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/31 20:05:37 1.5 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/31 22:24:16 1.6 @@ -485,13 +485,13 @@ :flags (force) :documentation "Make a checkpoint.") -(def-function ("db_set_error_file" %db-set-error-file) - ((db :pointer-void) - (file :cstring))) - -(defun db-set-error-file (db filename) - (with-cstrings ((fname filename)) - (%db-set-error-file db fname))) +;;(def-function ("db_set_error_file" %db-set-error-file) +;; ((db :pointer-void) +;; (file :cstring))) + +;;(defun db-set-error-file (db filename) +;; (with-cstrings ((fname filename)) +;; (%db-set-error-file db fname))) ;; Database

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 31 Jan '07

31 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv24260/src/db-bdb Modified Files: bdb-collections.lisp bdb-controller.lisp berkeley-db.lisp libberkeley-db.c Removed Files: bdb-symbol-tables.lisp Log Message: Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/12/16 19:35:10 1.11 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/01/31 20:05:37 1.12 @@ -19,6 +19,8 @@ (in-package :db-bdb) +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0))) + (defclass bdb-btree (btree) () (:documentation "A BerkleyDB implementation of a BTree")) @@ -32,7 +34,6 @@ (make-instance 'bdb-btree :sc sc)) (defmethod get-value (key (bt bdb-btree)) - (declare (optimize (speed 3) (space 0) (safety 0))) (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) @@ -43,7 +44,6 @@ (values nil nil)))))) (defmethod existsp (key (bt bdb-btree)) - (declare (optimize (speed 3) (safety 0) (space 0))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf (get-con bt)) @@ -55,8 +55,6 @@ (defmethod (setf get-value) (value key (bt bdb-btree)) - (declare (optimize (speed 3) (safety 0) (space 0))) - (assert (or *auto-commit* (not (eq *current-transaction* 0)))) ;; (with-transaction () (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) @@ -64,8 +62,7 @@ (serialize key key-buf sc) (serialize value value-buf sc) (db-put-buffered (controller-btrees sc) - key-buf value-buf - :auto-commit *auto-commit*))) + key-buf value-buf))) ;; ) value) @@ -85,15 +82,13 @@ ;; (write-value)))) (defmethod remove-kv (key (bt bdb-btree)) - (declare (optimize (speed 3) (space 0) (safety 0))) - (assert (or *auto-commit* (not (eq *current-transaction* 0)))) ;; (with-transaction (:store-controller (get-con bt)) (let ((sc (get-con bt)) ) (with-buffer-streams (key-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf sc) (db-delete-buffered (controller-btrees sc) - key-buf :auto-commit *auto-commit*)))) + key-buf)))) ;; Secondary indices @@ -216,7 +211,6 @@ (defmethod remove-kv (key (bt bdb-indexed-btree)) "Remove a key / value pair, and update secondary indices." - (declare (optimize (speed 3))) (let ((sc (get-con bt))) (with-buffer-streams (key-buf secondary-buf) (buffer-write-int (oid bt) key-buf) @@ -252,7 +246,6 @@ (defmethod get-value (key (bt bdb-btree-index)) "Get the value in the primary DB from a secondary key." - (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) (serialize key key-buf (get-con bt)) @@ -263,7 +256,6 @@ (values nil nil))))) (defmethod get-primary-key (key (bt btree-index)) - (declare (optimize (speed 3))) (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) @@ -282,19 +274,16 @@ (defmethod make-cursor ((bt bdb-btree)) "Make a cursor from a btree." - (declare (optimize (speed 3))) (make-instance 'bdb-cursor :btree bt :handle (db-cursor (controller-btrees (get-con bt))) :oid (oid bt))) (defmethod cursor-close ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (db-cursor-close (cursor-handle cursor)) (setf (cursor-initialized-p cursor) nil)) (defmethod cursor-duplicate ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (make-instance (type-of cursor) :initialized-p (cursor-initialized-p cursor) :oid (cursor-oid cursor) @@ -303,7 +292,6 @@ :position (cursor-initialized-p cursor)))) (defmethod cursor-current ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) @@ -317,7 +305,6 @@ (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-first ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -333,7 +320,6 @@ ;;A bit of a hack..... (defmethod cursor-last ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (+ (cursor-oid cursor) 1) key-buf) @@ -361,7 +347,6 @@ (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-next ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) @@ -375,7 +360,6 @@ (cursor-first cursor))) (defmethod cursor-prev ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) @@ -389,7 +373,6 @@ (cursor-last cursor)))) (defmethod cursor-set ((cursor bdb-cursor) key) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -404,7 +387,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-set-range ((cursor bdb-cursor) key) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -419,7 +401,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-get-both ((cursor bdb-cursor) key value) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -435,7 +416,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-get-both-range ((cursor bdb-cursor) key value) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -450,7 +430,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-delete ((cursor bdb-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) @@ -469,7 +448,6 @@ "Put by cursor. Not particularly useful since primaries don't support duplicates. Currently doesn't properly move the cursor." - (declare (optimize (speed 3))) (if key-specified-p (setf (get-value key (cursor-btree cursor)) value) (if (cursor-initialized-p cursor) @@ -493,7 +471,6 @@ (defmethod make-cursor ((bt bdb-btree-index)) "Make a secondary-cursor from a secondary index." - (declare (optimize (speed 3))) (make-instance 'bdb-secondary-cursor :btree bt :handle (db-cursor @@ -502,7 +479,6 @@ (defmethod cursor-pcurrent ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -519,7 +495,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pfirst ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) (multiple-value-bind (key pkey val) @@ -536,7 +511,6 @@ ;;A bit of a hack..... (defmethod cursor-plast ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (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) @@ -568,7 +542,6 @@ (setf (cursor-initialized-p cursor) nil))))))) (defmethod cursor-pnext ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -583,7 +556,6 @@ (cursor-pfirst cursor))) (defmethod cursor-pprev ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -598,7 +570,6 @@ (cursor-plast cursor))) (defmethod cursor-pset ((cursor bdb-secondary-cursor) key) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -615,7 +586,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pset-range ((cursor bdb-secondary-cursor) key) - (declare (optimize (speed 3))) (let ((sc (get-con (cursor-btree cursor)))) (with-buffer-streams (key-buf pkey-buf value-buf) (buffer-write-int (cursor-oid cursor) key-buf) @@ -631,7 +601,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pget-both ((cursor bdb-secondary-cursor) key pkey) - (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor)))) (sc (get-con (cursor-btree cursor)))) @@ -649,7 +618,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pget-both-range ((cursor bdb-secondary-cursor) key pkey) - (declare (optimize (speed 3))) (with-buffer-streams (key-buf pkey-buf value-buf) (let ((primary-oid (oid (primary (cursor-btree cursor)))) (sc (get-con (cursor-btree cursor)))) @@ -668,7 +636,6 @@ (defmethod cursor-delete ((cursor bdb-secondary-cursor)) "Delete by cursor: deletes ALL secondary indices." - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -706,7 +673,6 @@ (error "Puts are forbidden on secondary indices. Try adding to the primary.")) (defmethod cursor-next-dup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) @@ -718,7 +684,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-next-nodup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) @@ -731,7 +696,6 @@ (cursor-first cursor))) (defmethod cursor-prev-nodup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf value-buf) (multiple-value-bind (key val) @@ -744,7 +708,6 @@ (cursor-last cursor))) (defmethod cursor-pnext-dup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -757,7 +720,6 @@ (setf (cursor-initialized-p cursor) nil)))))) (defmethod cursor-pnext-nodup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) @@ -771,16 +733,15 @@ (cursor-pfirst cursor))) (defmethod cursor-pprev-nodup ((cursor bdb-secondary-cursor)) - (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) (with-buffer-streams (key-buf pkey-buf value-buf) (multiple-value-bind (key pkey val) (db-cursor-pmove-buffered (cursor-handle cursor) key-buf pkey-buf value-buf :prev-nodup t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key (get-con (cursor-btree cursor))) + (values t (deserialize key (get-con (cursor-btree cursor))) (deserialize val (get-con (cursor-btree cursor))) - (progn (buffer-read-int pkey) + (progn (buffer-read-int pkey) (deserialize pkey (get-con (cursor-btree cursor))))) (setf (cursor-initialized-p cursor) nil)))) (cursor-plast cursor))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/26 14:41:08 1.16 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/31 20:05:37 1.17 @@ -19,6 +19,8 @@ (in-package :db-bdb) +(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) @@ -61,15 +63,15 @@ ;; Open/close ;; -(defmethod open-controller ((sc bdb-store-controller) &key (recover t) - (recover-fatal nil) (thread t) +(defmethod open-controller ((sc bdb-store-controller) &key (recover nil) + (recover-fatal nil) (thread t) (errfile nil) (deadlock-detect nil)) (let ((env (db-env-create))) - ;; thread stuff? (setf (controller-environment sc) env) + (db-env-set-flags env 0 :auto-commit t) (db-env-open env (namestring (second (controller-spec sc))) - :create t :init-txn t :init-lock t - :init-mpool t :init-log t :thread thread + :create t :init-rep nil :init-mpool t :thread thread + :init-lock t :init-log t :init-txn t :recover recover :recover-fatal recover-fatal ) (db-env-set-timeout env 100000 :set-transaction-timeout t) @@ -99,7 +101,7 @@ (db-bdb::db-set-lisp-dup-compare indices-assoc (controller-serializer-version sc)) (db-set-flags indices-assoc :dup-sort t) (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" - :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) + :auto-commit t :type DB-UNKNOWN :thread thread) ;; :rdonly t) (db-bdb::db-fake-associate btrees indices-assoc :auto-commit t) (let ((db (db-create env))) @@ -134,18 +136,14 @@ (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)) sc))) -;; NOTE: This was the easist way to do this. A BDB hash table would be better -;; and perhaps generally a better thing to export; however I don't want to -;; go through the effort at this time. - -(defparameter *symbol-to-id-table-oid* -3) -(defparameter *id-to-symbol-table-oid* -4) - (defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) (stop-deadlock-detector sc) --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/22 22:22:35 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/31 20:05:37 1.5 @@ -77,80 +77,85 @@ ;; eventually write a macro which generates a custom flag function. ;; -;I don't like the UFFI syntax for enumerations +;; Current header file version required: Berkeley DB 4.5 + +;; I don't like the UFFI syntax for enumerations (defconstant DB-BTREE 1) (defconstant DB-HASH 2) (defconstant DB-RECNO 3) (defconstant DB-QUEUE 4) (defconstant DB-UNKNOWN 5) -(defconstant DB_CREATE #x00000001) (defconstant DB_LOCK_NOWAIT #x00000002) + +(defconstant DB_CREATE #x00000001) (defconstant DB_FORCE #x00000004) -(defconstant DB_NOMMAP #x00000008) -(defconstant DB_RDONLY #x00000010) -(defconstant DB_RECOVER #x00000020) -(defconstant DB_THREAD #x00000040) -(defconstant DB_TRUNCATE #x00000080) -(defconstant DB_TXN_NOSYNC #x00000100) -(defconstant DB_EXCL #x00002000) +(defconstant DB_MULTIVERSION #x00000008) +(defconstant DB_NOMMAP #x00000010) +(defconstant DB_RDONLY #x00000020) +(defconstant DB_RECOVER #x00000040) +(defconstant DB_THREAD #x00000080) +(defconstant DB_TRUNCATE #x00000100) +(defconstant DB_TXN_NOSYNC #x00000200) +(defconstant DB_TXN_NOT_DURABLE #x00000400) +(defconstant DB_TXN_WRITE_NOSYNC #x00000800) + +(defconstant DB_EXCL #x00004000) -(defconstant DB_TXN_NOWAIT #x00002000) -(defconstant DB_TXN_SYNC #x00004000) +(defconstant DB_TXN_NOWAIT #x00004000) +(defconstant DB_TXN_SYNC #x00008000) -(defconstant DB_DUP #x00004000) -(defconstant DB_DUPSORT #x00008000) +(defconstant DB_DUP #x00008000) +(defconstant DB_DUPSORT #x00010000) (defconstant DB_JOINENV #x00000000) -(defconstant DB_INIT_CDB #x00002000) -(defconstant DB_INIT_LOCK #x00004000) -(defconstant DB_INIT_LOG #x00008000) -(defconstant DB_INIT_MPOOL #x00010000) -(defconstant DB_INIT_REP #x00020000) -(defconstant DB_INIT_TXN #x00040000) -(defconstant DB_LOCKDOWN #x00080000) -(defconstant DB_PRIVATE #x00100000) -(defconstant DB_RECOVER_FATAL #x00200000) -(defconstant DB_SYSTEM_MEM #x00800000) -(defconstant DB_AUTO_COMMIT #x01000000) -(defconstant DB_READ_COMMITTED #x02000000) -(defconstant DB_DEGREE_2 #x02000000) ;; DEPRECATED, now called DB_READ_COMMITTED -(defconstant DB_READ_UNCOMMITTED #x04000000) -(defconstant DB_DIRTY_READ #x04000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED - -(defconstant DB_CURRENT 7) -(defconstant DB_FIRST 9) -(defconstant DB_GET_BOTH 10) -(defconstant DB_GET_BOTH_RANGE 12) -(defconstant DB_LAST 17) -(defconstant DB_NEXT 18) -(defconstant DB_NEXT_DUP 19) -(defconstant DB_NEXT_NODUP 20) -(defconstant DB_PREV 25) -(defconstant DB_PREV_NODUP 26) -(defconstant DB_SET 28) -(defconstant DB_SET_RANGE 30) +(defconstant DB_INIT_CDB #x00004000) +(defconstant DB_INIT_LOCK #x00008000) +(defconstant DB_INIT_LOG #x00010000) +(defconstant DB_INIT_MPOOL #x00020000) +(defconstant DB_INIT_REP #x00040000) +(defconstant DB_INIT_TXN #x00080000) +(defconstant DB_LOCKDOWN #x00100000) +(defconstant DB_PRIVATE #x00200000) +(defconstant DB_RECOVER_FATAL #x00400000) +(defconstant DB_REGISTER #x00800000) +(defconstant DB_SYSTEM_MEM #x01000000) +(defconstant DB_AUTO_COMMIT #x02000000) +(defconstant DB_READ_COMMITTED #x04000000) +(defconstant DB_DEGREE_2 #x04000000) ;; DEPRECATED, now called DB_READ_COMMITTED +(defconstant DB_READ_UNCOMMITTED #x08000000) +(defconstant DB_DIRTY_READ #x08000000) ;; DEPRECATED, now called DB_READ_UNCOMMITTED (defconstant DB_AFTER 1) (defconstant DB_BEFORE 3) -(defconstant DB_KEYFIRST 15) -(defconstant DB_KEYLAST 16) +(defconstant DB_CURRENT 6) +(defconstant DB_FIRST 7) +(defconstant DB_GET_BOTH 8) +(defconstant DB_GET_BOTH_RANGE 10) +(defconstant DB_LAST 15) +(defconstant DB_NEXT 16) +(defconstant DB_NEXT_DUP 17) +(defconstant DB_NEXT_NODUP 18) +(defconstant DB_PREV 23) +(defconstant DB_PREV_NODUP 24) +(defconstant DB_SET 25) +(defconstant DB_SET_RANGE 27) + +(defconstant DB_NODUPDATA 19) +(defconstant DB_NOOVERWRITE 20) +(defconstant DB_NOSYNC 21) -(defconstant DB_NODUPDATA 21) -(defconstant DB_NOOVERWRITE 22) -(defconstant DB_NOSYNC 23) - -(defconstant DB_POSITION 24) +(defconstant DB_POSITION 22) (defconstant DB_SEQ_DEC #x00000001) (defconstant DB_SEQ_INC #x00000002) (defconstant DB_SEQ_WRAP #x00000008) -(defconstant DB_SET_LOCK_TIMEOUT 29) -(defconstant DB_SET_TXN_TIMEOUT 33) +(defconstant DB_SET_LOCK_TIMEOUT 26) +(defconstant DB_SET_TXN_TIMEOUT 30) -(defconstant DB_FREELIST_ONLY #x00002000) -(defconstant DB_FREE_SPACE #x00004000) +(defconstant DB_FREELIST_ONLY #x00004000) +(defconstant DB_FREE_SPACE #x00008000) (defconstant DB_KEYEMPTY -30997) (defconstant DB_KEYEXIST -30996) @@ -256,7 +261,7 @@ (documentation nil) (transaction nil)) (let ((wname (if (listp names) (first names) names)) - (fname (if (listp names) (second names) + (fname (if (listp names) (second names) (intern (concatenate 'string "%" (symbol-name names))))) (wrapper-args (make-wrapper-args args flags keys)) (fun-args (make-fun-args args flags)) @@ -480,6 +485,14 @@ :flags (force) :documentation "Make a checkpoint.") +(def-function ("db_set_error_file" %db-set-error-file) + ((db :pointer-void) + (file :cstring))) + +(defun db-set-error-file (db filename) + (with-cstrings ((fname filename)) + (%db-set-error-file db fname))) + ;; Database (eval-when (:compile-toplevel :load-toplevel) @@ -1882,8 +1895,7 @@ :returning :int) (defun next-counter (env db parent key key-size lockid lockid-size) - "Get the next element in the counter. To be deprecated -when 4.3 is released." + "Get the next element in the counter. To be deprecated when 4.3 is released." (let ((ret (%next-counter env db parent key key-size lockid lockid-size))) (if (< ret 0) (error 'db-error :errno ret) --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/22 16:17:43 1.6 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/31 20:05:37 1.7 @@ -56,6 +56,7 @@ */ #include <stdint.h> +#include <stdio.h> #include <string.h> #include <wchar.h> @@ -173,7 +174,7 @@ DB_ENV *db_env_cr(u_int32_t flags, int *errno) { DB_ENV *envp; *errno = db_env_create(&envp, flags); - return envp; + return envp; } char * db_strerr(int error) { @@ -215,6 +216,7 @@ return dbenv->txn_checkpoint(dbenv, kbyte, min, flags); } + /* Database */ DB *db_cr(DB_ENV *dbenv, u_int32_t flags, int *errno) { @@ -265,6 +267,10 @@ return db->get_pagesize(db, pagesizep); } +void db_set_error_file(DB *db, char *filename) { + return db->set_errfile(db, fopen(filename, "w+")); +} + /* Accessors */ /* We manage our own buffers (DB_DBT_USERMEM). */

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 31 Jan '07

31 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv24260/src/elephant Modified Files: collections.lisp controller.lisp serializer2.lisp Log Message: Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/06/19 01:03:30 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/01/31 20:05:38 1.6 @@ -135,7 +135,6 @@ (defmethod remove-kv (key (bt btree-index)) "Remove a key / value from the PRIMARY by a secondary lookup, updating ALL other secondary indices." - (declare (optimize (speed 3))) (remove-kv (get-primary-key key bt) (primary bt))) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/26 14:41:13 1.25 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/31 20:05:38 1.26 @@ -139,7 +139,7 @@ ;; (defclass store-controller () - ((spec :type (or pathname string (simple-array character)) + ((spec :type list :accessor controller-spec :initarg :spec :documentation "Backend create functions should pass in :spec during make-instance") --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/25 18:18:00 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/31 20:05:38 1.7 @@ -20,7 +20,7 @@ (:use :cl :elephant :elephant-memutil) (:import-from :elephant *circularity-initial-hash-size* - *resourced-byte-spec* + #+(or cmu sbcl allegro) get-cached-instance controller-symbol-cache controller-symbol-id-cache

1 0

[elephant-cvs] CVS elephant/src/memutil
by ieslick 31 Jan '07

31 Jan '07

Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv24260/src/memutil Modified Files: memutil.lisp Log Message: Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/01/20 22:12:18 1.14 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2007/01/31 20:05:38 1.15 @@ -82,7 +82,7 @@ (length :int)) :returning :void)) -(eval-when (compile) +(eval-when (:compile-toplevel) (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (inline read-int read-uint read-float read-double

1 0

[elephant-cvs] CVS elephant
by ieslick 31 Jan '07

31 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv24260 Modified Files: TODO ele-bdb.asd Log Message: Upgrade to BDB 4.5; green on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/TODO 2007/01/25 18:17:59 1.37 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/31 20:05:37 1.38 @@ -7,14 +7,13 @@ -------------------------------------------- Active tasks: -- Speed up symbol storage and reference using symbol id's - - Fast symbols are property tag in DB (so code doesn't corrupt DB) - 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 - Provide support for fast and slow critical sections by lisps: buffer-streams, circularity-arrays/hashes, shared controller side-effects... (see email) @@ -69,6 +68,7 @@ - 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 @@ -81,8 +81,6 @@ - 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? -- Allow dump of fast-symbol tables for low-level reconstruction in case of - catastrophic errors Documentation: - Migrate code base to SVN and create tickets in TRAC @@ -99,7 +97,6 @@ January 22, 2006 checkins: x Modularize serializers for easy upgrade -x Implement backend support for symbol-table protocol 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! --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/21 21:20:03 1.15 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/31 20:05:37 1.16 @@ -63,7 +63,6 @@ (:bdb-c-source "libberkeley-db") (:file "berkeley-db") (:file "bdb-controller") - (:file "bdb-symbol-tables") (:file "bdb-slots") (:file "bdb-collections") (:file "bdb-transactions"))

1 0

[elephant-cvs] CVS elephant
by ieslick 29 Jan '07

29 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv26676 Modified Files: elephant.asd Log Message: Build support for 64-bit compilation or OpenMCL 1.1 on OS X --- /project/elephant/cvsroot/elephant/elephant.asd 2007/01/25 18:17:59 1.24 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/01/29 15:15:04 1.25 @@ -109,6 +109,7 @@ (list #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" + #+(or x8664-target) "-arch x86_64" "-Wall" "-fPIC" "-O3"

1 0

[elephant-cvs] CVS elephant/src/elephant
by rread 26 Jan '07

26 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv22773/src/elephant Modified Files: backend.lisp controller.lisp serializer.lisp Log Message: Repairing the use of the serializer for the SQL side --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/01/25 19:37:53 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/01/26 14:41:13 1.7 @@ -39,6 +39,7 @@ #:*elephant-code-version* #:store-controller #:open-controller + #:database-version #:close-controller #:controller-serialize #:controller-deserialize @@ -95,6 +96,7 @@ #:*elephant-code-version* #:store-controller #:open-controller + #:database-version #:close-controller #:controller-serialize #:controller-deserialize @@ -136,4 +138,4 @@ #:register-backend-con-init #:lookup-backend-con-init )) - \ No newline at end of file + --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/25 19:37:53 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/26 14:41:13 1.25 @@ -112,8 +112,9 @@ (assert (consp spec)) (setq *store-controller* (get-controller spec)) (load-user-configuration *store-controller*) + (apply #'open-controller *store-controller* args) (initialize-serializer *store-controller*) - (apply #'open-controller *store-controller* args)) + ) (defun close-store (&optional sc) "Conveniently close the store controller." @@ -178,24 +179,7 @@ (setf (controller-serialize sc) 'elephant-serializer2::serialize) (setf (controller-deserialize sc) 'elephant-serializer2::deserialize)))) -;; -;; VERSIONING -;; -(defmethod database-version ((sc 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 (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 (controller-version-cached sc) (read stream))) - (with-open-file (stream path :direction :output) - (setf (controller-version-cached sc) - (write *elephant-code-version* :stream stream)))))))) (defun prior-version-p (v1 v2) "Is v1 an equal or earlier version than v2" @@ -258,6 +242,15 @@ (intern (string-upcase (cdr name)) (car name))) + +;; +;; VERSIONING +;; + +(defgeneric database-version (sc) + (:documentation "Backends implement this to store the serializer version") + ) + ;; ;; STORE CONTROLLER PROTOCOL ;; --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/21 21:20:04 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/26 14:41:13 1.18 @@ -36,19 +36,24 @@ (with-buffer-streams (out-buf) (cl-base64::usb8-array-to-base64-string (elephant-memutil::buffer-read-byte-vector - (serialize x out-buf sc))))) + (serialize x out-buf sc))) + ) +) (defun convert-buffer-to-base64-string (bs sc) (declare (ignore sc)) (cl-base64::usb8-array-to-base64-string - (elephant-memutil::buffer-read-byte-vector bs))) + (elephant-memutil::buffer-read-byte-vector bs) +) +) (defun deserialize-from-base64-string (x sc) (with-buffer-streams (other) (deserialize (elephant-memutil::buffer-write-byte-vector other - (cl-base64::base64-string-to-usb8-array x)) + (cl-base64::base64-string-to-usb8-array x) + ) sc) ))

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by rread 26 Jan '07

26 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv22773/src/db-clsql Modified Files: sql-collections.lisp sql-controller.lisp Log Message: Repairing the use of the serializer for the SQL side --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/01/19 21:03:30 1.7 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-collections.lisp 2007/01/26 14:41:08 1.8 @@ -27,19 +27,17 @@ ;; Somehow I suspect that what I am getting back here ;; is actually the main key... - (let* ((sc (get-con bt)) - (con (controller-db sc))) - (let ((pk (sql-get-from-clcn (oid bt) key sc con))) + (let* ((sc (get-con bt))) + (let ((pk (sql-get-from-clcn (oid bt) key sc))) (if pk - (sql-get-from-clcn (oid (primary bt)) pk sc con)) + (sql-get-from-clcn (oid (primary bt)) pk sc)) ))) (defmethod get-primary-key (key (bt sql-btree-index)) (declare (optimize (speed 3))) (let* ((sc (get-con bt)) - (con (controller-db sc)) ) - (sql-get-from-clcn (oid bt) key sc con))) + (sql-get-from-clcn (oid bt) key sc))) ;; My basic strategy is to keep track of a current key @@ -321,9 +319,8 @@ (let* ((cur-pk (aref (:sql-crsr-ks cursor) (:sql-crsr-ck cursor))) (sc (get-con (cursor-btree cursor))) - (con (controller-db sc)) (indexed-pk (sql-get-from-clcn-nth (cursor-oid cursor) cur-pk - sc con + sc (:dp-nmbr cursor)))) (if indexed-pk (let ((v (get-value indexed-pk (primary (cursor-btree cursor))))) @@ -533,8 +530,7 @@ (setf (:dp-nmbr cursor) (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) - (controller-db (get-con (cursor-btree cursor))) - + (get-con (cursor-btree cursor)) )))) (has-key-value-scnd cursor :returnpk returnpk)) (cursor-last-x cursor :returnpk returnpk))) @@ -600,7 +596,7 @@ (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) - (controller-db (get-con (cursor-btree cursor))) + (get-con (cursor-btree cursor)) ) 1)) (assert (>= (:dp-nmbr cursor) 0)) @@ -621,7 +617,7 @@ (setf (:dp-nmbr cursor) (- (sql-get-from-clcn-cnt (cursor-oid cursor) (get-current-key cursor) - (controller-db (get-con (cursor-btree cursor))) + (get-con (cursor-btree cursor)) ) 1)) (has-key-value-scnd cursor :returnpk returnpk)) (cursor-last-x cursor :returnpk returnpk))) --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/11/11 18:41:11 1.12 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2007/01/26 14:41:08 1.13 @@ -59,33 +59,29 @@ ) (defmethod get-value (key (bt sql-btree)) - (let* ((sc (get-con bt)) - (con (controller-db sc))) - (sql-get-from-clcn (oid bt) key sc con) + (let* ((sc (get-con bt))) + (sql-get-from-clcn (oid bt) key sc) ) ) (defmethod (setf get-value) (value key (bt sql-btree)) - (let* ((sc (get-con bt)) - (con (controller-db sc))) - (sql-add-to-clcn (oid bt) key value sc con) + (let* ((sc (get-con bt))) + (sql-add-to-clcn (oid bt) key value sc) ) ) (defmethod existsp (key (bt sql-btree)) - (let* ((sc (get-con bt)) - (con (controller-db sc))) - (sql-from-clcn-existsp (oid bt) key con) + (let* ((sc (get-con bt))) + (sql-from-clcn-existsp (oid bt) key sc) ) ) (defmethod remove-kv (key (bt sql-btree)) - (let* ((sc (get-con bt)) - (con (controller-db sc))) + (let* ((sc (get-con bt))) (sql-remove-one-from-clcn (oid bt) key sc - con)) + )) ) @@ -129,8 +125,7 @@ ) (defmethod add-index ((bt sql-indexed-btree) &key index-name key-form populate) - (let* ((sc (get-con bt)) - (con (controller-db sc))) + (let* ((sc (get-con bt))) (if (and (not (null index-name)) (symbolp index-name) (or (symbolp key-form) (listp key-form))) (let ((indices (indices bt)) @@ -146,15 +141,15 @@ #'(lambda (k v) (multiple-value-bind (index? secondary-key) (funcall key-fn index k v) -;; This is a slow, DB cycle intensive operation. It could chunked somehow, -;; I think, probably making it 10 times faster. + ;; This is a slow, DB cycle intensive operation. It could chunked somehow, + ;; I think, probably making it 10 times faster. (when index? (unless (sql-from-clcn-key-and-value-existsp - (oid index) secondary-key k con) + (oid index) secondary-key k sc) (sql-add-to-clcn (oid index) secondary-key k - sc con :insert-only t)) + sc :insert-only t)) ))) bt)))) index) @@ -163,7 +158,6 @@ (defmethod (setf get-value) (value key (bt sql-indexed-btree)) "Set a key / value pair, and update secondary indices." (let* ((sc (get-con bt)) - (con (controller-db sc)) (indices (indices-cache bt))) (with-transaction (:store-controller sc) (maphash @@ -174,15 +168,15 @@ (when index? ;; This duplicates values that are already there... (unless (sql-from-clcn-key-and-value-existsp - (oid index) secondary-key key con) + (oid index) secondary-key key sc) (sql-add-to-clcn (oid index) secondary-key key - sc con :insert-only t)) + sc :insert-only t)) ))) indices) ;; Now we place the actual value - (sql-add-to-clcn (oid bt) key value sc con) + (sql-add-to-clcn (oid bt) key value sc) ) value)) @@ -191,7 +185,7 @@ (declare (optimize (speed 3))) (let* ( (sc (get-con bt)) - (con (controller-db sc))) + ) (with-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value @@ -209,13 +203,13 @@ (sql-remove-key-and-value-from-clcn (oid index) secondary-key key - con) + sc) ;; And furthermore, we have to remove the index entry ;; (remove-kv secondary-key index) ))) indices) ;; Now we place the actual value - (sql-remove-from-clcn (oid bt) key sc con)) + (sql-remove-from-clcn (oid bt) key sc)) ) value)))) @@ -233,6 +227,22 @@ ;; way to recover from that automatically. If it ;; does not exist, return nil so we can create it later! + +(defun version-table-exists (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! + (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] + '( + ([serializerversion] text :not-null) + ) :database con + ) + ) + ;; These functions are probably not cross-database portable... (defun keyvalue-table-exists (con) ;; we want to use ":owner :all" because we don't really care who created @@ -240,6 +250,7 @@ (clsql:table-exists-p [keyvalue] :database con :owner :all) ) + ;; This is just an initial version; it is possible that ;; we might someday wish to use blobs instead; certainly, I am ;; storing blobs now in the Berkeley-db and we meed to make sure @@ -260,12 +271,15 @@ ;; ALL OF THIS needs to be inside a transaction. (clsql::create-table [keyvalue] - '( - ([clctn_id] integer :not-null) - ([key] text :not-null) - ([value] text) - ) :database con - ) + + ;; 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)") @@ -278,22 +292,46 @@ ;;) ;; (unless (index-exists-p [idx_clctn_id]) (clsql::create-index [idx_clctn_id] :on [keyvalue] - :attributes '([clctn_id]) - :database con) + :attributes '([clctn_id]) + :database con) ;; ) ;; (unless (index-exists-p [idx_key]) (clsql::create-index [idx_key] :on [keyvalue] - :attributes '([key]) - :database con) + :attributes '([key]) + :database con) ;;) ;; This is actually unique ;; (unless (index-exists-p [idx_both]) (clsql:create-index [idx_both] :on [keyvalue] - :attributes '([clctn_id] [key]) - :database con) + :attributes '([clctn_id] [key]) + :database con) ;;) ) +(defmethod database-version ((sc sql-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* ((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) + ) + ))))) + + (defmethod open-controller ((sc sql-store-controller) ;; At present these three have no meaning &key @@ -304,14 +342,18 @@ (the sql-store-controller (let* ((dbtype (car (second (controller-spec sc)))) (con (clsql:connect (cdr (second (controller-spec sc))) - :database-type dbtype - :if-exists :old))) + :database-type dbtype + :if-exists :old))) (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) (with-transaction (:store-controller sc) (create-keyvalue-table con))) + (unless (version-table-exists con) + (with-transaction (:store-controller sc) + (create-version-table con))) + (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)) @@ -322,7 +364,7 @@ (defmethod reconnect-controller ((sc sql-store-controller)) (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 @@ -337,7 +379,7 @@ (defmethod next-oid ((sc sql-store-controller )) (let ((con (controller-db sc))) (clsql:sequence-next [persistent_seq] - :database con)) + :database con)) ) ;; if add-to-root is a method, then we can make it class dependent... @@ -348,39 +390,39 @@ ;; a proper method myself, but I will give it a name so it doesn't ;; conflict with 'add-to-root. 'add-to-root can remain a convenience symbol, ;; that will end up calling this routine! -(defun sql-add-to-root (key value pgsc con) - (sql-add-to-clcn 0 key value pgsc con) +(defun sql-add-to-root (key value sc) + (sql-add-to-clcn 0 key value sc) ) -(defun sql-add-to-clcn (clcn key value sc con - &key (insert-only nil)) +(defun sql-add-to-clcn (clcn key value sc + &key (insert-only nil)) (declare (ignore sc)) (assert (integerp clcn)) - (let ( + (let ((con (controller-db sc)) (vbs - (serialize-to-base64-string value)) + (serialize-to-base64-string value sc)) (kbs - (serialize-to-base64-string key)) + (serialize-to-base64-string key sc)) ) - (if (and (not insert-only) (sql-from-clcn-existsp clcn key con)) + (if (and (not insert-only) (sql-from-clcn-existsp clcn key sc)) (clsql::update-records [keyvalue] - :av-pairs `((key ,kbs) - (clctn_id ,clcn) - (value ,vbs)) - :where [and [= [clctn_id] clcn] [= [key] kbs]] - :database con) + :av-pairs `((key ,kbs) + (clctn_id ,clcn) + (value ,vbs)) + :where [and [= [clctn_id] clcn] [= [key] kbs]] + :database con) (clsql::insert-records :into [keyvalue] - :attributes '(key clctn_id value) - :values (list kbs clcn vbs) - :database con - )) + :attributes '(key clctn_id value) + :values (list kbs clcn vbs) + :database con + )) ) value ) -(defun sql-get-from-root (key sc con) - (sql-get-from-clcn 0 key sc con) +(defun sql-get-from-root (key sc) + (sql-get-from-clcn 0 key sc) ) ;; This is a major difference betwen SQL and BDB: @@ -399,22 +441,29 @@ ;; To do that I have to read in all of the values and deserialized them ;; This could be a good reason to keep the oids out, and separte, in ;; a separate column. -(defun sql-get-from-clcn (clcn key sc con) +(defun sql-get-from-clcn (clcn key sc) (assert (integerp clcn)) - (sql-get-from-clcn-nth clcn key sc con 0) + (sql-get-from-clcn-nth clcn key sc 0) ) -(defun sql-get-from-clcn-nth (clcn key sc con n) +(defun sql-get-from-clcn-nth (clcn key sc n) (assert (and (integerp clcn) (integerp n))) - (let* ( + (let* ((con (controller-db sc)) (kbs - (serialize-to-base64-string key)) + (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 " + clcn + kbs + n)) (tuples - (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; ;; this isn't a very good way to do things... ;; Note also that this will be extremely inefficient if @@ -424,95 +473,101 @@ ;; 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 sc)) + (deserialize-from-base64-string (car x) sc)) tuples) #'my-generic-less-than)) t) (values nil nil)))) -(defun sql-get-from-clcn-cnt (clcn key con) +(defun sql-get-from-clcn-cnt (clcn key sc) (assert (integerp clcn)) - (let* ( - (kbs (serialize-to-base64-string key)) + (let* ((con (controller-db sc)) + (kbs (serialize-to-base64-string key sc)) (tuples (clsql::select [count [value]] - :from [keyvalue] [244 lines skipped]

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by rread 26 Jan '07

26 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv22773/src/db-bdb Modified Files: bdb-controller.lisp Log Message: Repairing the use of the serializer for the SQL side --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/19 21:03:29 1.15 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/01/26 14:41:08 1.16 @@ -271,4 +271,20 @@ :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))))))))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv11335/src/elephant Modified Files: backend.lisp controller.lisp Log Message: Minor fixes for symbol id removal checkin --- /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2006/12/16 19:35:10 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/backend.lisp 2007/01/25 19:37:53 1.6 @@ -79,9 +79,6 @@ #:register-backend-con-init #:lookup-backend-con-init ) - (:import-from :elephant-serializer2 - #:serialize-symbol-complete - ) (:export ;; Variables #:*cachesize* --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/25 18:18:00 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/25 19:37:53 1.24 @@ -164,9 +164,8 @@ ;; User configuration parameters for the controller (defun load-user-configuration (controller) - ;; Fast symbols - (setf (controller-fast-symbols-p controller) - (elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant)))) + ;; Placeholder + nil) (defun initialize-serializer (sc) "Establish serializer version on controller startup"

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv11335/tests Modified Files: testindexing.lisp Log Message: Minor fixes for symbol id removal checkin --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/01/22 16:17:44 1.20 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/01/25 19:37:55 1.21 @@ -371,6 +371,8 @@ (defvar normal-index nil) +(defgeneric stress1 (obj)) + (defun make-stress-classes () (defclass stress-normal () ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil)

1 0

[elephant-cvs] CVS elephant
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv27212 Modified Files: INSTALL TODO config.sexp elephant.asd Log Message: Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes --- /project/elephant/cvsroot/elephant/INSTALL 2006/11/11 18:41:10 1.19 +++ /project/elephant/cvsroot/elephant/INSTALL 2007/01/25 18:17:59 1.20 @@ -3,10 +3,10 @@ Requirements ------------ -Support Lisps: +Supported Lisps: CMUCL 19a Linux -SBCL 0.9.6/0.9.9 Linux / Mac OSX -Allegro CL 6.2/7.0/8.0 Linux / Mac OSX +SBCL 0.9.17/1.0+ Linux / Mac OSX +Allegro CL 7.0/8.0 Linux / Mac OSX OpenMCL 0.14.2 LispWorks (port in-progress) @@ -14,14 +14,12 @@ ASDF - http://www.cliki.net/asdf UFFI 1.5.4+ - http://uffi.b9.com/ -Backends: -1) Sleepycat Berkeley DB 4.3 - http://www.sleepycat.com -2) CLSQL - http://clsql.b9.com/ - And an appropriate SQL installation. +A Backend Database: +1) Oracle Berkeley DB 4.4 or 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 -A C compiler, probably gcc or Visual Studio. Presumably you -have this if you installed Sleepycat. +A C compiler, probably gcc or Visual Studio. Presumably you have this if you installed ------------------ Short Instructions @@ -35,10 +33,10 @@ Then: (open-store '(<backend> <spec>)) Where <backend> = { :bdb | :clsql } - <spec> = { '(:sqlite3 "db path") | '(:postgresql "db path") | "bdb directory" } + <spec> = { "fresh directory for BDB files" | '(:sqlite3 "db path") | '(:postgresql "db path") -This should load all files, including compiling libraries, on -most systems. For Win32, see the instructions below. +This should load all files, including compiling libraries, on most +systems. For Win32, see the instructions below. (We'll improve the build process for Win32 if there is demand) @@ -46,18 +44,18 @@ Long Instructions ----------------- -For SBCL, CMUCL, Allegro 7.0+, MCL and CLISP: +For SBCL, CMUCL, Allegro 8.0+, MCL and CLISP: 0) Unpack Elephant. I put mine in the directory -/usr/local/share/common-lisp/elephant-0.6/ +/usr/local/share/common-lisp/elephant-0.6.x/ 1) Install ASDF. Ensure that you have a recent version of ASDF installed as the load process now depends upon it. -2) Install UFFI. +2) Install UFFI 3) Install a backend: Either Berkeley DB 4.4, PostGresql, or SQLite 3. @@ -78,11 +76,11 @@ Under Un*x, you may actually already have this installed, though it may be compiled with funny options, so if things don't work you may want to try to start from scratch. FreeBSD has a port -for this, as I'm sure do other BSDs (including Darwin/Fink.) +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/BerekleyDB.4.4/lib/libdb.so and - /usr/local/BerekleyDB.4.4/include/db.h, or + /usr/local/BerkeleyDB.4.4/lib/libdb.so and + /usr/local/BerkeleyDB.4.4/include/db.h, or /usr/local/lib/db44/libdb.so and /usr/local/include/db44/db.h.) @@ -95,6 +93,7 @@ of the Berkeley DB distribution :berkeley-db-root, the library to load :berkeley-db-lib and the pthreads library if you're running linux :pthread-lib. + For Win32 (directions courtesy of Bill Clementson): --------------------------------------------------- Create an MSVC dll project and add src/db-bdb/libberkeley-db.c, @@ -176,6 +175,11 @@ This should take less than 5 minutes on decent hardware. +The tests are not idempotent, so if you run the tests a second time, +they are likely to fail. To avoid this, for example if you are +debugging tests, just run the script delscript.sh (or do the +equivalent on Win32) in the elephant/tests directory. + Elephant allows migration between repositories. To test this: (do-migration-tests *default-spec* <backend>) --- /project/elephant/cvsroot/elephant/TODO 2007/01/22 23:11:08 1.36 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/25 18:17:59 1.37 @@ -8,20 +8,26 @@ Active tasks: - Speed up symbol storage and reference using symbol id's + - Fast symbols are property tag in DB (so code doesn't corrupt DB) - Full 64-bit support (arrays, native 64-bit fixnums, etc) - - char vs. uint8 in buffer-stream - - flexible handling of 64-bit fixnums + - 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 - - Fast and slow critical sections by lisp -- Think about dynamic vs. object based store & transaction resolution? + - 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 -- Make elephant threads appropriately bind dynamic variables? +- 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 -- Update to require BDB 4.5? - Throw condition when store spec is invalid, etc +- Test with BDB 4.5? BDB Features: ? Determine how to detect deadlock conditions as an optional run-safe mode? --- /project/elephant/cvsroot/elephant/config.sexp 2007/01/20 22:12:17 1.3 +++ /project/elephant/cvsroot/elephant/config.sexp 2007/01/25 18:17:59 1.4 @@ -2,8 +2,7 @@ (:berkeley-db-lib-dir . "/opt/local/lib/db44/") (:berkeley-db-lib . "/usr/local/BerkeleyDB.4.4/lib/libDB-4.4.dylib") (:pthread-lib . nil) - (:clsql-lib . nil) - (:fast-symbols . nil)) + (:clsql-lib . nil)) ;; Typical pthread settings are: /lib/tls/libpthread.so.0 ;; nil means that the library in question is not loaded --- /project/elephant/cvsroot/elephant/elephant.asd 2007/01/21 21:20:03 1.23 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/01/25 18:17:59 1.24 @@ -107,8 +107,8 @@ (unless (and input-file output-file) (error "Must specify both input and output files")) (list - #-(or darwin macosx) "-shared" - #+(or darwin macosx) "-bundle" + #-(or darwin macosx darwin-host) "-shared" + #+(or darwin macosx darwin-host) "-bundle" "-Wall" "-fPIC" "-O3"

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv27212/src/db-bdb Modified Files: bdb-symbol-tables.lisp Log Message: Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/22 22:22:35 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/25 18:18:00 1.3 @@ -26,38 +26,37 @@ (serialize-symbol-complete symbol keybuf) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) - (if buf (values (buffer-read-int buf) T) - (values (create-persistent-symbol sc symbol keybuf valbuf) t))))) - -(defun create-persistent-symbol (sc symbol keybuf valbuf) - "Takes an symbol->id table + symbol keybuf, allocates an ID and updates - the persistent tables." - (reset-buffer-stream valbuf) ;; Just to avoid any contamination -;; (with-transaction (:txn-nosync t :dirty-read t) -;; (format t "getting next symid") - (let ((id (next-symid sc))) ;; allocate a new unique id + (if buf + (values (buffer-read-int buf) t) + (values (create-persistent-symbol-id sc symbol) t))))) + +(defun create-persistent-symbol-id (sc symbol) + "Allocates an ID and updates persistent tables" + (let ((id (next-symid sc))) ;; Update symbol->id table -;; (format t "Writing sym->id: ~A -> ~A~%" symbol id) - (buffer-write-int id valbuf) -;; (format t "Putting id into table location~%") - (db-put-buffered (controller-btrees sc) keybuf valbuf - :auto-commit *auto-commit*) + (with-buffer-streams (keybuf valbuf) +;; (format t "Writing sym->id: ~A -> ~A~%" symbol id) + (buffer-write-int *symbol-to-id-table-oid* keybuf) + (serialize-symbol-complete symbol keybuf) + (buffer-write-int id valbuf) +;; (format t "Putting it into table location~%") + (db-put-buffered (controller-btrees sc) keybuf valbuf)) ;; Write id->symbol table - (reset-buffer-stream keybuf) - (reset-buffer-stream valbuf) -;; (format t "Writing id->sym: ~A -> ~A~%" id symbol) - (buffer-write-int *id-to-symbol-table-oid* keybuf) - (buffer-write-int id keybuf) - (serialize-symbol-complete symbol valbuf) - (db-put-buffered (controller-btrees sc) keybuf valbuf - :auto-commit *auto-commit*) - id) -;; ) - ) + (with-buffer-streams (keybuf valbuf) +;; (format t "Writing id->sym: ~A -> ~A~%" id symbol) + (buffer-write-int *id-to-symbol-table-oid* keybuf) +;; (buffer-write-byte elephant-serializer2::+fixnum32+ keybuf) +;; (buffer-write-int id keybuf) + (serialize id keybuf sc) + (serialize-symbol-complete symbol valbuf) +;; (format t "Putting it into table location~%") + (db-put-buffered (controller-btrees sc) keybuf valbuf)) +;; (format t "Done") + id)) (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id) - "Lookup the ID associated with a symbol" + "Lookup the symbol associated with this id" (with-buffer-streams (keybuf valbuf) ;; (format t "Looking up: ~A~%" id) (buffer-write-int *id-to-symbol-table-oid* keybuf)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv27212/src/elephant Modified Files: controller.lisp serializer2.lisp unicode2.lisp Log Message: Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/22 23:11:08 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/25 18:18:00 1.23 @@ -151,14 +151,10 @@ (class-root :reader controller-class-root :documentation "This should be a persistent indexed btree instantiated by the backend") ;; Upgradable serializer strategy - (version :accessor controller-version-cached :initform nil) + (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) - ;; Symbol ID caches - (symbol-cache :accessor controller-symbol-cache :initform (make-hash-table :size 2000)) - (symbol-id-cache :accessor controller-symbol-id-cache :initform (make-hash-table :size 2000)) - (fast-symbols :accessor controller-fast-symbols-p :initform nil) ) (:documentation "Class of objects responsible for the book-keeping of holding DB @@ -443,21 +439,6 @@ ;; (defmethod clear-agents (agent) ;; (setf *agencies* nil)) - -;; -;; Support for serialization efficiency -;; - -(defgeneric lookup-persistent-symbol-id (sc symbol) - (:documentation "Return an ID for the provided symbol. This function is - a callback for the serializer that the backends share in - most cases.")) - -(defgeneric lookup-persistent-symbol (sc id) - (:documentation "Return a symbol for the ID. This should always succeed. - The database should not use the existing serializer to perform - this function; but memutils and unicode are available")) - ;; ;; Low-level support for metaclass protocol ;; --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/22 23:11:08 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/25 18:18:00 1.6 @@ -64,7 +64,7 @@ (defconstant +symbol+ 13) ;; Cached symbol references -(defconstant +symbol-id+ 14) +;; (defconstant +reserved+ 14) ;; stored by id+classname (defconstant +persistent+ 15) @@ -115,7 +115,7 @@ (vector-push-extend hash *circularity-hash-queue*))) ;; -;; Circularity Hash for Serializer +;; Circularity Hash for Deserializer ;; (defparameter *circularity-vector-queue* (make-array 20 :fill-pointer 0 :adjustable t) @@ -146,7 +146,8 @@ (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." - (declare (type buffer-stream bs)) + (declare (type buffer-stream bs) + (ignorable sc)) (let ((*lisp-obj-id* -1) (*circularity-hash* (get-circularity-hash))) (labels @@ -154,15 +155,23 @@ (incf *lisp-obj-id*)) (%serialize (frob) (etypecase frob - (symbol - (serialize-symbol frob bs sc)) - (string - (serialize-string frob bs)) ((integer #.most-negative-fixnum #.most-positive-fixnum) (buffer-write-byte +fixnum32+ bs) (buffer-write-int frob bs)) (null (buffer-write-byte +nil+ bs)) + (symbol + (let ((sym-name (symbol-name frob))) + (declare (type string sym-name) + (dynamic-extent sym-name)) + (buffer-write-byte +symbol+ bs) + (serialize-string sym-name bs) + (let ((package (symbol-package frob))) + (if package + (serialize-string (package-name package) bs) + (buffer-write-byte +nil+ bs))))) + (string + (serialize-string frob bs)) (persistent (buffer-write-byte +persistent+ bs) (buffer-write-int (oid frob) bs) @@ -199,23 +208,7 @@ (loop for item in svs do (%serialize item))))))) (integer - (let* ((num (abs frob)) - (word-size (ceiling (/ (integer-length num) 32))) - (needed (* word-size 4))) - (declare (type fixnum word-size needed)) - (if (< frob 0) - (buffer-write-byte +negative-bignum+ bs) - (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! - ;; 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)))) + (serialize-bignum frob bs)) (rational (buffer-write-byte +rational+ bs) (%serialize (numerator frob)) @@ -298,17 +291,31 @@ (release-circularity-hash *circularity-hash*) bs))) -(defun slots-and-values (o) - (loop for sd in (compute-slots (class-of o)) - for slot-name = (slot-definition-name sd) - with ret = () - do - (when (and (slot-boundp o slot-name) - (eq :instance - (slot-definition-allocation sd))) - (push (slot-value o slot-name) ret) - (push slot-name ret)) - finally (return ret))) +(defun serialize-bignum (frob bs) + "Serialize bignum to buffer stream" + (declare (type integer frob) + (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)) + (if (< frob 0) + (buffer-write-byte +negative-bignum+ bs) + (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! + ;; 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)))) + +;;; +;;; DESERIALIZER +;;; (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." @@ -343,8 +350,6 @@ (if package (intern name (find-package package)) (make-symbol name)))) - ((= tag +symbol-id+) - (deserialize-symbol-id (buffer-read-int bs) sc)) ((= tag +persistent+) (get-cached-instance sc (buffer-read-fixnum bs) @@ -462,61 +467,4 @@ with num integer = 0 do (setq num (dpb (buffer-read-uint bs) byte-spec num)) - finally (return (if positive num (- num))))) - -;; -;; Symbol cache -;; - -(defun serialize-symbol (symbol bs sc) - "Serialize a symbol by recording its ID" - (declare (type buffer-stream bs) - (type symbol symbol) - (type store-controller sc)) - (if (controller-fast-symbols-p sc) - (let ((id (lookup-id symbol sc))) - (declare (type fixnum id)) - (buffer-write-byte +symbol-id+ bs) - (buffer-write-int id bs)) - (serialize-symbol-complete symbol bs))) - -(defun lookup-id (symbol sc) - "Find an id for a symbol or create a new one" - (declare (type symbol symbol)) - (let ((id (gethash symbol (controller-symbol-id-cache sc)))) - (declare (type fixnum id)) - (if id id - (let ((pid (lookup-persistent-symbol-id sc symbol))) - (setf (gethash symbol (controller-symbol-id-cache sc)) pid) - (setf (gethash pid (controller-symbol-cache sc)) symbol) - pid)))) - -(defun serialize-symbol-complete (symbol bs) - "To be called by backends to serialize the string - instead of the ID as they implement the - persistent symbol table" - (declare (type symbol symbol) - (type buffer-stream bs)) - (let ((sym-name (symbol-name symbol))) - (declare (type string sym-name) - (dynamic-extent sym-name)) - (buffer-write-byte +symbol+ bs) - (serialize-string sym-name bs) - (let ((package (symbol-package symbol))) - (if package - (serialize-string (package-name package) bs) - (buffer-write-byte +nil+ bs))))) - -(defun deserialize-symbol-id (id sc) - "Deserialize a symbol ID by finding it in the cache" - (declare (type fixnum id)) - (let ((symbol (gethash id (controller-symbol-cache sc)))) - (if symbol symbol - (let ((symbol (lookup-persistent-symbol sc id))) - (if symbol - (progn - (setf (gethash id (controller-symbol-cache sc)) symbol) - (setf (gethash symbol (controller-symbol-id-cache sc)) id) - symbol) - (error "Symbol lookup foobar! ID referred to does not exist in database")))))) - + finally (return (if positive num (- num))))) \ No newline at end of file --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/01/25 18:18:00 1.2 @@ -39,7 +39,7 @@ ;; 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)) - ;; Actualy code pages > 0 are rare; so we can pay an extra cost + ;; 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) (serialize-to-utf32le string bstream)))))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 25 Jan '07

25 Jan '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv27212/tests Modified Files: elephant-tests.lisp Log Message: Symbol ID hack removed from BDB; Allegro/MacOS/x86 passes --- /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2006/11/11 18:41:11 1.21 +++ /project/elephant/cvsroot/elephant/tests/elephant-tests.lisp 2007/01/25 18:18:00 1.22 @@ -216,3 +216,71 @@ `(values ,@(loop for form in forms collect `(is-not-null ,form)))) + + +(defpclass performance-test () + ((slot1-is-a-test-slot :accessor perfslot1 :initarg :s1 :initform 1) + (slot2-is-a-really-long-symbol :accessor perfslot2 :initarg :s2 :initform 2) + (slot3-is-so-long-we-shouldnt-even-talk-about-it-lest-we-die :accessor perfslot3 :initarg :s3 :initform 3))) + +(defun performance-test () + (let ((a (make-array 500)) + (b (make-array 500 :element-type 'fixnum))) + + (loop for j from 0 to 20 do + (with-transaction () + (loop for i from 0 below 500 do + (setf (aref a i) (make-instance 'performance-test :s1 10 :s2 20 :s3 30)))) + (with-transaction () + (loop for i from 0 below 500 do + (setf (perfslot2 (aref a i)) 30) + (setf (aref b i) (+ (* (perfslot2 (aref a i)) + (perfslot3 (aref a i))) + (perfslot1 (aref a i)))))) + (every (lambda (elt) (= elt 910)) b)))) + + +(defun serializer-performance-test () + (elephant-memutil::with-buffer-streams (key val) + (loop for i from 0 upto 1000000 do + (serialize 'persistent-symbol-test key *store-controller*) + (deserialize key *store-controller*) + (elephant-memutil::reset-buffer-stream key)))) + +(defun slot-access-test () + (let ((pt (make-instance 'performance-test)) + (var 0)) + (loop for i from 0 upto 1000000 do + (setq var (perfslot1 pt))))) + +(defclass simple-class () + ((slot1 :accessor slot1 :initform 20) + (slot-number-two :accessor slot2 :initform "This is a test") + (slot3 :accessor slot3 :initform 'state-is-idle) + (slot4 :accessor slot4 :initform 'test))) + +(defun regular-class-test (sc) + (let ((src (make-array 500)) + (targ (make-array 500)) + (bt (make-btree sc))) + (loop for i from 0 below 500 do + (setf (aref src i) + (make-instance 'simple-class))) + (time + (loop for j from 0 upto 20 do + (with-transaction (:store-controller sc) + (loop for elt across src + for i from 0 do + (setf (get-value i bt) elt))) + (with-transaction (:store-controller sc) + (loop for elt across src + for i from 0 do + (setf (aref targ i) (get-value i bt)))))))) + +(defun serializer-stdclass-test () + (let ((inst (make-instance 'simple-class))) + (elephant-memutil::with-buffer-streams (key val) + (loop for i from 0 upto 100000 do + (serialize inst key *store-controller*) + (deserialize key *store-controller*) + (elephant-memutil::reset-buffer-stream key)))))

1 0

[elephant-cvs] CVS elephant
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv9131 Modified Files: TODO Log Message: Where did bdb-slots go? --- /project/elephant/cvsroot/elephant/TODO 2007/01/22 16:17:43 1.35 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/22 23:11:08 1.36 @@ -7,12 +7,12 @@ -------------------------------------------- Active tasks: -- Enable and verify symbol-id strategy +- Speed up symbol storage and reference using symbol id's - Full 64-bit support (arrays, native 64-bit fixnums, etc) - char vs. uint8 in buffer-stream - flexible handling of 64-bit fixnums - -Multi-threading support and multiple-store cleanup: +- Ensure serialization is thread-safe and reasonably efficient + - Fast and slow critical sections by lisp - Think about dynamic vs. object based store & transaction resolution? - Perform error checking when mixed - Current store specific *current-transaction* stack @@ -91,11 +91,9 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- -January 2006 checkins; major features +January 22, 2006 checkins: x Modularize serializers for easy upgrade x Implement backend support for symbol-table protocol -x Speed up symbol storage and reference using symbol id's -x Ensure serialization is thread-safe and reasonably efficient 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!

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9131/src/elephant Modified Files: controller.lisp package.lisp serializer2.lisp variables.lisp Log Message: Where did bdb-slots go? --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/22 16:17:43 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/22 23:11:08 1.22 @@ -80,6 +80,7 @@ (setf (gethash spec *dbconnection-spec*) sc) sc))) + ;; NOTE: Check for asdf loaded rather than rely on asdf to? (defun load-backend (type) (let ((record (assoc type *elephant-backends*))) @@ -109,9 +110,8 @@ (defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) - ;; Setup system config parameters from my-config - (ensure-loaded-configuration) (setq *store-controller* (get-controller spec)) + (load-user-configuration *store-controller*) (initialize-serializer *store-controller*) (apply #'open-controller *store-controller* args)) @@ -165,6 +165,13 @@ 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) + ;; Fast symbols + (setf (controller-fast-symbols-p controller) + (elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant)))) + (defun initialize-serializer (sc) "Establish serializer version on controller startup" (cond ((prior-version-p (database-version sc) '(0 6 0)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/21 21:20:04 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/22 23:11:08 1.8 @@ -35,6 +35,7 @@ #:add-to-root #:get-from-root #:remove-from-root #:root-existsp #:get-cached-instance #:flush-instance-cache #:controller-symbol-cache #:controller-symbol-id-cache + #:controller-fast-symbols-p #:optimize-storage #:with-transaction --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/22 16:17:44 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/22 23:11:08 1.5 @@ -473,7 +473,7 @@ (declare (type buffer-stream bs) (type symbol symbol) (type store-controller sc)) - (if *fast-symbols* + (if (controller-fast-symbols-p sc) (let ((id (lookup-id symbol sc))) (declare (type fixnum id)) (buffer-write-byte +symbol-id+ bs) --- /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/21 21:20:04 1.8 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/22 23:11:08 1.9 @@ -43,15 +43,6 @@ Users attempting to directly write this variable will run into an error") -;;;;;;;;;;;;;;;;;;;; -;;;; User Configuration for site customization - -(defvar *fast-symbols* nil) ;; for serializer2.lisp - -(defun ensure-loaded-configuration () - (setf *fast-symbols* - (elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant)))) - ;;;;;;;;;;;;;;;;; ;;;; Serializer optimization parameters

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv32683 Modified Files: bdb-symbol-tables.lisp berkeley-db.lisp Added Files: bdb-slots.lisp Log Message: Added missing file --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/19 21:03:29 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-symbol-tables.lisp 2007/01/22 22:22:35 1.2 @@ -34,18 +34,18 @@ the persistent tables." (reset-buffer-stream valbuf) ;; Just to avoid any contamination ;; (with-transaction (:txn-nosync t :dirty-read t) - (format t "getting next symid") +;; (format t "getting next symid") (let ((id (next-symid sc))) ;; allocate a new unique id ;; Update symbol->id table - (format t "Writing sym->id: ~A -> ~A~%" symbol id) +;; (format t "Writing sym->id: ~A -> ~A~%" symbol id) (buffer-write-int id valbuf) - (format t "Putting id into table location~%") +;; (format t "Putting id into table location~%") (db-put-buffered (controller-btrees sc) keybuf valbuf :auto-commit *auto-commit*) ;; Write id->symbol table (reset-buffer-stream keybuf) (reset-buffer-stream valbuf) - (format t "Writing id->sym: ~A -> ~A~%" id symbol) +;; (format t "Writing id->sym: ~A -> ~A~%" id symbol) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) (serialize-symbol-complete symbol valbuf) @@ -59,13 +59,13 @@ (defmethod lookup-persistent-symbol ((sc bdb-store-controller) id) "Lookup the ID associated with a symbol" (with-buffer-streams (keybuf valbuf) - (format t "Looking up: ~A~%" id) +;; (format t "Looking up: ~A~%" id) (buffer-write-int *id-to-symbol-table-oid* keybuf) (buffer-write-int id keybuf) - (format t "Get for id: ~A~%" id) +;; (format t "Get for id: ~A~%" id) (let ((buf (db-get-key-buffered (controller-btrees sc) keybuf valbuf))) - (format t "Got buf: ~A~%" buf) +;; (format t "Got buf: ~A~%" buf) (if buf (values (deserialize buf sc) T) (error "Invalid ID - no persistent mapping for ID"))))) --- /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/20 22:12:17 1.3 +++ /project/elephant/cvsroot/elephant/src/db-bdb/berkeley-db.lisp 2007/01/22 22:22:35 1.4 @@ -19,7 +19,9 @@ (in-package :db-bdb) -(declaim (inline %db-get-key-buffered db-get-key-buffered +(declaim + #-elephant-without-optimize (optimize (speed 3) (safety 0)) + (inline %db-get-key-buffered db-get-key-buffered %db-get-buffered db-get-buffered db-get %db-put-buffered db-put-buffered %db-put db-put @@ -617,8 +619,7 @@ a buffer-stream. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for decoding, or NIL if nothing was found." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (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)) (loop @@ -668,8 +669,7 @@ string. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for decoding, or NIL if nothing was found." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type string key) (type buffer-stream value-buffer-stream) (type fixnum key-size) @@ -708,8 +708,7 @@ "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 is found, NIL is returned." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type string key) (type fixnum key-size) (type boolean auto-commit get-both degree-2 read-committed @@ -759,8 +758,7 @@ "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 (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream) (type boolean auto-commit exists-error-p)) (let ((errno @@ -794,8 +792,7 @@ (value-size (length value)) (transaction *current-transaction*)) :cstrings (key value) - :declarations (declare (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + :declarations (declare (type pointer-void db transaction) (type string key value) (type fixnum key-size value-size) (type boolean auto-commit)) @@ -816,8 +813,7 @@ "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 (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type buffer-stream key-buffer-stream) (type boolean auto-commit)) (let ((errno (%db-delete-buffered db transaction @@ -846,8 +842,7 @@ (transaction *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 (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) (type string key) + (declare (type pointer-void db transaction) (type string key) (type fixnum key-size) (type boolean auto-commit)) (with-cstrings ((key key)) (let ((errno @@ -878,8 +873,7 @@ duplicates. The key and value are encoded as buffer-streams. T on success, NIL if the key / value pair wasn't found." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream)) (let ((errno (%db-delete-kv db transaction (buffer-stream-buffer key-buffer-stream) @@ -913,8 +907,7 @@ (defun db-compact (db start stop end &key (transaction *current-transaction*) freelist-only free-space) - (declare (optimize (speed 3) (safety 2)) - (type pointer-void db transaction) + (declare (type pointer-void db transaction) (type buffer-stream start stop) (type boolean freelist-only free-space)) (loop @@ -953,8 +946,7 @@ (defun db-cursor (db &key (transaction *current-transaction*) degree-2 read-committed dirty-read read-uncommitted) "Create a cursor." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db) + (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) @@ -979,8 +971,7 @@ (defun db-cursor-delete (cursor) "Delete by cursor." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor)) + (declare (type pointer-void cursor)) (let ((errno (%db-cursor-delete cursor 0))) (declare (type fixnum errno)) (cond ((= errno 0) t) @@ -1000,8 +991,7 @@ (defun db-cursor-duplicate (cursor &key (position t)) "Duplicate a cursor." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void 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))) @@ -1031,8 +1021,7 @@ "Move a cursor, returning the key / value pair found. Supports current, first, last, next, next-dup, next-nodup, prev, prev-nodup." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream value-buffer-stream) (type boolean current first last next next-dup next-nodup prev prev-nodup dirty-read read-uncommitted)) @@ -1077,8 +1066,7 @@ &key set set-range dirty-read read-uncommitted) "Move a cursor to a key, returning the key / value pair found. Supports set and set-range." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream value-buffer-stream) (type boolean set set-range dirty-read read-uncommitted)) (loop @@ -1118,8 +1106,7 @@ &key get-both get-both-range dirty-read read-uncommitted) "Move a cursor to a key / value pair, returning the key / value pair found. Supports get-both and get-both-range." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream value-buffer-stream) (type boolean get-both get-both-range dirty-read read-uncommitted)) (loop @@ -1180,8 +1167,7 @@ "Move a secondary cursor, returning the key / value / primary triple found. Supports current, first, last, next, next-dup, next-nodup, prev, prev-nodup." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream pkey-buffer-stream value-buffer-stream) (type boolean current first last next next-dup next-nodup prev @@ -1236,8 +1222,7 @@ &key set set-range dirty-read) "Move a secondary cursor tp a key, returning the key / value / primary triple found. Supports set, set-range." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream pkey-buffer-stream value-buffer-stream) (type boolean set set-range dirty-read)) @@ -1288,8 +1273,7 @@ "Move a secondary cursor tp a key / primary pair, returning the key / value / primary triple found. Supports get, get-range." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream pkey-buffer-stream value-buffer-stream) (type boolean get-both get-both-range dirty-read)) @@ -1346,8 +1330,7 @@ &key after before current keyfirst keylast no-dup-data exists-error-p) "Put by cursor. The key and value are encoded as buffer-streams." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void cursor) + (declare (type pointer-void cursor) (type buffer-stream key-buffer-stream value-buffer-stream) (type boolean after before current keyfirst keylast no-dup-data exists-error-p)) @@ -1385,8 +1368,7 @@ degree-2 read-committed dirty-read read-uncommitted txn-nosync txn-nowait txn-sync) "Start a transaction. Transactions may be nested." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void env parent) + (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*)) @@ -1411,8 +1393,7 @@ (wrap-errno (db-transaction-abort %db-txn-abort) (transaction) :keys ((transaction *current-transaction*)) - :declarations (declare (optimize (speed 3) (safety 0)) - (type pointer-void transaction)) + :declarations (declare (type pointer-void transaction)) :documentation "Abort a transaction.") (def-function ("db_txn_commit" %db-txn-commit) @@ -1423,8 +1404,7 @@ (wrap-errno (db-transaction-commit %db-txn-commit) (transaction flags) :keys ((transaction *current-transaction*)) :flags (txn-nosync txn-sync) - :declarations (declare (optimize (speed 3) (safety 0)) - (type pointer-void transaction) + :declarations (declare (type pointer-void transaction) (type boolean txn-nosync txn-sync)) :documentation "Commit a transaction.") @@ -1523,7 +1503,6 @@ (defun db-transaction-id (&optional (transaction *current-transaction*)) "Returns the ID of the transaction (for locking purposes.)" - (declare (optimize (speed 3))) (%db-transaction-id transaction)) (def-function ("db_env_lock_id" %db-env-lock-id) @@ -1715,8 +1694,7 @@ (defun db-sequence-create (db) "Create a new sequence." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void db) + (declare (type pointer-void db) (type pointer-int *errno-buffer*)) (let* ((seq (%db-sequence-create db 0 *errno-buffer*)) @@ -1763,8 +1741,7 @@ (defun db-sequence-get (sequence delta &key auto-commit txn-nosync (transaction *current-transaction*)) "Get the next element." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void sequence transaction) + (declare (type pointer-void sequence transaction) (type fixnum delta) (type boolean auto-commit txn-nosync)) (multiple-value-bind @@ -1792,8 +1769,7 @@ (defun db-sequence-get-fixnum (sequence delta &key auto-commit txn-nosync (transaction *current-transaction*)) "Get the next element as a fixnum." - (declare (optimize (speed 3) (safety 0)) - (type pointer-void sequence transaction) + (declare (type pointer-void sequence transaction) (type fixnum delta) (type boolean auto-commit txn-nosync)) (multiple-value-bind --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/01/22 22:22:35 NONE +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-slots.lisp 2007/01/22 22:22:35 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; bdb-slots.lisp -- Implement the slot protocol ;;; ;;; Initial version 8/26/2004 by Ben Lee ;;; <blee(a)common-lisp.net> ;;; ;;; part of ;;; ;;; Elephant: an object-oriented database for Common Lisp ;;; ;;; Copyright (c) 2004 by Andrew Blumberg and Ben Lee ;;; <ablumberg(a)common-lisp.net> <blee(a)common-lisp.net> ;;; ;;; 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-bdb) ;; ;; Persistent slot protocol implementation ;; (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) (let ((buf (db-get-key-buffered (controller-db sc) key-buf value-buf))) (if buf (deserialize buf sc) #+cmu (error 'unbound-slot :instance instance :slot name) #-cmu (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*) 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) (let ((buf (db-get-key-buffered (controller-db sc) key-buf value-buf))) (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*)))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv25298/src/elephant Modified Files: controller.lisp serializer2.lisp Log Message: 0.6.1 Working HEAD is limping again. All tests pass on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/21 21:20:04 1.20 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/22 16:17:43 1.21 @@ -137,7 +137,7 @@ ;; COMMON STORE CONTROLLER FUNCTIONALITY ;; -(defclass store-controller () +(defclass store-controller () ((spec :type (or pathname string (simple-array character)) :accessor controller-spec :initarg :spec --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/21 21:20:04 1.3 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/22 16:17:44 1.4 @@ -45,7 +45,7 @@ ;; Constants -(defconstant +fixnum+ 1) +(defconstant +fixnum32+ 1) (defconstant +fixnum64+ 2) (defconstant +char+ 3) (defconstant +single-float+ 4) @@ -154,15 +154,15 @@ (incf *lisp-obj-id*)) (%serialize (frob) (etypecase frob - ((integer #.most-negative-fixnum #.most-positive-fixnum) - (buffer-write-byte +fixnum+ bs) - (buffer-write-int frob bs)) - (null - (buffer-write-byte +nil+ bs)) (symbol (serialize-symbol frob bs sc)) (string (serialize-string frob bs)) + ((integer #.most-negative-fixnum #.most-positive-fixnum) + (buffer-write-byte +fixnum32+ bs) + (buffer-write-int frob bs)) + (null + (buffer-write-byte +nil+ bs)) (persistent (buffer-write-byte +persistent+ bs) (buffer-write-int (oid frob) bs) @@ -327,7 +327,7 @@ (declare (type foreign-char tag) (dynamic-extent tag)) (cond - ((= tag +fixnum+) + ((= tag +fixnum32+) (buffer-read-fixnum bs)) ((= tag +nil+) nil) ((= tag +utf8-string+)

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv25298/tests Modified Files: delscript.sh testindexing.lisp testserializer.lisp Log Message: 0.6.1 Working HEAD is limping again. All tests pass on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/tests/delscript.sh 2006/11/11 18:41:11 1.2 +++ /project/elephant/cvsroot/elephant/tests/delscript.sh 2007/01/22 16:17:44 1.3 @@ -1,9 +1,12 @@ rm testdb/__* rm testdb/%* rm testdb/log* +rm testdb/VERSION rm testdb2/__* rm testdb2/%* rm testdb2/log* +rm testdb2/VERSION rm testbdb/testsbdb rm testbdb/__* -rm testbdb/log* \ No newline at end of file +rm testbdb/log* +rm testbdb/VERSION \ No newline at end of file --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/09/04 05:42:43 1.19 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/01/22 16:17:44 1.20 @@ -417,8 +417,8 @@ (end (1- (+ start size)))) (get-instances-by-range class 'stress1 start end))) -(defparameter *stress-count* 500) -(defparameter *range-size* 40) +(defparameter *stress-count* 700) +(defparameter *range-size* 80) (deftest indexing-timing (progn --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/01/21 21:20:05 1.11 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/01/22 16:17:44 1.12 @@ -348,15 +348,14 @@ (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) (are-not-null -;; (in-out-deep-equalp c1) -;; (in-out-deep-equalp c2) -;; (in-out-deep-equalp l1) -;; (in-out-deep-equalp h) -;; (in-out-deep-equalp g) -;; (in-out-deep-equalp f) + (in-out-deep-equalp c1) + (in-out-deep-equalp c2) + (in-out-deep-equalp l1) + (in-out-deep-equalp h) + (in-out-deep-equalp g) + (in-out-deep-equalp f) (in-out-deep-equalp b))) - t) - ;;t t t t t t t) + t t t t t t t) (defclass pfoo () ((slot1 :initarg :slot1 :accessor slot1))

1 0

[elephant-cvs] CVS elephant
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv25298 Modified Files: TODO Log Message: 0.6.1 Working HEAD is limping again. All tests pass on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/TODO 2007/01/21 21:20:03 1.34 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/22 16:17:43 1.35 @@ -6,38 +6,22 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -Bugs or Observations: -- Windows support for asdf-based library builds? Include dll? -- Validate migration 0.6.0->0.6.1 +Active tasks: +- Enable and verify symbol-id strategy - Full 64-bit support (arrays, native 64-bit fixnums, etc) - char vs. uint8 in buffer-stream - flexible handling of 64-bit fixnums -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 all NOTE comments in the code -- Validate that migrate can use either O(c) or O(n/c) where c << n memory -- Migrate code base to SVN and create tickets in TRAC - -Store variables: -- Think through default *store-controller* vs. explicit parameter passing - referencing all over the APIs +Multi-threading support and multiple-store cleanup: - Think about dynamic vs. object based store & transaction resolution? - Perform error checking when mixed - Current store specific *current-transaction* stack -- Throw condition when store spec is invalid, etc - -Multi-threading operation: - Make elephant threads appropriately bind dynamic variables? - Thread safety for all global vars - Thread safe API option for user-managed store-controller? - Thread safe API for transactions - Update to require BDB 4.5? +- Throw condition when store spec is invalid, etc BDB Features: ? Determine how to detect deadlock conditions as an optional run-safe mode? @@ -63,22 +47,39 @@ parameter that determines if this is the default? Performance: -- Allow dump of fast-symbol tables for low-level reconstruction in case of - catastrophic errors +- 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) + +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 + +RELEASE ISSUES 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? +- Allow dump of fast-symbol tables for low-level reconstruction in case of + catastrophic errors + 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 - Add notes about optimize-storage @@ -100,6 +101,9 @@ x Ensure thread safety in buffer-stream allocation! January 2006 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*) x New build interface; all-lisp compilation (sans win32), (help from elephant-devel) x Verify that operations such as indexing are thread safe x Diffs for lisp-controlled DB checkpointing (by Gabor Melis) @@ -124,6 +128,9 @@ 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 - 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? @@ -140,6 +147,7 @@ - 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) --------------------------------------------------

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 22 Jan '07

22 Jan '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv25298/src/db-bdb Modified Files: libberkeley-db.c Log Message: 0.6.1 Working HEAD is limping again. All tests pass on Allegro 8.0/Mac OS X --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/20 22:12:17 1.5 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2007/01/22 16:17:43 1.6 @@ -265,889 +265,1055 @@ return db->get_pagesize(db, pagesizep); } -int db_set_bt_compare(DB *db, - int (*bt_compare_fcn)(DB *db, const DBT *dbt1, - const DBT *dbt2)) { - return db->set_bt_compare(db, bt_compare_fcn); -} +/* Accessors */ +/* We manage our own buffers (DB_DBT_USERMEM). */ -int db_set_dup_compare(DB *db, - int (*dup_compare_fcn)(DB *db, const DBT *dbt1, - const DBT *dbt2)) { - return db->set_dup_compare(db, dup_compare_fcn); +int db_get_raw(DB *db, DB_TXN *txnid, + char *key, u_int32_t key_size, + char *buffer, u_int32_t buffer_length, + u_int32_t flags, u_int32_t *result_size) { + DBT DBTKey, DBTValue; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + DBTValue.data = buffer; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = db->get(db, txnid, &DBTKey, &DBTValue, flags); + *result_size = DBTValue.size; + + return ret; } -#define type_numeric1(c) ((c)<8) -#include <math.h> - -double read_num(char *buf); -int case_cmp(const char *a, int32_t length1, const 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); - -/* Inspired by the BDB docs. We have to memcpy to - insure memory alignment. */ +int db_put_raw(DB *db, DB_TXN *txnid, + char *key, u_int32_t key_size, + char *value, u_int32_t value_size, + u_int32_t flags) { + DBT DBTKey, DBTValue; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + DBTValue.data = value; + DBTValue.size = value_size; + + return db->put(db, txnid, &DBTKey, &DBTValue, flags); +} -/* Original serializer */ -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; +int db_del(DB *db, DB_TXN *txnid, + char *key, u_int32_t key_size, + u_int32_t flags) { + DBT DBTKey; + + memset(&DBTKey, 0, sizeof(DBT)); + DBTKey.data = key; + DBTKey.size = key_size; + return db->del(db, txnid, &DBTKey, flags); +} - /* Compare OIDs. */ - difference = read_int(ad, 0) - read_int(bd, 0); - if (difference) return difference; +int db_compact(DB *db, DB_TXN *txnid, + char *start, u_int32_t start_size, + char *stop, u_int32_t stop_size, + u_int32_t flags, + char *end, u_int32_t end_length, + u_int32_t *end_size) { + DBT DBTStart, DBTStop, DBTEnd; + int errno; - /* Have a type tag? */ - if (a->size == 4) - if (b->size == 4) - return 0; - else - return -1; - else if (b->size == 4) - return 1; + memset(&DBTStart, 0, sizeof(DBT)); + DBTStart.data = start; + DBTStart.size = start_size; - at = ad[4]; bt = bd[4]; + memset(&DBTStop, 0, sizeof(DBT)); + DBTStop.data = stop; + DBTStop.size = stop_size; - /* Compare numerics. */ - if (type_numeric1(at) && type_numeric1(bt)) { - ddifference = read_num(ad+4) - read_num(bd+4); - if (ddifference > 0) return 1; - else if (ddifference < 0) return -1; - return 0; - } + memset(&DBTEnd, 0, sizeof(DBT)); + DBTEnd.data = end; + DBTEnd.ulen = end_length; + DBTEnd.flags |= DB_DBT_USERMEM; - /* Compare types. */ - /* ISE: need extra conditional here...forget why, so research it */ - difference = at - bt; - if (difference) return difference; + errno = db->compact(db, txnid, + &DBTStart, + &DBTStop, + NULL, + flags, + &DBTEnd); + *end_size = DBTEnd.size; - /* Same type! */ - switch (at) { - case 8: /* nil */ - return 0; - case 9: /* 8-bit symbol */ - case 10: /* 8-bit string */ - case 11: /* 8-bit pathname */ - return case_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); - case 12: /* 16-bit symbol */ - case 13: /* 16-bit string */ - case 14: /* 16-bit pathname */ - return utf16_cmp(ad+9, read_int(ad, 5), bd+9, read_int(bd, 5)); - case 20: - case 21: - case 22: - return wcs_cmp((wchar_t*)ad+9, read_int(ad, 5), (wchar_t*)bd+9, read_int(bd, 5)); - default: - return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); - } + return errno; } - -#define type_numeric2(c) ((c)<9) - -/* New serializer */ -int lisp_compare2(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; - - /* Compare OIDs: OIDs are limited by native integer width */ - difference = read_int(ad, 0) - read_int(bd, 0); - if (difference) return difference; + - /* Have a type tag? */ - if (a->size == 4) - if (b->size == 4) - return 0; - else - return -1; - else if (b->size == 4) - return 1; - - at = ad[4]; bt = bd[4]; - /* Compare numerics. */ - if (type_numeric2(at) && type_numeric2(bt)) { - /* ddifference = read_num2(ad+4) - read_num2(bd+4); */ - ddifference = read_num(ad+4) - read_num(bd+4); - if (ddifference > 0) return 1; - else if (ddifference < 0) return -1; - return 0; - } - - /* Compare types. */ - /* ISE: need extra conditional here...forget why, so research it */ - difference = at - bt; - if (difference) return difference; +/* Cursors */ - /* TODO: compare strings of different sizes? */ - /* TODO: compare symbol-ids? */ - - /* Same type! */ - switch (at) { - case 0x3F: /* nil */ - return 0; - case 9: /* 8-bit string */ - return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); - /* ISE: Why did I do this? - if( bt == 9 ) - return case_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); - else - return full_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)) - */ - case 10: /* 16-bit string */ - return utf16_cmp(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); - case 11: - return wcs_cmp((wchar_t*)ad+9, read_int32(ad, 5), (wchar_t*)bd+9, read_int32(bd, 5)); - default: - return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); - } +DBC * db_cursor(DB *db, DB_TXN *txnid, u_int32_t flags, int *errno) { + DBC *cursor; + *errno = db->cursor(db, txnid, &cursor, flags); + return cursor; } -int db_set_lisp_compare(DB *db, int version) { - switch (version) { - case 1: - return db->set_bt_compare(db, &lisp_compare1); - default: - return db->set_bt_compare(db, &lisp_compare2); - } +int db_cursor_close(DBC *cursor) { + return cursor->c_close(cursor); } -int db_set_lisp_dup_compare(DB *db, int version) { - switch (version) { - case 1: - return db->set_dup_compare(db, &lisp_compare1); - default: - return db->set_dup_compare(db, &lisp_compare2); - } +int db_cursor_del(DBC *cursor, u_int32_t flags) { + return cursor->c_del(cursor, flags); } -#ifndef exp2 -#define exp2(c) (pow(2,(c))) -#endif - -double read_num(char *buf) { - char *limit; - double i, result, denom; - switch (buf[0]) { - case 1: - case 2: - return (double)read_int(buf, 1); - case 3: - return (double)read_float(buf, 1); - case 4: - return read_double(buf, 1); - case 5: - result = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - result -= exp2(i*32) * read_uint(buf, 0); - } - return result; - case 6: - result = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - result += exp2(i*32) * read_uint(buf, 0); - } - return result; - case 7: - default: - switch ((++buf)[0]) { - case 1: - result = (double)read_int(++buf, 0); - buf += 4; - break; - case 5: - result = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - result -= exp2(i*32) - read_uint(buf, 0); - } - break; - case 6: - default: - result = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - result += exp2(i*32) * read_uint(buf, 0); - } - break; - } - - switch (buf[0]) { - case 1: - return result / read_int(++buf, 0); - case 5: - denom = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - denom -= exp2(i*32) * read_uint(buf, 0); - } - return result / denom; - case 6: - default: - denom = 0; - buf += 5; - limit = buf + read_uint(buf, -4); - for(i=0 ; buf < limit; i++, buf = buf+4) { - denom += exp2(i*32) * read_uint(buf, 0); - } - return result / denom; - } - } +DBC * db_cursor_dup(DBC *cursor, u_int32_t flags, int *errno) { + DBC *dup; + *errno = cursor->c_dup(cursor, &dup, flags); + return dup; } -#ifdef WIN32 -#define strncasecmp _strnicmp -typedef unsigned short uint16_t; -#endif - -int case_cmp(const char *a, int32_t length1, const char *b, int32_t length2) { - int min, sizediff, diff; - sizediff = length1 - length2; - min = sizediff > 0 ? length2 : length1; - diff = strncasecmp(a, b, min); - if (diff == 0) return sizediff; - return diff; +int db_cursor_get_raw(DBC *cursor, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + 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) { + DBT DBTKey, DBTValue; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTValue, 0, sizeof(DBT)); + DBTKey.data = keybuf; + DBTKey.size = keybuf_size; + DBTKey.ulen = keybuf_length; + DBTKey.flags |= DB_DBT_USERMEM; + DBTValue.data = buffer; + DBTValue.size = buffer_size; + DBTValue.ulen = buffer_length; + DBTValue.flags |= DB_DBT_USERMEM; + + ret = cursor->c_get(cursor, &DBTKey, &DBTValue, flags); + *ret_key_size = DBTKey.size; + *result_size = DBTValue.size; + + return ret; } -int wcs_cmp(const wchar_t *a, int32_t length1, - const wchar_t *b, int32_t length2) { - int min, sizediff, diff; - sizediff = length1 - length2; - min = sizediff > 0 ? length2 : length1; - diff = wcsncmp(a, b, min /4); - if (diff == 0) return sizediff; - return diff; +int db_cursor_pget_raw(DBC *cursor, + char *keybuf, u_int32_t keybuf_size, + u_int32_t keybuf_length, + char *pkeybuf, u_int32_t pkeybuf_size, + u_int32_t pkeybuf_length, + 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 *ret_pkey_size, + u_int32_t *result_size) { + DBT DBTKey, DBTPKey, DBTValue; + int ret; + + memset(&DBTKey, 0, sizeof(DBT)); + memset(&DBTPKey, 0, sizeof(DBT)); [1387 lines skipped]

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 21 Jan '07

21 Jan '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv13092/tests Modified Files: testserializer.lisp Log Message: Up and limping; 0.6.1 working HEAD is in good shape again. Fails four tests (all cursor ranges). Object ID's are turned off for now - they are a user configuration option --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2006/02/19 04:53:02 1.10 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/01/21 21:20:05 1.11 @@ -15,19 +15,19 @@ (defun in-out-value (var) (with-buffer-streams (out-buf) - (deserialize (serialize var out-buf) :sc *store-controller*))) + (deserialize (serialize var out-buf *store-controller*) *store-controller*))) (defun in-out-eq (var) (with-buffer-streams (out-buf) - (eq var (deserialize (serialize var out-buf) :sc *store-controller*)))) + (eq var (deserialize (serialize var out-buf *store-controller*) *store-controller*)))) (defun in-out-equal (var) (with-buffer-streams (out-buf) - (equal var (deserialize (serialize var out-buf) :sc *store-controller*)))) + (equal var (deserialize (serialize var out-buf *store-controller*) *store-controller*)))) (defun in-out-equalp (var) (with-buffer-streams (out-buf) - (equalp var (deserialize (serialize var out-buf) :sc *store-controller*)))) + (equalp var (deserialize (serialize var out-buf *store-controller*) *store-controller*)))) (deftest fixnums (are-not-null @@ -126,8 +126,8 @@ (defun in-out-uninterned-equal (var) (with-buffer-streams (out-buf) - (serialize var out-buf) - (let ((new (deserialize (serialize var out-buf) :sc *store-controller*))) + (serialize var out-buf *store-controller*) + (let ((new (deserialize (serialize var out-buf *store-controller*) *store-controller*))) (and (equal (symbol-name new) (symbol-name var)) (equal (symbol-package new) (symbol-package var)))))) @@ -313,8 +313,9 @@ t t t t t t t) (defun in-out-deep-equalp (var) + (assert *store-controller*) (with-buffer-streams (out-buf) - (deep-equalp var (deserialize (serialize var out-buf) :sc *store-controller*)))) + (deep-equalp var (deserialize (serialize var out-buf *store-controller*) *store-controller*)))) (deftest objects (are-not-null @@ -347,14 +348,15 @@ (setf (slot-value b 'slot1) h) (setf (slot-value b 'slot2) f) (are-not-null - (in-out-deep-equalp c1) - (in-out-deep-equalp c2) - (in-out-deep-equalp l1) - (in-out-deep-equalp h) - (in-out-deep-equalp g) - (in-out-deep-equalp f) +;; (in-out-deep-equalp c1) +;; (in-out-deep-equalp c2) +;; (in-out-deep-equalp l1) +;; (in-out-deep-equalp h) +;; (in-out-deep-equalp g) +;; (in-out-deep-equalp f) (in-out-deep-equalp b))) - t t t t t t t) + t) + ;;t t t t t t t) (defclass pfoo () ((slot1 :initarg :slot1 :accessor slot1))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 21 Jan '07

21 Jan '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv13092/src/elephant Modified Files: controller.lisp package.lisp serializer.lisp serializer1.lisp serializer2.lisp variables.lisp Log Message: Up and limping; 0.6.1 working HEAD is in good shape again. Fails four tests (all cursor ranges). Object ID's are turned off for now - they are a user configuration option --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/20 22:12:17 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/01/21 21:20:04 1.20 @@ -109,8 +109,8 @@ (defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) - ;; setup system config parameters (if necessary) - ;; GF iface to overload by backend + ;; Setup system config parameters from my-config + (ensure-loaded-configuration) (setq *store-controller* (get-controller spec)) (initialize-serializer *store-controller*) (apply #'open-controller *store-controller* args)) @@ -167,7 +167,7 @@ (defun initialize-serializer (sc) "Establish serializer version on controller startup" - (cond ((prior-version-p (controller-version sc) '(0 6 0)) + (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)) @@ -181,10 +181,10 @@ ;; (defmethod database-version ((sc store-controller)) - (:documentation "A version determination for a given store + "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)")) + list of the form '(0 6 0)" (let ((version (controller-version-cached sc))) (if version version (let ((path (make-pathname :name "VERSION" :defaults (second (controller-spec sc))))) @@ -192,7 +192,7 @@ (with-open-file (stream path :direction :input) (setf (controller-version-cached sc) (read stream))) (with-open-file (stream path :direction :output) - (setf (controller-version-cached sc) + (setf (controller-version-cached sc) (write *elephant-code-version* :stream stream)))))))) (defun prior-version-p (v1 v2) @@ -358,13 +358,13 @@ ;; (defmethod up-to-date-p ((sc store-controller)) - (equal (controller-version sc) *elephant-code-version*)) + (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) - (controller-version 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 @@ -383,7 +383,7 @@ "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 (controller-version sc))) + (ver (database-version sc))) (when (member ver (rest row) :test #'equal)) t) nil)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/20 22:12:18 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/01/21 21:20:04 1.7 @@ -54,6 +54,7 @@ #:lookup-persistent-symbol #:lookup-persistent-symbol-id + #:int-byte-spec #:cursor #:secondary-cursor #:make-cursor #:with-btree-cursor #:cursor-close #:cursor-init @@ -68,8 +69,6 @@ #:cursor-pset-range #:cursor-pget-both #:cursor-pget-both-range - #:run-elephant-thread - ;; Class indexing management API #:*default-indexed-class-synch-policy* #:find-class-index #:find-inverted-index @@ -95,6 +94,7 @@ #:ele-make-lock #:ele-with-lock #:ele-without-interrupts + #:slots-and-values ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/20 22:12:18 1.16 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/01/21 21:20:04 1.17 @@ -19,16 +19,15 @@ (defun serialize (frob bs sc) "Generic interface to serialization that dispatches based on the current Elephant version" + (assert sc) (funcall (symbol-function (controller-serialize sc)) frob bs sc)) (defun deserialize (bs sc) "Generic interface to serialization that dispatches based on the current Elephant version" + (assert sc) (funcall (symbol-function (controller-deserialize sc)) bs sc)) -;;(defun serializer-feature (sc) -;; ( - ;; ;; SQL encoding support ;; @@ -103,27 +102,75 @@ ;; ))) ;;;; -;;;; Serializer comparison via performane test +;;;; Common utilities ;;;; -(defun performance-test (serialize-fn deserialize-fn object &optional (iterations 10000)) - (declare (optimize (speed 3) (safety 1))) - (let ((bs (elephant-memutil::grab-buffer-stream))) - (reset-buffer-stream bs) - (loop for i fixnum from 0 to iterations do - (funcall serialize-fn object bs nil) - (funcall deserialize-fn bs nil) - (reset-buffer-stream bs)) - (elephant-memutil::return-buffer-stream bs))) - -(defun test-1 (object &optional (iterations 10000)) - (time - (performance-test #'elephant-serializer1::serialize - #'elephant-serializer1::deserialize - object iterations))) - -(defun test-2 (object &optional (iterations 10000)) - (time - (performance-test #'elephant-serializer2::serialize - #'elephant-serializer2::deserialize - object iterations))) \ No newline at end of file +;; slot names and values for ordinary objects + +(defun slots-and-values (o) + (declare (optimize (speed 3) (safety 0))) + (loop for sd in (compute-slots (class-of o)) + for slot-name = (slot-definition-name sd) + with ret = () + do + (when (and (slot-boundp o slot-name) + (eq :instance + (slot-definition-allocation sd))) + (push (slot-value o slot-name) ret) + (push slot-name ret)) + finally (return ret))) + +;; array type tags + +(declaim (type hash-table array-type-to-byte byte-to-array-type)) +(defvar array-type-to-byte (make-hash-table :test 'equalp)) +(defvar byte-to-array-type (make-hash-table :test 'equalp)) + +(setf (gethash 'T array-type-to-byte) #x00) +(setf (gethash 'base-char array-type-to-byte) #x01) +(setf (gethash 'character array-type-to-byte) #x02) +(setf (gethash 'single-float array-type-to-byte) #x03) +(setf (gethash 'double-float array-type-to-byte) #x04) +(setf (gethash '(complex single-float) array-type-to-byte) #x05) +(setf (gethash '(complex double-float) array-type-to-byte) #x06) +(setf (gethash 'fixnum array-type-to-byte) #x07) +(setf (gethash 'bit array-type-to-byte) #x08) + +(defun type= (t1 t2) + (and (subtypep t1 t2) (subtypep t2 t1))) + +(let ((counter 8)) + (loop for i from 2 to 65 + for spec = (list 'unsigned-byte i) + for uspec = (upgraded-array-element-type spec) + when (type= spec uspec) + do + (setf (gethash spec array-type-to-byte) (incf counter))) + (loop for i from 2 to 65 + for spec = (list 'signed-byte i) + for uspec = (upgraded-array-element-type spec) + when (type= spec uspec) + do + (setf (gethash spec array-type-to-byte) (incf counter)))) + +(loop for key being the hash-key of array-type-to-byte + using (hash-value value) + do + (setf (gethash value byte-to-array-type) key)) + +(defun array-type-from-byte (b) + (gethash b byte-to-array-type)) + +(defun byte-from-array-type (ty) + (the (unsigned-byte 8) (gethash ty array-type-to-byte))) + +(defun int-byte-spec (position) + (declare (optimize (speed 3) (safety 0)) + (type (unsigned-byte 24) position)) + #+(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/01/16 00:51:25 1.1 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer1.lisp 2007/01/21 21:20:04 1.2 @@ -24,7 +24,10 @@ slot-definition-allocation slot-definition-name compute-slots - oid)) + oid + int-byte-spec + array-type-from-byte + byte-from-array-type)) (in-package :elephant-serializer1) @@ -82,20 +85,20 @@ of object references. CLRHASH then starts to dominate performance as it has to visit ever spot in the table so we're better off GCing the old table than clearing it" - (declare (optimize (speed 3) (safety 0))) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0))) (if (> (hash-table-size *circularity-hash*) 100) (setf *circularity-hash* (make-hash-table :test 'eq :size 50)) (clrhash *circularity-hash*))) (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." - (declare (optimize (speed 3) (safety 0)) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (setq *lisp-obj-id* 0) (clear-circularity-hash) (labels ((%serialize (frob) - (declare (optimize (speed 3) (safety 0))) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0))) (typecase frob (fixnum (buffer-write-byte +fixnum+ bs) @@ -269,26 +272,13 @@ (%serialize frob) bs)) -(defun slots-and-values (o) - (declare (optimize (speed 3) (safety 0))) - (loop for sd in (compute-slots (class-of o)) - for slot-name = (slot-definition-name sd) - with ret = () - do - (when (and (slot-boundp o slot-name) - (eq :instance - (slot-definition-allocation sd))) - (push (slot-value o slot-name) ret) - (push slot-name ret)) - finally (return ret))) - (defun deserialize (buf-str sc) "Deserialize a lisp value from a buffer-stream." - (declare (optimize (speed 3) (safety 0)) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) (type (or null buffer-stream) buf-str)) (labels ((%deserialize (bs) - (declare (optimize (speed 3) (safety 0)) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) (type buffer-stream bs)) (let ((tag (buffer-read-byte bs))) (declare (type foreign-char tag)) @@ -439,7 +429,7 @@ (%deserialize buf-str))))) (defun deserialize-bignum (bs length positive) - (declare (optimize (speed 3) (safety 0)) + (declare #-elephant-without-optimize (optimize (speed 3) (safety 0)) (type buffer-stream bs) (type fixnum length) (type boolean positive)) @@ -451,58 +441,5 @@ finally (return (if positive num (- num))))) -;; array type tags - -(declaim (type hash-table array-type-to-byte byte-to-array-type)) -(defvar array-type-to-byte (make-hash-table :test 'equalp)) -(defvar byte-to-array-type (make-hash-table :test 'equalp)) - -(setf (gethash 'T array-type-to-byte) #x00) -(setf (gethash 'base-char array-type-to-byte) #x01) -(setf (gethash 'character array-type-to-byte) #x02) -(setf (gethash 'single-float array-type-to-byte) #x03) -(setf (gethash 'double-float array-type-to-byte) #x04) -(setf (gethash '(complex single-float) array-type-to-byte) #x05) -(setf (gethash '(complex double-float) array-type-to-byte) #x06) -(setf (gethash 'fixnum array-type-to-byte) #x07) -(setf (gethash 'bit array-type-to-byte) #x08) - -(defun type= (t1 t2) - (and (subtypep t1 t2) (subtypep t2 t1))) - -(let ((counter 8)) - (loop for i from 2 to 65 - for spec = (list 'unsigned-byte i) - for uspec = (upgraded-array-element-type spec) - when (type= spec uspec) - do - (setf (gethash spec array-type-to-byte) (incf counter))) - (loop for i from 2 to 65 - for spec = (list 'signed-byte i) - for uspec = (upgraded-array-element-type spec) - when (type= spec uspec) - do - (setf (gethash spec array-type-to-byte) (incf counter)))) - -(loop for key being the hash-key of array-type-to-byte - using (hash-value value) - do - (setf (gethash value byte-to-array-type) key)) - -(defun array-type-from-byte (b) - (gethash b byte-to-array-type)) - -(defun byte-from-array-type (ty) - (the (unsigned-byte 8) (gethash ty array-type-to-byte))) - -(defun int-byte-spec (position) - (declare (optimize (speed 3) (safety 0)) - (type (unsigned-byte 24) position)) - #+(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/serializer2.lisp 2007/01/20 22:12:18 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/01/21 21:20:04 1.3 @@ -27,13 +27,15 @@ slot-definition-allocation slot-definition-name compute-slots - oid)) - + oid + int-byte-spec + array-type-from-byte + byte-from-array-type)) (in-package :elephant-serializer2) (eval-when (compile) - (declaim (optimize (speed 3) (safety 1) (space 0) (debug 0)) + (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1) (space 0) (debug 0)) (inline int-byte-spec serialize deserialize slots-and-values @@ -145,147 +147,153 @@ (defun serialize (frob bs sc) "Serialize a lisp value into a buffer-stream." (declare (type buffer-stream bs)) - (let ((*lisp-obj-id* 0) + (let ((*lisp-obj-id* -1) (*circularity-hash* (get-circularity-hash))) (labels - ((%serialize (frob) - (etypecase frob - ((integer #.most-negative-fixnum #.most-positive-fixnum) - (buffer-write-byte +fixnum+ bs) - (buffer-write-int frob bs)) - (null - (buffer-write-byte +nil+ bs)) - (symbol - (serialize-symbol frob bs sc)) - (string - (serialize-string frob bs)) - (persistent - (buffer-write-byte +persistent+ bs) - (buffer-write-int (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 - ;; CLHS says it should, but gives the class object itself, - ;; which cannot be directly serialized.... - (let ((tp (type-of frob))) - #+(or sbcl) - (if (not (symbolp tp)) - (setf tp (class-name (class-of frob)))) - (%serialize tp)) + ((%next-object-id () + (incf *lisp-obj-id*)) + (%serialize (frob) + (etypecase frob + ((integer #.most-negative-fixnum #.most-positive-fixnum) + (buffer-write-byte +fixnum+ bs) + (buffer-write-int frob bs)) + (null + (buffer-write-byte +nil+ bs)) + (symbol + (serialize-symbol frob bs sc)) + (string + (serialize-string frob bs)) + (persistent + (buffer-write-byte +persistent+ bs) + (buffer-write-int (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 + ;; CLHS says it should, but gives the class object itself, + ;; which cannot be directly serialized.... + (let ((tp (type-of frob))) + #+(or sbcl) + (if (not (symbolp tp)) + (setf tp (class-name (class-of frob)))) + (%serialize tp)) ) - #-(and :lispworks (or :win32 :linux)) - (single-float - (buffer-write-byte +single-float+ bs) - (buffer-write-float frob bs)) - (double-float - (buffer-write-byte +double-float+ bs) - (buffer-write-double frob bs)) - (standard-object - (buffer-write-byte +object+ bs) - (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) - (progn - (buffer-write-int (incf *lisp-obj-id*) bs) - (setf (gethash frob *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))))))) - (integer - (let* ((num (abs frob)) - (word-size (ceiling (/ (integer-length num) 32))) - (needed (* word-size 4))) - (declare (type fixnum word-size needed)) - (if (< frob 0) - (buffer-write-byte +negative-bignum+ bs) - (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! - ;; 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)))) - (rational - (buffer-write-byte +rational+ bs) - (%serialize (numerator frob)) - (%serialize (denominator frob))) - (character - (buffer-write-byte +char+ bs) - ;; might be wide! - (buffer-write-uint (char-code frob) bs)) - (cons - (buffer-write-byte +cons+ bs) - (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) - (progn - (buffer-write-int (incf *lisp-obj-id*) bs) - (setf (gethash frob *circularity-hash*) *lisp-obj-id*) - (%serialize (car frob)) - (%serialize (cdr frob)))))) - (pathname - (let ((pstring (namestring frob))) - (buffer-write-byte +pathname+ bs) - (serialize-string pstring bs))) - (hash-table - (buffer-write-byte +hash-table+ bs) - (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) - (progn - (buffer-write-int (incf *lisp-obj-id*) bs) - (setf (gethash frob *circularity-hash*) *lisp-obj-id*) - (%serialize (hash-table-test frob)) - (%serialize (hash-table-rehash-size frob)) - (%serialize (hash-table-rehash-threshold frob)) - (%serialize (hash-table-count frob)) - (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-int idp bs) -;; (progn -;; (buffer-write-int (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))))))) - (array - (buffer-write-byte +array+ bs) - (let ((idp (gethash frob *circularity-hash*))) - (if idp (buffer-write-int idp bs) - (progn - (buffer-write-int (incf *lisp-obj-id*) bs) - (setf (gethash frob *circularity-hash*) *lisp-obj-id*) - (buffer-write-byte - (logior (byte-from-array-type (array-element-type frob)) - (if (array-has-fill-pointer-p frob) - +fill-pointer-p+ 0) - (if (adjustable-array-p frob) - +adjustable-p+ 0)) - bs) - (let ((rank (array-rank frob))) - (buffer-write-int rank bs) - (loop for i fixnum from 0 below rank - do (buffer-write-int (array-dimension frob i) - bs))) - (when (array-has-fill-pointer-p frob) - (buffer-write-int (fill-pointer frob) bs)) - (loop for i fixnum from 0 below (array-total-size frob) - do - (%serialize (row-major-aref frob i))))))) - ))) + #-(and :lispworks (or :win32 :linux)) + (single-float + (buffer-write-byte +single-float+ bs) + (buffer-write-float frob bs)) + (double-float + (buffer-write-byte +double-float+ bs) + (buffer-write-double frob bs)) + (standard-object + (buffer-write-byte +object+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (let ((id (%next-object-id))) + (buffer-write-int id bs) + (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))))))) + (integer + (let* ((num (abs frob)) + (word-size (ceiling (/ (integer-length num) 32))) + (needed (* word-size 4))) + (declare (type fixnum word-size needed)) + (if (< frob 0) + (buffer-write-byte +negative-bignum+ bs) + (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! + ;; 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)))) + (rational + (buffer-write-byte +rational+ bs) + (%serialize (numerator frob)) + (%serialize (denominator frob))) + (character + (buffer-write-byte +char+ bs) + ;; might be wide! + (buffer-write-uint (char-code frob) bs)) + (cons + (buffer-write-byte +cons+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (let ((id (%next-object-id))) + (buffer-write-int id bs) + (setf (gethash frob *circularity-hash*) id)) + (%serialize (car frob)) + (%serialize (cdr frob)))))) + (pathname + (let ((pstring (namestring frob))) + (buffer-write-byte +pathname+ bs) + (serialize-string pstring bs))) + (hash-table + (buffer-write-byte +hash-table+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (let ((id (%next-object-id))) + (buffer-write-int id bs) + (setf (gethash frob *circularity-hash*) id)) + (%serialize (hash-table-test frob)) + (%serialize (hash-table-rehash-size frob)) + (%serialize (hash-table-rehash-threshold frob)) + (%serialize (hash-table-count frob)) + (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-int idp bs) + ;; (progn + ;; (buffer-write-int (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))))))) + (array + (buffer-write-byte +array+ bs) + (let ((idp (gethash frob *circularity-hash*))) + (if idp (buffer-write-int idp bs) + (progn + (let ((id (%next-object-id))) + (buffer-write-int id bs) + (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) + +fill-pointer-p+ 0) + (if (adjustable-array-p frob) + +adjustable-p+ 0)) + bs) + (let ((rank (array-rank frob))) + (buffer-write-int rank bs) + (loop for i fixnum from 0 below rank + do (buffer-write-int (array-dimension frob i) + bs))) + (when (array-has-fill-pointer-p frob) + (buffer-write-int (fill-pointer frob) bs)) + (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))) @@ -512,61 +520,3 @@ symbol) (error "Symbol lookup foobar! ID referred to does not exist in database")))))) - -;; -;; Array type tags -;; - -(declaim (type hash-table array-type-to-byte byte-to-array-type)) -(defvar array-type-to-byte (make-hash-table :test 'equalp)) -(defvar byte-to-array-type (make-hash-table :test 'equalp)) - -(setf (gethash 'T array-type-to-byte) #x00) -(setf (gethash 'base-char array-type-to-byte) #x01) -(setf (gethash 'character array-type-to-byte) #x02) -(setf (gethash 'single-float array-type-to-byte) #x03) -(setf (gethash 'double-float array-type-to-byte) #x04) -(setf (gethash '(complex single-float) array-type-to-byte) #x05) -(setf (gethash '(complex double-float) array-type-to-byte) #x06) -(setf (gethash 'fixnum array-type-to-byte) #x07) -(setf (gethash 'bit array-type-to-byte) #x08) - -(defun type= (t1 t2) - (and (subtypep t1 t2) (subtypep t2 t1))) - -(let ((counter 8)) - (loop for i from 2 to 65 - for spec = (list 'unsigned-byte i) - for uspec = (upgraded-array-element-type spec) - when (type= spec uspec) - do - (setf (gethash spec array-type-to-byte) (incf counter))) - (loop for i from 2 to 65 - for spec = (list 'signed-byte i) - for uspec = (upgraded-array-element-type spec) - when (type= spec uspec) - do - (setf (gethash spec array-type-to-byte) (incf counter)))) - -(loop for key being the hash-key of array-type-to-byte - using (hash-value value) - do - (setf (gethash value byte-to-array-type) key)) - -(defun array-type-from-byte (b) - (gethash b byte-to-array-type)) - -(defun byte-from-array-type (ty) - (the (unsigned-byte 8) (gethash ty array-type-to-byte))) - -(defun int-byte-spec (position) - (declare (optimize (speed 3) (safety 0)) - (type (unsigned-byte 24) position)) - #+(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/variables.lisp 2007/01/20 22:12:18 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/variables.lisp 2007/01/21 21:20:04 1.8 @@ -43,7 +43,14 @@ Users attempting to directly write this variable will run into an error") -(defvar *fast-symbols* nil) +;;;;;;;;;;;;;;;;;;;; +;;;; User Configuration for site customization + +(defvar *fast-symbols* nil) ;; for serializer2.lisp + +(defun ensure-loaded-configuration () + (setf *fast-symbols* + (elephant-system::get-config-option :fast-symbols (asdf:find-system :elephant)))) ;;;;;;;;;;;;;;;;; ;;;; Serializer optimization parameters

1 0

[elephant-cvs] CVS elephant
by ieslick 21 Jan '07

21 Jan '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv13092 Modified Files: TODO ele-bdb.asd elephant.asd Log Message: Up and limping; 0.6.1 working HEAD is in good shape again. Fails four tests (all cursor ranges). Object ID's are turned off for now - they are a user configuration option --- /project/elephant/cvsroot/elephant/TODO 2007/01/20 22:12:17 1.33 +++ /project/elephant/cvsroot/elephant/TODO 2007/01/21 21:20:03 1.34 @@ -1,5 +1,5 @@ -Last updated: November 21, 2006 +Last updated: January 20, 2007 Ongoing release plan notes: @@ -34,7 +34,10 @@ Multi-threading operation: - Make elephant threads appropriately bind dynamic variables? -x Verify that operations such as indexing are thread safe +- Thread safety for all global vars +- Thread safe API option for user-managed store-controller? +- Thread safe API for transactions +- Update to require BDB 4.5? BDB Features: ? Determine how to detect deadlock conditions as an optional run-safe mode? @@ -77,8 +80,8 @@ Documentation: - Add notes about with-transaction usage (abort & commit behavior on exit) -- Add notes about optimize-storage - Add notes about fast-symbols +- 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 @@ -86,16 +89,21 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- -January 2006 checkin -x Improved optimization options to be more user controlled (Pierre Thierry) + +January 2006 checkins; major features +x Modularize serializers for easy upgrade x Implement backend support for symbol-table protocol x Speed up symbol storage and reference using symbol id's -x Ensure serialization is thread-safe and reasonably efficient -x MCL 1.1 unicode support; rationalize other lisp support for unicode -x Modularize serializers for easy upgrade -x New build interface; all-lisp compilation (sans win32) +x Ensure serialization is thread-safe and reasonably efficient +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 Make sure to ensure thread safety in buffer-stream allocation! +x Ensure thread safety in buffer-stream allocation! + +January 2006 checkins; minor fixes +x New build interface; all-lisp compilation (sans win32), (help from elephant-devel) +x Verify that operations such as indexing are thread safe +x Diffs for lisp-controlled DB checkpointing (by Gabor Melis) +x Improved optimization options to be more user controlled (Pierre Thierry) x Investigated gensym warnings in berkeley-db.lisp (caused by an FFI macro, no harm in it) x Remove warnings in libberkeley-db.c --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/19 21:03:29 1.14 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2007/01/21 21:20:03 1.15 @@ -24,26 +24,6 @@ (in-package :ele-bdb-system) ;; -;; User parameters (bdb root and pthread, if necessary) -;; - -(defparameter *bdb-config* nil) - -(defun get-config-option (option component) - (unless *bdb-config* - (let ((filespec (make-pathname :defaults (asdf:component-pathname - -(asdf:component-system component)) - :name "my-config" - :type "sexp"))) - (unless (probe-file filespec) - (error "Missing file. Copy config.sexp in elephant root -directory to my-config.sexp and edit it appropriately.")) - (with-open-file (config filespec) - (setf *bdb-config* (read config))))) - (cdr (assoc option *bdb-config*))) - -;; ;; Compile bdb lib and load libraries ;; --- /project/elephant/cvsroot/elephant/elephant.asd 2007/01/19 21:03:29 1.22 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/01/21 21:20:03 1.23 @@ -20,7 +20,7 @@ (defpackage elephant-system (:use :cl :asdf) - (:export :elephant-c-source :compiler-options :foreign-libraries-to-load-first)) + (:export :elephant-c-source :compiler-options :foreign-libraries-to-load-first :get-config-option)) (in-package :elephant-system) @@ -51,6 +51,22 @@ (apply (find-symbol (symbol-name fn) (symbol-name :uffi)) args)) ;; +;; 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" + :type "sexp"))) + (unless (probe-file filespec) + (error "Missing file. Copy config.sexp in elephant root +directory to my-config.sexp and edit it appropriately.")) + (with-open-file (config filespec) + (cdr (assoc option (read config)))))) + +;; ;; Basic utilities for elephant c files ;; @@ -153,10 +169,10 @@ (:file "transactions") (:file "metaclasses") (:file "classes") + (:file "serializer") (:file "serializer1") ;; 0.6.0 db's (:file "serializer2") ;; 0.6.1 db's (:file "unicode2") - (:file "serializer") (:file "cache") (:file "controller") (:file "collections")

1 0

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

elephant-cvs January 2007