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)
