Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv4494/src/db-bdb
Modified Files: bdb-collections.lisp bdb-controller.lisp libberkeley-db.c package.lisp Log Message: Checkpoint for 0.6.1 feature set - BROKEN
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/11/11 18:41:10 1.10 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/12/16 19:35:10 1.11 @@ -36,17 +36,17 @@ (let ((sc (get-con bt))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (let ((buf (db-get-key-buffered (controller-btrees sc) key-buf value-buf))) - (if buf (values (deserialize buf :sc sc) T) + (if buf (values (deserialize buf sc) T) (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) + (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-btrees (get-con bt)) key-buf value-buf))) @@ -57,25 +57,43 @@ (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 (:store-controller (get-con bt)) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (serialize value value-buf) - (db-put-buffered (controller-btrees (get-con bt)) - key-buf value-buf - :auto-commit *auto-commit*) - value)) +;; (with-transaction () + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) + (db-put-buffered (controller-btrees sc) + key-buf value-buf + :auto-commit *auto-commit*))) +;; ) + value) + +;; (labels ((write-value () +;; (let ((sc (get-con bt))) +;; (with-buffer-streams (key-buf value-buf) +;; (buffer-write-int (oid bt) key-buf) +;; (serialize key key-buf sc) +;; (serialize value value-buf sc) +;; (db-put-buffered (controller-btrees sc) +;; key-buf value-buf +;; :auto-commit *auto-commit*) +;; value)))) +;; (if (eq *current-transaction* 0) +;; (with-transaction (:store-controller (get-con bt)) +;; (write-value)) +;; (write-value))))
(defmethod remove-kv (key (bt bdb-btree)) (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) - (db-delete-buffered (controller-btrees (get-con bt)) - key-buf :auto-commit *auto-commit*))) + (serialize key key-buf sc) + (db-delete-buffered (controller-btrees sc) + key-buf :auto-commit *auto-commit*))))
;; Secondary indices
@@ -123,9 +141,9 @@ (with-buffer-streams (primary-buf secondary-buf) (flet ((index (key skey) (buffer-write-int (oid bt) primary-buf) - (serialize key primary-buf) + (serialize key primary-buf sc) (buffer-write-int (oid index) secondary-buf) - (serialize skey secondary-buf) + (serialize skey secondary-buf sc) ;; should silently do nothing if ;; the key/value already exists (db-put-buffered @@ -175,8 +193,8 @@ (let ((indices (indices-cache bt))) (with-buffer-streams (key-buf value-buf secondary-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (with-transaction (:store-controller sc) (db-put-buffered (controller-btrees sc) key-buf value-buf) @@ -187,7 +205,7 @@ (when index? ;; Manually write value into secondary index (buffer-write-int (oid index) secondary-buf) - (serialize secondary-key secondary-buf) + (serialize secondary-key secondary-buf sc) ;; should silently do nothing if the key/value already ;; exists (db-put-buffered (controller-indices sc) @@ -202,7 +220,7 @@ (let ((sc (get-con bt))) (with-buffer-streams (key-buf secondary-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf sc) (with-transaction (:store-controller sc) (let ((value (get-value key bt))) (when value @@ -214,7 +232,7 @@ (funcall (key-fn index) index key value) (when index? (buffer-write-int (oid index) secondary-buf) - (serialize secondary-key secondary-buf) + (serialize secondary-key secondary-buf sc) ;; need to remove kv pairs with a cursor! -- ;; this is a C performance hack (db-delete-kv-buffered @@ -237,25 +255,26 @@ (declare (optimize (speed 3))) (with-buffer-streams (key-buf value-buf) (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) + (serialize key key-buf (get-con bt)) (let ((buf (db-get-key-buffered (controller-indices-assoc (get-con bt)) key-buf value-buf))) - (if buf (values (deserialize buf :sc (get-con bt)) T) + (if buf (values (deserialize buf (get-con bt)) T) (values nil nil)))))
(defmethod get-primary-key (key (bt btree-index)) (declare (optimize (speed 3))) - (with-buffer-streams (key-buf value-buf) - (buffer-write-int (oid bt) key-buf) - (serialize key key-buf) - (let ((buf (db-get-key-buffered - (controller-indices (get-con bt)) - key-buf value-buf))) - (if buf - (let ((oid (buffer-read-fixnum buf))) - (values (deserialize buf :sc (get-con bt)) oid)) - (values nil nil))))) + (let ((sc (get-con bt))) + (with-buffer-streams (key-buf value-buf) + (buffer-write-int (oid bt) key-buf) + (serialize key key-buf sc) + (let ((buf (db-get-key-buffered + (controller-indices sc) + key-buf value-buf))) + (if buf + (let ((oid (buffer-read-fixnum buf))) + (values (deserialize buf sc) oid)) + (values nil nil))))))
(defclass bdb-cursor (cursor) ((handle :accessor cursor-handle :initarg :handle)) @@ -286,20 +305,20 @@ (defmethod cursor-current ((cursor bdb-cursor)) (declare (optimize (speed 3))) (when (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf - :current t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil)))))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) key-buf value-buf + :current t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (progn (setf (cursor-initialized-p cursor) t) + (values t (deserialize key sc) + (deserialize val sc))) + (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) (multiple-value-bind (key val) @@ -307,15 +326,15 @@ key-buf value-buf :set-range t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t + (deserialize key sc) + (deserialize val sc))) + (setf (cursor-initialized-p cursor) nil)))))) ;;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) (if (db-cursor-set-buffered (cursor-handle cursor) @@ -328,10 +347,8 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) + (values t (deserialize key sc) + (deserialize val sc))) (setf (cursor-initialized-p cursor) nil)))) (multiple-value-bind (key val) (db-cursor-move-buffered (cursor-handle cursor) key-buf @@ -339,71 +356,75 @@ (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize key - :sc (get-con (cursor-btree cursor))) - (deserialize val - :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil)))))) + (values t (deserialize key sc) + (deserialize val sc ))) + (setf (cursor-initialized-p cursor) nil)))))))
(defmethod cursor-next ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) - key-buf value-buf :next t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor)))) - (setf (cursor-initialized-p cursor) nil)))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :next t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key sc) + (deserialize val sc)) + (setf (cursor-initialized-p cursor) nil))))) (cursor-first cursor))) (defmethod cursor-prev ((cursor bdb-cursor)) (declare (optimize (speed 3))) (if (cursor-initialized-p cursor) - (with-buffer-streams (key-buf value-buf) - (multiple-value-bind (key val) - (db-cursor-move-buffered (cursor-handle cursor) - key-buf value-buf :prev t) - (if (and key (= (buffer-read-int key) (cursor-oid cursor))) - (values t (deserialize key :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor)))) - (setf (cursor-initialized-p cursor) nil)))) - (cursor-last cursor))) + (let ((sc (get-con (cursor-btree cursor)))) + (with-buffer-streams (key-buf value-buf) + (multiple-value-bind (key val) + (db-cursor-move-buffered (cursor-handle cursor) + key-buf value-buf :prev t) + (if (and key (= (buffer-read-int key) (cursor-oid cursor))) + (values t (deserialize key sc) + (deserialize val sc)) + (setf (cursor-initialized-p cursor) nil)))) + (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) - (serialize key key-buf) + (serialize key key-buf sc) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set t) (if k - (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize val :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (progn + (setf (cursor-initialized-p cursor) t) + (values t key (deserialize val sc))) + (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) - (serialize key key-buf) + (serialize key key-buf sc) (multiple-value-bind (k val) (db-cursor-set-buffered (cursor-handle cursor) key-buf value-buf :set-range t) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t (deserialize k :sc (get-con (cursor-btree cursor))) - (deserialize val :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t (deserialize k sc) + (deserialize val sc))) + (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) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (multiple-value-bind (k v) (db-cursor-get-both-buffered (cursor-handle cursor) key-buf value-buf :get-both t) @@ -411,21 +432,22 @@ (if k (progn (setf (cursor-initialized-p cursor) t) (values t key value)) - (setf (cursor-initialized-p cursor) nil))))) + (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) - (serialize key key-buf) - (serialize value value-buf) + (serialize key key-buf sc) + (serialize value value-buf sc) (multiple-value-bind (k v) (db-cursor-get-both-buffered (cursor-handle cursor) key-buf value-buf :get-both-range t) (if k (progn (setf (cursor-initialized-p cursor) t) - (values t key (deserialize v :sc (get-con (cursor-btree cursor))))) - (setf (cursor-initialized-p cursor) nil))))) + (values t key (deserialize v sc))) + (setf (cursor-initialized-p cursor) nil))))))
(defmethod cursor-delete ((cursor bdb-cursor)) (declare (optimize (speed 3))) @@ -438,7 +460,7 @@ (when (and key (= (buffer-read-int key) (cursor-oid cursor))) ;; in case of a secondary index this should delete everything ;; as specified by the BDB docs. - (remove-kv (deserialize key :sc (get-con (cursor-btree cursor))) + (remove-kv (deserialize key (get-con (cursor-btree cursor))) (cursor-btree cursor))) (setf (cursor-initialized-p cursor) nil))) (error "Can't delete with uninitialized cursor!"))) @@ -458,7 +480,7 @@ (declare (ignore v)) (if (and k (= (buffer-read-int k) (cursor-oid cursor))) (setf (get-value - (deserialize k :sc (get-con (cursor-btree cursor))) + (deserialize k (get-con (cursor-btree cursor))) (cursor-btree cursor)) value) (setf (cursor-initialized-p cursor) nil)))) @@ -489,14 +511,11 @@ :current t) (if (and key (= (buffer-read-int key) (cursor-oid cursor))) (progn (setf (cursor-initialized-p cursor) t) - (values t - (deserialize - key - :sc (get-con (cursor-btree cursor))) - (deserialize - val - :sc (get-con (cursor-btree cursor))) - (progn (buffer-read-int pkey) (deserialize pkey))))
[275 lines skipped] --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/11/11 18:41:10 1.13 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/12/16 19:35:10 1.14 @@ -25,6 +25,8 @@ :accessor controller-environment) (oid-db :type (or null pointer-void) :accessor controller-oid-db) (oid-seq :type (or null pointer-void) :accessor controller-oid-seq) + (symid-db :type (or null pointer-void) :accessor controller-symid-db) + (symid-seq :type (or null pointer-void) :accessor controller-symid-seq) (btrees :type (or null pointer-void) :accessor controller-btrees) (indices :type (or null pointer-void) :accessor controller-indices) (indices-assoc :type (or null pointer-void) @@ -55,7 +57,20 @@ (string t) (otherwise nil))))
+(defmethod controller-version ((sc store-controller)) + (let ((version (controller-version 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) + (read stream)) + (with-open-file (stream path :direction :output) + (write *elephant-code-version* :stream stream))))))) + +;; ;; Open/close +;; + (defmethod open-controller ((sc bdb-store-controller) &key (recover t) (recover-fatal nil) (thread t) (deadlock-detect nil)) @@ -78,20 +93,20 @@ :auto-commit t :type DB-BTREE :create t :thread thread)
(setf (controller-btrees sc) btrees) - (db-bdb::db-set-lisp-compare btrees) + (db-bdb::db-set-lisp-compare btrees (controller-serializer-version sc)) (db-open btrees :file "%ELEPHANT" :database "%ELEPHANTBTREES" :auto-commit t :type DB-BTREE :create t :thread thread)
(setf (controller-indices sc) indices) - (db-bdb::db-set-lisp-compare indices) - (db-bdb::db-set-lisp-dup-compare indices) + (db-bdb::db-set-lisp-compare indices (controller-serializer-version sc)) + (db-bdb::db-set-lisp-dup-compare indices (controller-serializer-version sc)) (db-set-flags indices :dup-sort t) (db-open indices :file "%ELEPHANT" :database "%ELEPHANTINDICES" :auto-commit t :type DB-BTREE :create t :thread thread)
(setf (controller-indices-assoc sc) indices-assoc) - (db-bdb::db-set-lisp-compare indices-assoc) - (db-bdb::db-set-lisp-dup-compare indices-assoc) + (db-bdb::db-set-lisp-compare indices-assoc (controller-serializer-version sc)) + (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) @@ -110,6 +125,19 @@ :auto-commit t :create t :thread t) (setf (controller-oid-seq sc) oid-seq)))
+ (let ((db (db-create env))) + (setf (controller-symid-db sc) db) + (db-open db :file "%ELEPHANTSYMID" :database "%ELEPHANTSYMID" + :auto-commit t :type DB-BTREE :create t :thread thread) + (let ((symid-seq (db-sequence-create db))) + (db-sequence-set-cachesize symid-seq *cachesize*) + (db-sequence-set-flags symid-seq :seq-inc t :seq-wrap t) + (db-sequence-set-range symid-seq 0 most-positive-fixnum) + (db-sequence-initial-value symid-seq 0) + (db-sequence-open symid-seq "%ELEPHANTSYMID" + :auto-commit t :create t :thread t) + (setf (controller-symid-seq sc) symid-seq))) + (setf (slot-value sc 'root) (make-instance 'bdb-btree :from-oid -1 :sc sc))
@@ -121,6 +149,13 @@
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) @@ -130,6 +165,10 @@ ;; clean instance cache (flush-instance-cache sc) ;; close handles / environment + (db-sequence-close (controller-symid-seq sc)) + (setf (controller-symid-seq sc) nil) + (db-close (controller-symid-db sc)) + (setf (controller-symid-db sc) nil) (db-sequence-close (controller-oid-seq sc)) (setf (controller-oid-seq sc) nil) (db-close (controller-oid-db sc)) @@ -152,6 +191,17 @@ (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ :auto-commit t :txn-nosync t))
+(defmethod next-symid ((sc bdb-store-controller)) + (declare (type bdb-store-controller sc)) + (db-sequence-get-fixnum (controller-symid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t)) + + + +;; +;; Automated Deadlock Support +;; + (defparameter *deadlock-type-alist* '((:oldest . "o") (:youngest . "y") @@ -206,6 +256,10 @@ #+(and (not allegro) port) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) #+(and sbcl linux) (sb-ext:process-kill "/bin/kill" (list "-9" (format nil "~A" pid))))
+;; +;; Take advantage of release 4.4's compact storage feature. Hidden features of BDB only +;; + (defmethod optimize-storage ((ctrl bdb-store-controller) &key start-key stop-key (freelist-only nil) (free-space t) &allow-other-keys) @@ -219,59 +273,12 @@ (db-compact (controller-indices-assoc ctrl) nil nil end) (db-compact (controller-oid-db ctrl) nil nil end)) (progn - (serialize start-key start) + (serialize start-key start ctrl) (db-compact (controller-db ctrl) start - (when stop-key (serialize stop-key stop) stop) + (when stop-key (serialize stop-key stop ctrl) stop) end :freelist-only freelist-only :free-space free-space))) - (values (deserialize end :sc ctrl)))) - -;; -;; Persistent slot protocol -;; + (values (deserialize end ctrl))))
-(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) - (let ((buf (db-get-key-buffered (controller-db sc) - key-buf value-buf))) - (if buf (deserialize buf :sc 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) - (serialize new-value value-buf) - (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) - (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) - (db-delete-buffered (controller-db sc) key-buf - :transaction *current-transaction* - :auto-commit *auto-commit*)))
--- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/11/11 18:41:10 1.1 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.c 2006/12/16 19:35:10 1.2 @@ -55,6 +55,7 @@ ;;; */
+#include <stdint.h> #include <string.h> #include <wchar.h>
@@ -66,17 +67,41 @@ /* Pointer arithmetic utility functions */ /* should these be in network-byte order? probably not..... */ int read_int(char *buf, int offset) { - int i; + int int; memcpy(&i, buf+offset, sizeof(int)); return i; }
-unsigned int read_uint(char *buf, int offset) { - unsigned int ui; +int read_uint(char *buf, int offset) { + unsigned int ui; memcpy(&ui, buf+offset, sizeof(unsigned int)); return ui; }
+int32_t read_int32(char *buf, int offset) { + int int32_t; + memcpy(&i, buf+offset, sizeof(int32_t)); + return i; +} + +uint32_t read_uint32(char *buf, int offset) { + uint32_t ui; + memcpy(&ui, buf+offset, sizeof(uint32_t)); + return ui; +} + +int64_t read_int64(char *buf, int offset) { + int64_t i; + memcpy(&i, buf+offset, sizeof(int64_t)); + return i; +} + +uint64_t read_uint64(char *buf, int offset) { + uint64_t ui; + memcpy(&ui, buf+offset, sizeof(uint64_t)); + return ui; +} + float read_float(char *buf, int offset) { float f; memcpy(&f, buf+offset, sizeof(float)); @@ -89,14 +114,33 @@ return d; }
+/* Platform specific integer */ void write_int(char *buf, int num, int offset) { memcpy(buf+offset, &num, sizeof(int)); }
-void write_uint(char *buf, unsigned int num, int offset) { +void write_uint(char *buf, unsighed int num, int offset) { memcpy(buf+offset, &num, sizeof(unsigned int)); }
+ +/* Well-defined integer widths */ +void write_int32(char *buf, int32_t num, int offset) { + memcpy(buf+offset, &num, sizeof(int32_t)); +} + +void write_uint32(char *buf, uint32_t num, int offset) { + memcpy(buf+offset, &num, sizeof(uint32_t)); +} + +void write_int64(char *buf, int64_t num, int offset) { + memcpy(buf+offset, &num, sizeof(int64_t)); +} + +void write_uint64(char *buf, uint64_t num, int offset) { + memcpy(buf+offset, &num, sizeof(uint64_t)); +} + void write_float(char *buf, float num, int offset) { memcpy(buf+offset, &num, sizeof(float)); } @@ -228,7 +272,7 @@ return db->set_dup_compare(db, dup_compare_fcn); }
-#define type_numeric(c) ((c)<8) +#define type_numeric1(c) ((c)<8) #include <math.h>
double read_num(char *buf); @@ -239,7 +283,9 @@
/* Inspired by the BDB docs. We have to memcpy to insure memory alignment. */ -int lisp_compare(DB *dbp, const DBT *a, const DBT *b) { + +/* Original serializer */ +int lisp_compare1(DB *dbp, const DBT *a, const DBT *b) { int difference; double ddifference; char *ad, *bd, at, bt; @@ -262,7 +308,7 @@ at = ad[4]; bt = bd[4];
/* Compare numerics. */ - if (type_numeric(at) && type_numeric(bt)) { + 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; @@ -270,6 +316,7 @@ }
/* Compare types. */ + if difference = at - bt; if (difference) return difference;
@@ -294,12 +341,81 @@ } }
-int db_set_lisp_compare(DB *db) { - return db->set_bt_compare(db, &lisp_compare); +#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); + if (ddifference > 0) return 1; + else if (ddifference < 0) return -1; + return 0; + } + + /* Compare types. */ + if + difference = at - bt; + if (difference) return difference; + + ;; TODO: compare strings of different sizes? + ;; TODO: compare symbol-ids? + + /* Same type! */ + switch (at) { + case #x3F: /* nil */ + return 0; + case 9: /* 8-bit string */ + 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(ad+9, read_int32(ad, 5), bd+9, read_int32(bd, 5)); + default: + return lex_cmp(ad+5, (a->size)-5, bd+5, (b->size)-5); + } +} + +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_set_lisp_dup_compare(DB *db) { - return db->set_dup_compare(db, &lisp_compare); +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); + } }
#ifndef exp2 --- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/11/11 18:41:10 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/12/16 19:35:10 1.3 @@ -26,7 +26,7 @@ Elephant, but with some magic for Elephant. In general there is a 1-1 mapping from functions here and functions in Berkeley DB, so refer to their documentation for details.") - (:use common-lisp uffi elephant-memutil elephant elephant-backend) + (:use common-lisp uffi elephant-memutil elephant-backend elephant) #+cmu (:use alien) #+sbcl @@ -40,4 +40,5 @@ #+openmcl (:import-from :ccl #:byte-length) - ) + (:export + #:optimize-storage))