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))
