Update of /project/elephant/cvsroot/elephant/src In directory common-lisp.net:/tmp/cvs-serv4345/src

Modified Files: utils.lisp sleepycat.lisp serializer.lisp controller.lisp berkeley-db.lisp Log Message: updates for sbcl unicode, sleepycat 4.3, new sequences and degree-2

Date: Thu Feb 24 02:06:10 2005 Author: blee

Index: elephant/src/utils.lisp diff -u elephant/src/utils.lisp:1.7 elephant/src/utils.lisp:1.8 --- elephant/src/utils.lisp:1.7 Sun Sep 19 19:52:18 2004 +++ elephant/src/utils.lisp Thu Feb 24 02:06:08 2005 @@ -47,6 +47,9 @@ (type hash-table *circularity-hash*) (type boolean *auto-commit*))

+(defvar *cachesize* 100 + "Size of the OID sequence cache.") + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Thread-local specials @@ -106,7 +109,7 @@ (environment '(controller-environment *store-controller*)) (parent '*current-transaction*) - dirty-read txn-nosync + degree-2 dirty-read txn-nosync txn-nowait txn-sync (retries 100)) &body body) @@ -118,6 +121,7 @@ `(sleepycat:with-transaction (:transaction ,transaction :environment ,environment :parent ,parent + :degree-2 ,degree-2 :dirty-read ,dirty-read :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait

Index: elephant/src/sleepycat.lisp diff -u elephant/src/sleepycat.lisp:1.12 elephant/src/sleepycat.lisp:1.13 --- elephant/src/sleepycat.lisp:1.12 Tue Sep 21 03:37:21 2004 +++ elephant/src/sleepycat.lisp Thu Feb 24 02:06:09 2005 @@ -71,7 +71,11 @@ #:buffer-write-uint #:buffer-write-float #:buffer-write-double #:buffer-write-string #:buffer-read-byte #:buffer-read-fixnum #:buffer-read-int #:buffer-read-uint #:buffer-read-float - #:buffer-read-double #:buffer-read-string #:byte-length + #:buffer-read-double + #-(and allegro ics) #:buffer-read-ucs1-string + #+(or lispworks (and allegro ics)) #:buffer-read-ucs2-string + #+(and sbcl sb-unicode) #:buffer-read-ucs4-string + #:byte-length #:pointer-int #:pointer-void #:array-or-pointer-char @@ -92,7 +96,14 @@ #:db-cursor-pget-both-buffered #:db-cursor-put-buffered #:db-transaction-begin #:db-transaction-abort #:db-transaction-commit #:with-transaction - #:db-transaction-id #:db-env-lock-id #:db-env-lock-id-free + #:db-transaction-id + #:db-sequence-create #:db-sequence-open #:db-sequence-close + #:db-sequence-get #:db-sequence-get-fixnum + #:db-sequence-initial-value #:db-sequence-remove + #:db-sequence-set-cachesize #:db-sequence-get-cachesize + #:db-sequence-set-flags #:db-sequence-set-range + #:db-sequence-get-range + #:db-env-lock-id #:db-env-lock-id-free #:db-env-lock-get #:db-env-lock-put #:with-lock #:db-env-set-timeout #:db-env-get-timeout #:db-env-set-lock-detect #:db-env-get-lock-detect @@ -132,12 +143,12 @@ (uffi:load-foreign-library ;; Sleepycat: this works on linux #+linux - "/usr/local/BerkeleyDB.4.2/lib/libdb.so" + "/db/ben/lisp/db43/lib/libdb.so" ;; this works on FreeBSD #+(and (or bsd freebsd) (not darwin)) - "/usr/local/lib/db42/libdb.so" + "/usr/local/lib/db43/libdb.so" #+darwin - "/usr/local/BerkeleyDB.4.2/lib/libdb.dylib" + "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib" :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!"))

@@ -165,7 +176,7 @@

(declaim (inline read-int read-uint read-float read-double write-int write-uint write-float write-double - offset-char-pointer copy-str-to-buf copy-bufs + offset-char-pointer copy-str-to-buf %copy-str-to-buf copy-bufs ;;resize-buffer-stream ;;buffer-stream-buffer buffer-stream-size buffer-stream-position ;;buffer-stream-length @@ -174,7 +185,9 @@ buffer-write-float buffer-write-double buffer-write-string buffer-read-byte buffer-read-fixnum buffer-read-int buffer-read-uint buffer-read-float buffer-read-double - buffer-read-string)) + #-(and allegreo ics) buffer-read-ucs1-string + #+(or lispworks (and allegro ics)) buffer-read-ucs2-string + #+(and sbcl sb-unicode) buffer-read-ucs4-string))

;; Constants and Flags ;; eventually write a macro which generates a custom flag function. @@ -182,8 +195,8 @@ ;I don't like the UFFI syntax for enumerations (defconstant DB-BTREE 1) (defconstant DB-HASH 2) -(defconstant DB-QUEUE 3) -(defconstant DB-RECNO 4) +(defconstant DB-RECNO 3) +(defconstant DB-QUEUE 4) (defconstant DB-UNKNOWN 5)

(defconstant DB_AUTO_COMMIT #x1000000) @@ -201,7 +214,8 @@ (defconstant DB_SYSTEM_MEM #x0400000) (defconstant DB_THREAD #x0000040) (defconstant DB_FORCE #x0000004) -(defconstant DB_DIRTY_READ #x2000000) +(defconstant DB_DEGREE_2 #x2000000) +(defconstant DB_DIRTY_READ #x4000000) (defconstant DB_CREATE #x0000001) (defconstant DB_EXCL #x0001000) (defconstant DB_NOMMAP #x0000008) @@ -210,7 +224,7 @@ (defconstant DB_TXN_NOSYNC #x0000100) (defconstant DB_TXN_NOWAIT #x0001000) (defconstant DB_TXN_SYNC #x0002000) -(defconstant DB_LOCK_NOWAIT #x001) +(defconstant DB_LOCK_NOWAIT #x002) (defconstant DB_DUP #x0000002) (defconstant DB_DUPSORT #x0000004)

@@ -238,6 +252,11 @@

(defconstant DB_POSITION 24)

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

@@ -245,16 +264,17 @@ (defconstant DB_KEYEXIST -30996) (defconstant DB_LOCK_DEADLOCK -30995) (defconstant DB_LOCK_NOTGRANTED -30994) -(defconstant DB_NOTFOUND -30990) +(defconstant DB_NOTFOUND -30989)

(defconstant DB_LOCK_DEFAULT 1) (defconstant DB_LOCK_EXPIRE 2) (defconstant DB_LOCK_MAXLOCKS 3) -(defconstant DB_LOCK_MINLOCKS 4) -(defconstant DB_LOCK_MINWRITE 5) -(defconstant DB_LOCK_OLDEST 6) -(defconstant DB_LOCK_RANDOM 7) -(defconstant DB_LOCK_YOUNGEST 8) +(defconstant DB_LOCK_MAXWRITE 4) +(defconstant DB_LOCK_MINLOCKS 5) +(defconstant DB_LOCK_MINWRITE 6) +(defconstant DB_LOCK_OLDEST 7) +(defconstant DB_LOCK_RANDOM 8) +(defconstant DB_LOCK_YOUNGEST 9)

(defvar +NULL-VOID+ (make-null-pointer :void) "A null pointer to a void type.") @@ -299,6 +319,22 @@ (defvar *buffer-streams* (make-array 0 :adjustable t :fill-pointer t) "Vector of buffer-streams, which you can grab / return.")

+(defconstant +2^32+ 4294967296) +(defconstant +2^64+ 18446744073709551616) +(defconstant +2^32-1+ (1- +2^32+)) + +(defmacro make-64-bit-integer (high32 low32) + `(+ ,low32 (ash ,high32 32))) + +(defmacro high32 (int64) + `(ash ,int64 -32)) + +(defmacro low32 (int64) + `(logand ,int64 +2^32-1+)) + +(defmacro split-64-bit-integer (int64) + `(values (ash ,int64 -32) (logand ,int64 +2^32-1+))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; buffer-streams @@ -498,9 +534,13 @@ (defmacro byte-length (s) "Return the number of bytes of the internal representation of a string." - #+(or lispworks (and allegro ics)) + #+(and allegro ics) `(let ((l (length ,s))) (+ l l)) - #-(or lispworks (and allegro ics)) + #+(or (and sbcl sb-unicode) lispworks) + `(etypecase ,s + (base-string (length ,s)) + (string (* (length ,s) #+sbcl 4 #+lispworks 2))) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) `(length ,s))

;; for copying the bytes of a string to a foreign buffer @@ -517,14 +557,27 @@ :returning :void)

#+(or cmu sbcl scl) -(def-function ("copy_buf" copy-str-to-buf) +(def-function ("copy_buf" %copy-str-to-buf) ((dest array-or-pointer-char) (dest-offset :int) - (src :cstring) + (src array-or-pointer-char) (src-offset :int) (length :int)) :returning :void)

+#+(or cmu sbcl scl) +(defun copy-str-to-buf (d do s so l) + (declare (optimize (speed 3) (safety 0)) + (type array-or-pointer-char d) + (type fixnum do so l) + (type string s)) + (%copy-str-to-buf d do + #+sbcl + (sb-sys:vector-sap s) + #+(or cmu scl) + (sys:vector-sap s) + so l)) + ;; but OpenMCL can't directly pass string bytes. #+openmcl (defun copy-str-to-buf (dest dest-offset src src-offset length) @@ -775,27 +828,62 @@ (setf (buffer-stream-position bs) (+ position 8)) (read-double (buffer-stream-buffer bs) position)))

-(defun buffer-read-string (bs length) - "Read a string. On Unicode Lisps this is a 16-bit operation!" +(defun buffer-read-ucs1-string (bs byte-length) + "Read a UCS1 string." (declare (optimize (speed 3) (safety 0)) (type buffer-stream bs) - (type fixnum length)) + (type fixnum byte-length)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position byte-length)) + #-(and sbcl sb-unicode) + (convert-from-foreign-string + (offset-char-pointer (buffer-stream-buffer bs) position) + :length byte-length :null-terminated-p nil) + #+(and sbcl sb-unicode) + (let ((res (make-string byte-length :element-type 'base-char))) + (sb-kernel:copy-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) + res))) + +#+(or lispworks (and allegro ics)) +(defun buffer-read-ucs2-string (bs byte-length) + "Read a UCS2 string." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum byte-length)) (let ((position (buffer-stream-position bs))) - (setf (buffer-stream-position bs) (+ position length)) + (setf (buffer-stream-position bs) (+ position byte-length)) ;; wide!!! #+(and allegro ics) (excl:native-to-string (offset-char-pointer (buffer-stream-buffer bs) position) - :length length + :length byte-length :external-format :unicode) #+lispworks (fli:convert-from-foreign-string (offset-char-pointer (buffer-stream-buffer bs) position) - :length length :external-format :unicode :null-terminated-p nil) - #-(or lispworks (and allegro ics)) - (convert-from-foreign-string - (offset-char-pointer (buffer-stream-buffer bs) position) - :length length :null-terminated-p nil))) + :length byte-length :external-format :unicode :null-terminated-p nil))) + +#+(and sbcl sb-unicode) +(defun buffer-read-ucs4-string (bs byte-length) + "Read a UCS4 string." + (declare (optimize (speed 3) (safety 0)) + (type buffer-stream bs) + (type fixnum byte-length)) + (let ((position (buffer-stream-position bs))) + (setf (buffer-stream-position bs) (+ position byte-length)) + (let ((res (make-string (/ byte-length 4) :element-type 'character))) + (sb-kernel:copy-from-system-area + (sb-alien:alien-sap (buffer-stream-buffer bs)) + (* position sb-vm:n-byte-bits) + res + (* sb-vm:vector-data-offset sb-vm:n-word-bits) + (* byte-length sb-vm:n-byte-bits)) + res)))

;; Wrapper macro -- handles errno return values ;; makes flags into keywords @@ -881,12 +969,14 @@

(defmacro flags (&key auto-commit joinenv init-cdb init-lock init-log init-mpool init-rep init-txn recover recover-fatal lockdown - private system-mem thread force dirty-read create excl nommap + private system-mem thread force degree-2 dirty-read create + excl nommap rdonly truncate txn-nosync txn-nowait txn-sync lock-nowait dup dup-sort current first get-both get-both-range last next next-dup next-nodup prev prev-nodup set set-range after before keyfirst keylast - no-dup-data no-overwrite nosync position set-lock-timeout + no-dup-data no-overwrite nosync position + seq-dec seq-inc seq-wrap set-lock-timeout set-transaction-timeout) (let ((flags (gensym))) `(let ((,flags 0)) @@ -906,6 +996,7 @@ ,@(when system-mem `((when ,system-mem (setq ,flags (logior ,flags DB_SYSTEM_MEM))))) ,@(when thread `((when ,thread (setq ,flags (logior ,flags DB_THREAD))))) ,@(when force `((when ,force (setq ,flags (logior ,flags DB_FORCE))))) + ,@(when degree-2 `((when ,degree-2 (setq ,flags (logior ,flags DB_DEGREE_2))))) ,@(when dirty-read `((when ,dirty-read (setq ,flags (logior ,flags DB_DIRTY_READ))))) ,@(when create `((when ,create (setq ,flags (logior ,flags DB_CREATE))))) ,@(when excl `((when ,excl (setq ,flags (logior ,flags DB_EXCL))))) @@ -938,6 +1029,9 @@ ,@(when no-overwrite `((when ,no-overwrite (setq ,flags (logior ,flags DB_NOOVERWRITE))))) ,@(when nosync `((when ,nosync (setq ,flags (logior ,flags DB_NOSYNC))))) ,@(when position `((when ,position (setq ,flags (logior ,flags DB_POSITION))))) + ,@(when seq-dec `((when ,seq-dec (setq ,flags (logior ,flags DB_SEQ_DEC))))) + ,@(when seq-inc `((when ,seq-inc (setq ,flags (logior ,flags DB_SEQ_INC))))) + ,@(when seq-wrap `((when ,seq-wrap (setq ,flags (logior ,flags DB_SEQ_WRAP))))) ,@(when set-lock-timeout `((when ,set-lock-timeout (setq ,flags (logior ,flags DB_SET_LOCK_TIMEOUT))))) ,@(when set-transaction-timeout `((when ,set-transaction-timeout (setq ,flags (logior ,flags DB_SET_TXN_TIMEOUT))))) ,flags)))

Index: elephant/src/serializer.lisp diff -u elephant/src/serializer.lisp:1.9 elephant/src/serializer.lisp:1.10 --- elephant/src/serializer.lisp:1.9 Thu Sep 16 06:20:41 2004 +++ elephant/src/serializer.lisp Thu Feb 24 02:06:10 2005 @@ -62,20 +62,19 @@ (defconstant +nil+ 8)

;; 8-bit -#-(or lispworks (and allegro ics)) -(defconstant +symbol+ 9) -#-(or lispworks (and allegro ics)) -(defconstant +string+ 10) -#-(or lispworks (and allegro ics)) -(defconstant +pathname+ 11) +(defconstant +ucs1-symbol+ 9) +(defconstant +ucs1-string+ 10) +(defconstant +ucs1-pathname+ 11)

;; 16-bit -#+(or lispworks (and allegro ics)) -(defconstant +symbol+ 12) -#+(or lispworks (and allegro ics)) -(defconstant +string+ 13) -#+(or lispworks (and allegro ics)) -(defconstant +pathname+ 14) +(defconstant +ucs2-symbol+ 12) +(defconstant +ucs2-string+ 13) +(defconstant +ucs2-pathname+ 14) + +;; 32-bit +(defconstant +ucs4-symbol+ 20) +(defconstant +ucs4-string+ 21) +(defconstant +ucs4-pathname+ 22)

(defconstant +persistent+ 15) (defconstant +cons+ 16) @@ -105,7 +104,15 @@ (symbol (let ((s (symbol-name frob))) (declare (type string s) (dynamic-extent s)) - (buffer-write-byte +symbol+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-symbol+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase s + (base-string +ucs1-symbol+) + (string #+sbcl +ucs4-symbol+ #+lispwoks +ucs2-symbol+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-symbol+ + bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs) (let ((package (symbol-package frob))) @@ -113,7 +120,15 @@ (%serialize (package-name package)) (%serialize nil))))) (string - (buffer-write-byte +string+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-string+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase frob + (base-string +ucs1-string+) + (string #+sbcl +ucs4-string+ #+lispwoks +ucs2-string+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-string+ + bs) (buffer-write-int (byte-length frob) bs) (buffer-write-string frob bs)) (persistent @@ -134,7 +149,15 @@ (pathname (let ((s (namestring frob))) (declare (type string s) (dynamic-extent s)) - (buffer-write-byte +pathname+ bs) + (buffer-write-byte + #+(and allegro ics) +ucs2-pathname+ + #+(or (and sbcl sb-unicode) lispworks) + (etypecase s + (base-string +ucs1-pathname+) + (string #+sbcl +ucs4-pathname+ #+lispwoks +ucs2-pathname+)) + #-(or lispworks (and allegro ics) (and sbcl sb-unicode)) + +ucs1-pathname+ + bs) (buffer-write-int (byte-length s) bs) (buffer-write-string s bs))) (integer @@ -252,14 +275,36 @@ ((= tag +fixnum+) (buffer-read-fixnum bs)) ((= tag +nil+) nil) - ((= tag +symbol+) - (let ((name (buffer-read-string bs (buffer-read-fixnum bs))) + #-(and allegro ics) + ((= tag +ucs1-symbol+) + (let ((name (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-symbol+) + (let ((name (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) (maybe-package-name (%deserialize bs))) (if maybe-package-name (intern name (find-package maybe-package-name)) (make-symbol name)))) - ((= tag +string+) - (buffer-read-string bs (buffer-read-fixnum bs))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-symbol+) + (let ((name (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) + (maybe-package-name (%deserialize bs))) + (if maybe-package-name + (intern name (find-package maybe-package-name)) + (make-symbol name)))) + #-(and allegro ics) + ((= tag +ucs1-string+) + (buffer-read-ucs1-string bs (buffer-read-fixnum bs))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-string+) + (buffer-read-ucs2-string bs (buffer-read-fixnum bs))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-string+) + (buffer-read-ucs4-string bs (buffer-read-fixnum bs))) ((= tag +persistent+) (get-cached-instance *store-controller* (buffer-read-fixnum bs) @@ -270,9 +315,18 @@ (buffer-read-double bs)) ((= tag +char+) (code-char (buffer-read-uint bs))) - ((= tag +pathname+) + #-(and allegro ics) + ((= tag +ucs1-pathname+) + (parse-namestring + (or (buffer-read-ucs1-string bs (buffer-read-fixnum bs)) ""))) + #+(or lispworks (and allegro ics)) + ((= tag +ucs2-pathname+) + (parse-namestring + (or (buffer-read-ucs2-string bs (buffer-read-fixnum bs)) ""))) + #+(and sbcl sb-unicode) + ((= tag +ucs4-pathname+) (parse-namestring - (or (buffer-read-string bs (buffer-read-fixnum bs)) ""))) + (or (buffer-read-ucs4-string bs (buffer-read-fixnum bs)) ""))) ((= tag +positive-bignum+) (deserialize-bignum bs (buffer-read-fixnum bs) t)) ((= tag +negative-bignum+)

Index: elephant/src/controller.lisp diff -u elephant/src/controller.lisp:1.11 elephant/src/controller.lisp:1.12 --- elephant/src/controller.lisp:1.11 Sun Sep 19 19:49:25 2004 +++ elephant/src/controller.lisp Thu Feb 24 02:06:10 2005 @@ -49,6 +49,8 @@ (environment :type (or null pointer-void) :accessor controller-environment) (db :type (or null pointer-void) :accessor controller-db) + (oid-db :type (or null pointer-void) :accessor controller-oid-db) + (oid-seq :type (or null pointer-void) :accessor controller-oid-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) @@ -102,33 +104,11 @@ ;; Should get cached since make-instance calls cache-instance (make-instance class-name :from-oid oid))))

-;; OID stuff -;; This stuff is all a hack until sequences appear in Sleepycat 4.3 -(defvar %oid-entry (uffi:allocate-foreign-object :char 12)) -(defvar %oid-lock (uffi:allocate-foreign-object :char 16)) - -(eval-when (:load-toplevel) - (loop for c across "%ELEPHANTOID" - for i from 0 to 11 - do (setf (uffi:deref-array %oid-entry '(:array :char) i) - (char-code c))) - (loop for c across "%ELEPHANTOIDLOCK" - for i from 0 to 15 - do (setf (uffi:deref-array %oid-lock '(:array :char) i) - (char-code c))) - ) - -(defvar %oid-entry-length 12) -(defvar %oid-lock-length 16) - (defun next-oid (sc) "Get the next OID." (declare (type store-controller sc)) - (sleepycat::next-counter (controller-environment sc) - (controller-db sc) - *current-transaction* - %oid-entry %oid-entry-length - %oid-lock %oid-lock-length)) + (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ + :auto-commit t :txn-nosync t))

;; Open/close (defmethod open-controller ((sc store-controller) &key (recover nil) @@ -166,20 +146,23 @@ (db-open indices-assoc :file "%ELEPHANT" :database "%ELEPHANTINDICES" :auto-commit t :type DB-UNKNOWN :thread thread :rdonly t) (sleepycat::db-fake-associate btrees indices-assoc :auto-commit t) + + (let ((db (db-create env))) + (setf (controller-oid-db sc) db) + (db-open db :file "%ELEPHANTOID" :database "%ELEPHANTOID" + :auto-commit t :type DB-BTREE :create t :thread thread) + (let ((oid-seq (db-sequence-create db))) + (db-sequence-set-cachesize oid-seq *cachesize*) + (db-sequence-set-flags oid-seq :seq-inc t :seq-wrap t) + (db-sequence-set-range oid-seq 0 most-positive-fixnum) + (db-sequence-initial-value oid-seq 0) + (db-sequence-open oid-seq "%ELEPHANTOID" + :auto-commit t :create t :thread t) + (setf (controller-oid-seq sc) oid-seq)))

(let ((root (make-instance 'btree :from-oid -1))) - (setf (slot-value sc 'root) root) - (with-transaction () - (with-buffer-streams (key-buf value-buf) - (let ((key-b (buffer-stream-buffer key-buf))) - (setf (buffer-stream-buffer key-buf) %oid-entry) - (setf (sleepycat::buffer-stream-size key-buf) %oid-entry-length) - (unless (db-get-key-buffered db key-buf value-buf) - (reset-buffer-stream value-buf) - (buffer-write-int 0 value-buf) - (db-put-buffered db key-buf value-buf)) - (setf (buffer-stream-buffer key-buf) key-b)))) - sc)))) + (setf (slot-value sc 'root) root)) + sc)))

(defmethod close-controller ((sc store-controller)) (when (slot-value sc 'root) @@ -188,6 +171,10 @@ ;; clean instance cache (setf (instance-cache sc) (make-cache-table :test 'eql)) ;; close handles / environment + (db-sequence-close (controller-oid-seq sc)) + (setf (controller-oid-seq sc) nil) + (db-close (controller-oid-db sc)) + (setf (controller-oid-db sc) nil) (db-close (controller-indices-assoc sc)) (setf (controller-indices-assoc sc) nil) (db-close (controller-indices sc)) @@ -232,6 +219,7 @@ (progn ,@body) (close-controller *store-controller*))))

+;;; Make these respect the transaction keywords (e.g. degree-2) (defun start-transaction (&key (parent *current-transaction*)) "Start a transaction. May be nested but not interleaved." (vector-push-extend *current-transaction* *transaction-stack*)

Index: elephant/src/berkeley-db.lisp diff -u elephant/src/berkeley-db.lisp:1.2 elephant/src/berkeley-db.lisp:1.3 --- elephant/src/berkeley-db.lisp:1.2 Sun Sep 19 19:46:56 2004 +++ elephant/src/berkeley-db.lisp Thu Feb 24 02:06:10 2005 @@ -64,7 +64,9 @@ %db-txn-begin db-transaction-begin %db-txn-abort db-transaction-abort %db-txn-commit db-transaction-commit - %db-transaction-id + %db-transaction-id + %db-sequence-get db-sequence-get + %db-sequence-get-lower db-sequence-get-fixnum ))

;; Environment @@ -298,7 +300,7 @@

(defun db-get-key-buffered (db key-buffer-stream value-buffer-stream &key (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "Get a key / value pair from a DB. The key is encoded in a buffer-stream. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for @@ -306,7 +308,7 @@ (declare (optimize (speed 3) (safety 0)) (type pointer-void db transaction) (type buffer-stream key-buffer-stream value-buffer-stream) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (loop for value-length fixnum = (buffer-stream-length value-buffer-stream) do @@ -318,6 +320,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -347,7 +350,7 @@ (defun db-get-buffered (db key value-buffer-stream &key (key-size (length key)) (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "Get a key / value pair from a DB. The key is passed as a string. Space for the value is passed in as a buffer-stream. On success the buffer-stream is returned for @@ -357,7 +360,7 @@ (type string key) (type buffer-stream value-buffer-stream) (type fixnum key-size) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (with-cstring (k key) (loop for value-length fixnum = (buffer-stream-length value-buffer-stream) @@ -368,6 +371,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -385,7 +389,7 @@

(defun db-get (db key &key (key-size (length key)) (transaction *current-transaction*) - auto-commit get-both dirty-read) + auto-commit get-both degree-2 dirty-read) "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." @@ -393,7 +397,7 @@ (type pointer-void db transaction) (type string key) (type fixnum key-size) - (type boolean auto-commit get-both dirty-read)) + (type boolean auto-commit get-both degree-2 dirty-read)) (with-cstring (k key) (with-buffer-streams (value-buffer-stream) (loop @@ -405,6 +409,7 @@ value-length (flags :auto-commit auto-commit :get-both get-both + :degree-2 degree-2 :dirty-read dirty-read)) (declare (type fixnum result-size errno)) (cond @@ -585,13 +590,14 @@ :returning :pointer-void)

(defun db-cursor (db &key (transaction *current-transaction*) - dirty-read) + degree-2 dirty-read) "Create a cursor." (declare (optimize (speed 3) (safety 0)) (type pointer-void db) - (type boolean dirty-read) + (type boolean degree-2 dirty-read) (type pointer-int *errno-buffer*)) - (let* ((curs (%db-cursor db transaction (flags :dirty-read dirty-read) + (let* ((curs (%db-cursor db transaction (flags :degree-2 degree-2 + :dirty-read dirty-read) *errno-buffer*)) (errno (deref-array *errno-buffer* '(:array :int) 0))) (declare (type pointer-void curs) @@ -1015,17 +1021,18 @@ :returning :pointer-void)

(defun db-transaction-begin (env &key (parent *current-transaction*) - dirty-read txn-nosync txn-nowait + degree-2 dirty-read txn-nosync txn-nowait txn-sync) "Start a transaction. Transactions may be nested." (declare (optimize (speed 3) (safety 0)) (type pointer-void env parent) - (type boolean dirty-read txn-nosync txn-nowait + (type boolean degree-2 dirty-read txn-nosync txn-nowait txn-sync) (type pointer-int *errno-buffer*)) (let* ((txn (%db-txn-begin env parent - (flags :dirty-read dirty-read + (flags :degree-2 degree-2 + :dirty-read dirty-read :txn-nosync txn-nosync :txn-nowait txn-nowait :txn-sync txn-sync) @@ -1102,7 +1109,7 @@ (defmacro with-transaction ((&key transaction environment (parent '*current-transaction*) (retries 100) - dirty-read txn-nosync + degree-2 dirty-read txn-nosync txn-nowait txn-sync) &body body) "Execute a body with a transaction in place. On success, @@ -1120,6 +1127,7 @@ (let ((,txn (db-transaction-begin ,environment :parent ,parent + :degree-2 ,degree-2 :dirty-read ,dirty-read :txn-nosync ,txn-nosync :txn-nowait ,txn-nowait @@ -1332,7 +1340,195 @@ "Sets the duplicate comparision function to a hand-cooked function for Elephant to compare lisp values.")

-;; Poor man's counters +;; Sequences + +(def-function ("db_sequence_create2" %db-sequence-create) + ((db :pointer-void) + (flags :unsigned-int) + (errno (* :int))) + :returning :pointer-void) + +(defun db-sequence-create (db) + "Create a new sequence." + (declare (optimize (speed 3) (safety 0)) + (type pointer-void db) + (type pointer-int *errno-buffer*)) + (let* ((seq + (%db-sequence-create db 0 *errno-buffer*)) + (errno (deref-array *errno-buffer* '(:array :int) 0))) + (declare (type pointer-void seq) + (type fixnum errno)) + (if (= errno 0) + seq + (error 'db-error :errno errno)))) + +(def-function ("db_sequence_open" %db-sequence-open) + ((seq :pointer-void) + (txn :pointer-void) + (key :cstring) + (key-size :unsigned-int) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-open (sequence transaction key key-size flags) + :flags (auto-commit create excl thread) + :cstrings (key) + :keys ((key-size (length key)) + (transaction *current-transaction*)) + :transaction transaction + :documentation "Open a sequence.") + +(def-function ("db_sequence_close" %db-sequence-close) + ((seq :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno (db-sequence-close %db-sequence-close) (sequence flags) + :documentation "Close a sequence.") + +(def-function ("db_sequence_get" %db-sequence-get) + ((seq :pointer-void) + (txn :pointer-void) + (delta :int) + (low :unsigned-int :out) + (high :int :out) + (flags :unsigned-int)) + :returning :int) + +(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) + (type fixnum delta) + (type boolean auto-commit txn-nosync)) + (multiple-value-bind + (errno low high) + (%db-sequence-get sequence transaction delta + (flags :auto-commit auto-commit + :txn-nosync txn-nosync)) + (declare (type fixnum errno) + (type (unsigned-byte 32) low) + (type (signed-byte 32) high)) + (cond ((= errno 0) (make-64-bit-integer high low)) + ((or (= errno db_lock_deadlock) + (= errno db_lock_notgranted)) + (throw 'transaction transaction)) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_get_lower" %db-sequence-get-lower) + ((seq :pointer-void) + (txn :pointer-void) + (delta :int) + (low :int :out) + (flags :unsigned-int)) + :returning :int) + +(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) + (type fixnum delta) + (type boolean auto-commit txn-nosync)) + (multiple-value-bind + (errno low) + (%db-sequence-get-lower sequence transaction delta + (flags :auto-commit auto-commit + :txn-nosync txn-nosync)) + (declare (type fixnum errno low)) + (cond ((= errno 0) low) + ((or (= errno db_lock_deadlock) + (= errno db_lock_notgranted)) + (throw 'transaction transaction)) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_initial_value" %db-sequence-initial-value) + ((seq :pointer-void) + (low :unsigned-int) + (high :int)) + :returning :int) + +(defun db-sequence-initial-value (sequence value) + "Set the initial value." + (let ((errno + (%db-sequence-initial-value sequence (low32 value) (high32 value)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_remove" %db-sequence-remove) + ((seq :pointer-void) + (txn :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-remove (sequence transaction flags) + :keys ((transaction *current-transaction*)) + :transaction transaction + :flags (auto-commit txn-nosync) + :documentation "Remove a sequence.") + +(def-function ("db_sequence_set_cachesize" %db-sequence-set-cachesize) + ((seq :pointer-void) + (size :int)) + :returning :int) + +(wrap-errno db-sequence-set-cachesize (sequence size) + :documentation "Set cache size for a sequence.") + +(def-function ("db_sequence_get_cachesize" %db-sequence-get-cachesize) + ((seq :pointer-void) + (size :int :out)) + :returning :int) + +(wrap-errno db-sequence-get-cachesize (sequence) + :outs 2 + :documentation "Get cache size for a sequence.") + +(def-function ("db_sequence_set_flags" %db-sequence-set-flags) + ((seq :pointer-void) + (flags :unsigned-int)) + :returning :int) + +(wrap-errno db-sequence-set-flags (sequence flags) + :flags (seq-dec seq-inc seq-wrap) + :documentation "Set cache size for a sequence.") + +(def-function ("db_sequence_set_range" %db-sequence-set-range) + ((seq :pointer-void) + (minlow :unsigned-int) + (minhigh :int) + (maxlow :unsigned-int) + (maxhigh :int)) + :returning :int) + +(defun db-sequence-set-range (sequence min max) + "Set the range of a sequence" + (let ((errno + (%db-sequence-set-range sequence (low32 min) (high32 min) + (low32 max) (high32 max)))) + (declare (type fixnum errno)) + (cond ((= errno 0) nil) + (t (error 'db-error :errno errno))))) + +(def-function ("db_sequence_get_range" %db-sequence-get-range) + ((seq :pointer-void) + (minlow :unsigned-int :out) + (minhigh :int :out) + (maxlow :unsigned-int :out) + (maxhigh :int :out)) + :returning :int) + +(defun db-sequence-get-range (sequence) + "Get the range of a sequence" + (multiple-value-bind (errno minlow minhigh maxlow maxhigh) + (%db-sequence-get-range sequence) + (declare (type fixnum errno) + (type integer minlow minhigh maxlow maxhigh)) + (cond ((= errno 0) (values (make-64-bit-integer minhigh minlow) + (make-64-bit-integer maxhigh maxlow))) + (t (error 'db-error :errno errno)))))

(def-function ("next_counter" %next-counter) ((env :pointer-void)