[elephant-cvs] CVS update: elephant/src/sleepycat.lisp
blee at common-lisp.net
blee at common-lisp.net
Sat Aug 28 06:41:50 UTC 2004
Update of /project/elephant/cvsroot/elephant/src
In directory common-lisp.net:/tmp/cvs-serv22194/src
Modified Files:
sleepycat.lisp
Log Message:
fixed with-transaction (no separate retry version) to use
throw / catch (non-consing!).
poor man's counters.
Date: Sat Aug 28 08:41:49 2004
Author: blee
Index: elephant/src/sleepycat.lisp
diff -u elephant/src/sleepycat.lisp:1.3 elephant/src/sleepycat.lisp:1.4
--- elephant/src/sleepycat.lisp:1.3 Fri Aug 27 19:32:56 2004
+++ elephant/src/sleepycat.lisp Sat Aug 28 08:41:49 2004
@@ -50,16 +50,19 @@
db-remove db-rename db-sync db-truncate
db-get-key-buffered db-get-buffered db-get db-put-buffered db-put
db-delete-buffered db-delete
- *current-transaction*
- db-transaction-begin db-transaction-abort db-transaction-commit
- with-transaction with-transaction-retry
+ *current-transaction* db-transaction-begin db-transaction-abort
+ db-transaction-commit with-transaction
db-transaction-id 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
- DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN
- +NULL-VOID+ +NULL-CHAR+
db-error db-error-errno
+ +NULL-VOID+ +NULL-CHAR+
+ DB-BTREE DB-HASH DB-QUEUE DB-RECNO DB-UNKNOWN
DB_KEYEMPTY DB_LOCK_DEADLOCK DB_LOCK_NOTGRANTED DB_NOTFOUND
+ DB-LOCKMODE#NG DB-LOCKMODE#READ DB-LOCKMODE#WRITE
+ DB-LOCKMODE#wAIT DB-LOCKMODE#IWRITE DB-LOCKMODE#IREAD
+ DB-LOCKMODE#IWR DB-LOCKMODE#DIRTY DB-LOCKMODE#WWRITE
))
(in-package "SLEEPYCAT")
@@ -98,24 +101,17 @@
(defconstant DB_TXN_NOSYNC #x0000100)
(defconstant DB_TXN_NOWAIT #x0001000)
(defconstant DB_TXN_SYNC #x0002000)
+(defconstant DB_LOCK_NOWAIT #x001)
(defconstant DB_GET_BOTH 10)
(defconstant DB_SET_LOCK_TIMEOUT 29)
(defconstant DB_SET_TXN_TIMEOUT 33)
-(def-enum lockop ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT
- :PUT :PUT-ALL :PUT-OBJ :PUT-READ
- :TIMEOUT :TRADE :UPGRADE-WRITE))
-
-(def-enum lockmode ((:NG 0) :READ :WRITE :WAIT
- :IWRITE :IREAD :IWR :DIRTY :WWRITE))
-
-(def-struct db-lockreq
- (op lockop)
- (mode lockmode)
- (timeout :unsigned-int)
- (obj (:array :char))
- (lock :pointer-void))
+(defconstant DB_KEYEMPTY -30997)
+(defconstant DB_LOCK_DEADLOCK -30995)
+(defconstant DB_LOCK_NOTGRANTED -30994)
+(defconstant DB_NOTFOUND -30990)
+
(eval-when (:compile-toplevel :load-toplevel)
;; UFFI
@@ -149,6 +145,7 @@
%db-txn-begin db-transaction-begin
%db-txn-abort db-transaction-abort
%db-txn-commit db-transaction-commit
+ %db-transaction-id
flags))
;; Buffer management / pointer arithmetic
@@ -348,7 +345,8 @@
)
(defmacro wrap-errno (names args &key (keys nil) (flags nil)
- (cstrings nil) (outs 1) (declarations nil))
+ (cstrings nil) (outs 1) (declarations nil)
+ (transaction nil))
(let ((wname (if (listp names) (first names) names))
(fname (if (listp names) (second names)
(intern (concatenate 'string "%" (symbol-name names)))))
@@ -364,16 +362,27 @@
(,fname , at fun-args)
(let ((,errno ,(first out-args)))
(declare (type fixnum ,errno))
- (if (= ,errno 0)
- (values ,@(rest out-args))
- (error 'db-error :errno ,errno)))))))
+ (cond
+ ((= ,errno 0) (values ,@(rest out-args)))
+ ,@(if transaction
+ (list `((or (= ,errno DB_LOCK_DEADLOCK)
+ (= ,errno DB_LOCK_NOTGRANTED))
+ (throw ,transaction ,transaction)))
+ (values))
+ (t (error 'db-error :errno ,errno))))))))
`(defun ,wname ,wrapper-args
,@(if declarations (list declarations) (values))
(with-cstrings ,(symbols-to-pairs cstrings)
(let ((,errno (,fname , at fun-args)))
(declare (type fixnum ,errno))
- (unless (= ,errno 0)
- (error 'db-error :errno ,errno))))))))
+ (cond
+ ((= ,errno 0) nil)
+ ,@(if transaction
+ (list `((or (= ,errno DB_LOCK_DEADLOCK)
+ (= ,errno DB_LOCK_NOTGRANTED))
+ (throw ,transaction ,transaction)))
+ (values))
+ (t (error 'db-error :errno ,errno)))))))))
;; Environment
@@ -425,7 +434,8 @@
:flags (auto-commit)
:keys ((transaction *current-transaction*)
(database +NULL-CHAR+))
- :cstrings (file database))
+ :cstrings (file database)
+ :transaction transaction)
(def-function ("db_env_dbrename" %db-env-dbrename)
((env :pointer-void)
@@ -440,7 +450,8 @@
:flags (auto-commit)
:keys ((transaction *current-transaction*)
(database +NULL-CHAR+))
- :cstrings (file database newname))
+ :cstrings (file database newname)
+ :transaction transaction)
(def-function ("db_env_remove" %db-env-remove)
((env :pointer-void)
@@ -509,7 +520,8 @@
(database +NULL-CHAR+)
(type DB-UNKNOWN)
(mode #o640))
- :cstrings (file database))
+ :cstrings (file database)
+ :transaction transaction)
(def-function ("db_remove" %db-remove)
((db :pointer-void)
@@ -549,7 +561,8 @@
:returning :int)
(wrap-errno db-truncate (db transaction flags) :flags (auto-commit)
- :keys ((transaction *current-transaction*)) :outs 2)
+ :keys ((transaction *current-transaction*)) :outs 2
+ :transaction transaction)
;; Accessors
@@ -582,11 +595,17 @@
:dirty-read dirty-read))
(declare (type fixnum result-length errno))
(if (<= result-length *get-buffer-length*)
- (if (= errno 0)
- (return-from db-get-key-buffered
- (the (values array-or-pointer-char fixnum)
- (values *get-buffer* result-length)))
- (error 'db-error :errno errno))
+ (cond
+ ((= errno 0)
+ (return-from db-get-key-buffered
+ (the (values array-or-pointer-char fixnum)
+ (values *get-buffer* result-length))))
+ ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY))
+ (return-from db-get-key-buffered
+ (the (values null fixnum) (values nil 0))))
+ ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED))
+ (throw transaction transaction))
+ (t (error 'db-error :errno errno)))
(resize-get-buffer result-length)))))
(def-function ("db_get_raw" %db-get-buffered)
@@ -620,11 +639,17 @@
:dirty-read dirty-read))
(declare (type fixnum result-length errno))
(if (<= result-length *get-buffer-length*)
- (if (= errno 0)
- (return-from db-get-buffered
- (the (values array-or-pointer-char fixnum)
- (values *get-buffer* result-length)))
- (error 'db-error :errno errno))
+ (cond
+ ((= errno 0)
+ (return-from db-get-buffered
+ (the (values array-or-pointer-char fixnum)
+ (values *get-buffer* result-length))))
+ ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY))
+ (return-from db-get-buffered
+ (the (values null fixnum) (values nil 0))))
+ ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED))
+ (throw transaction transaction))
+ (t (error 'db-error :errno errno)))
(resize-get-buffer result-length))))))
(defun db-get (db key &key (key-length (length key))
@@ -646,12 +671,17 @@
:dirty-read dirty-read))
(declare (type fixnum result-length errno))
(if (<= result-length *get-buffer-length*)
- (if (= errno 0)
- (return-from db-get
- (convert-from-foreign-string *get-buffer*
- :length result-length
- :null-terminated-p nil))
- (error 'db-error :errno errno))
+ (cond
+ ((= errno 0)
+ (return-from db-get
+ (convert-from-foreign-string *get-buffer*
+ :length result-length
+ :null-terminated-p nil)))
+ ((or (= errno DB_NOTFOUND) (= errno DB_KEYEMPTY))
+ (return-from db-get nil))
+ ((or (= errno DB_LOCK_DEADLOCK) (= errno DB_LOCK_NOTGRANTED))
+ (throw transaction transaction))
+ (t (error 'db-error :errno errno)))
(resize-get-buffer result-length))))))
(def-function ("db_put_raw" %db-put-buffered)
@@ -672,7 +702,8 @@
(type pointer-void db transaction)
(type array-or-pointer-char key datum)
(type fixnum key-length datum-length)
- (type boolean auto-commit)))
+ (type boolean auto-commit))
+ :transaction transaction)
(def-function ("db_put_raw" %db-put)
((db :pointer-void)
@@ -694,7 +725,8 @@
(type pointer-void db transaction)
(type string key datum)
(type fixnum key-length datum-length)
- (type boolean auto-commit)))
+ (type boolean auto-commit))
+ :transaction transaction)
(def-function ("db_del" %db-delete-buffered)
((db :pointer-void)
@@ -711,7 +743,8 @@
(type pointer-void db transaction)
(type array-or-pointer-char key)
(type fixnum key-length)
- (type boolean auto-commit)))
+ (type boolean auto-commit))
+ :transaction transaction)
(def-function ("db_del" %db-delete)
((db :pointer-void)
@@ -730,7 +763,8 @@
(type pointer-void db transaction)
(type string key)
(type fixnum key-length)
- (type boolean auto-commit)))
+ (type boolean auto-commit))
+ :transaction transaction)
;; Transactions
@@ -785,33 +819,39 @@
(type boolean txn-nosync txn-sync)))
(defmacro with-transaction ((&key transaction environment
- (globally t)
- (parent *current-transaction*)
+ (parent '*current-transaction*)
+ (retries 100)
dirty-read txn-nosync
txn-nowait txn-sync)
&body body)
(let ((txn (if transaction transaction (gensym)))
+ (count (gensym))
+ (result (gensym))
(success (gensym)))
- `(let* ((,txn (db-transaction-begin ,environment
- :parent ,parent
- :dirty-read ,dirty-read
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync))
- (,success nil)
- ,@(if globally `((*current-transaction* ,txn))
- (values)))
- (declare (dynamic-extent ,txn ,success)
- (type pointer-void ,txn)
- (type boolean ,success))
- (unwind-protect
- (prog1
- (progn , at body)
- (setq ,success t)
- (db-transaction-commit :transaction ,txn
- :txn-nosync ,txn-nosync
- :txn-sync ,txn-sync))
- (unless ,success (db-transaction-abort :transaction ,txn))))))
+ `(loop for ,count fixnum from 1 to ,retries
+ for ,txn of-type pointer-void =
+ (db-transaction-begin ,environment
+ :parent ,parent
+ :dirty-read ,dirty-read
+ :txn-nosync ,txn-nosync
+ :txn-nowait ,txn-nowait
+ :txn-sync ,txn-sync)
+ for ,success of-type boolean = nil
+ for ,result =
+ (let ((*current-transaction* ,txn))
+ (catch ,txn
+ (unwind-protect
+ (prog1 (progn , at body)
+ (setq ,success t)
+ (db-transaction-commit :transaction ,txn
+ :txn-nosync ,txn-nosync
+ :txn-sync ,txn-sync))
+ (unless ,success
+ (db-transaction-abort :transaction ,txn)))))
+ do
+ (unless (and (eq ,result ,txn) (not ,success))
+ (return ,result))
+ finally (error "Too many retries"))))
;; this is code for a non-consing with-transaction. which
;; doesn't work in the (globally t) case (e.g. setting
@@ -838,39 +878,36 @@
; :txn-sync ,txn-sync)))
; (unless ,success (%db-txn-abort ,txn)))))))
-(defmacro with-transaction-retry ((&key transaction environment
- (globally t)
- (parent *current-transaction*)
- (retries 100)
- dirty-read txn-nosync
- txn-nowait txn-sync)
- &body body)
- (let ((ret-tag (gensym))
- (retry-count (gensym)))
- `(let ((,retry-count 0))
- (tagbody ,ret-tag
- (handler-case
- (with-transaction (:tranasction ,transaction
- :environment ,environment
- :globally ,globally
- :parent ,parent
- :dirty-read ,dirty-read
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync)
- ,body)
- (db-error (err)
- (if (< (incf ,retry-count) ,retries)
- (go ,ret-tag)
- (error err))))))))
;; Locks and timeouts
-(def-function ("db_txn_id" db-transaction-id)
+(def-enum DB-LOCKOP ((:DUMP 0) :GET :GET-TIMEOUT :INHERIT
+ :PUT :PUT-ALL :PUT-OBJ :PUT-READ
+ :TIMEOUT :TRADE :UPGRADE-WRITE))
+
+(def-enum DB-LOCKMODE ((:NG 0) :READ :WRITE :WAIT
+ :IWRITE :IREAD :IWR :DIRTY :WWRITE))
+
+(def-struct DB-LOCK
+ (off :unsigned-int)
+ (ndx :unsigned-int)
+ (gen :unsigned-int)
+ (mode DB-LOCKMODE))
+
+(def-struct DB-LOCKREQ
+ (op DB-LOCKOP)
+ (mode DB-LOCKMODE)
+ (timeout :unsigned-int)
+ (obj (:array :char))
+ (lock (* DB-LOCK)))
+
+(def-function ("db_txn_id" %db-transaction-id)
((transaction :pointer-void))
:returning :unsigned-int)
+(defun db-transaction-id (&optional (transaction *current-transaction*))
+ (%db-transaction-id transaction))
(def-function ("db_env_lock_id" %db-env-lock-id)
((env :pointer-void)
@@ -887,6 +924,52 @@
(wrap-errno db-env-lock-id-free (env id))
+(def-function ("db_env_lock_get" %db-env-lock-get)
+ ((env :pointer-void)
+ (locker :unsigned-int)
+ (flags :unsigned-int)
+ (object array-or-pointer-char)
+ (object-length :unsigned-int)
+ (lock-mode DB-LOCKMODE)
+ (lock (* DB-LOCK)))
+ :returning :int)
+
+(wrap-errno db-env-lock-get (env locker flags object object-length
+ lock-mode lock)
+ :flags (lock-nowait))
+
+(def-function ("db_env_lock_put" %db-env-lock-put)
+ ((env :pointer-void)
+ (lock (* DB-LOCK)))
+ :returning :int)
+
+(wrap-errno db-env-lock-put (env lock))
+
+(defmacro with-lock ((env locker object object-length
+ &key (lock-mode DB-LOCKMODE#WRITE)
+ lock-nowait)
+ &body body)
+ (let ((lock (gensym))
+ (locked (gensym)))
+ `(with-foreign-object (,lock 'DB-LOCK)
+ (let ((,locked nil))
+ (unwind-protect
+ (progn
+ (db-env-lock-get ,env ,locker ,object ,object-length ,lock-mode
+ ,lock :lock-nowait ,lock-nowait)
+ (setq ,locked T)
+ , at body)
+ (when ,locked (db-env-lock-put ,env ,lock)))))))
+
+(def-function ("db_env_lock_vec" %db-env-lock-vec)
+ ((env :pointer-void)
+ (locker :unsigned-int)
+ (flags :unsigned-int)
+ (list (:array DB-LOCKREQ))
+ (nlist :int)
+ (elistp (* (* DB-LOCKREQ))))
+ :returning :int)
+
(def-function ("db_env_set_timeout" %db-env-set-timeout)
((env :pointer-void)
(timeout :unsigned-int)
@@ -937,6 +1020,25 @@
(wrap-errno db-env-lock-detect (env flags atype) :outs 2)
+;; Poor man's counters
+
+(def-function ("next_counter" %next-counter)
+ ((env :pointer-void)
+ (db :pointer-void)
+ (key array-or-pointer-char)
+ (key-length :unsigned-int)
+ (lockid array-or-pointer-char)
+ (lockid-length :unsigned-int))
+ :returning :int)
+
+(defun next-counter (env db key key-length lockid lockid-length)
+ (let ((ret (%next-counter env db key key-length lockid lockid-length)))
+ (if (< ret 0)
+ (error 'db-error :errno ret)
+ ret))))
+
+;; Misc
+
(defun flags (&key
auto-commit
joinenv
@@ -964,7 +1066,8 @@
txn-nowait
txn-sync
set-lock-timeout
- set-transaction-timeout)
+ set-transaction-timeout
+ lock-nowait)
(let ((flags 0))
(declare (optimize (speed 3) (safety 0) (space 0))
(type (unsigned-byte 32) flags)
@@ -1002,14 +1105,10 @@
(when txn-sync (setq flags (logior flags DB_TXN_SYNC)))
(when set-lock-timeout (setq flags (logior flags DB_SET_LOCK_TIMEOUT)))
(when set-transaction-timeout (setq flags (logior flags DB_SET_TXN_TIMEOUT)))
+ (when lock-nowait (setq flags (logior flags DB_LOCK_NOWAIT)))
flags))
;; Errors
-
-(defconstant DB_KEYEMPTY -30997)
-(defconstant DB_LOCK_DEADLOCK -30995)
-(defconstant DB_LOCK_NOTGRANTED -30994)
-(defconstant DB_NOTFOUND -30990)
(def-function ("db_strerr" %db-strerror)
((error :int))
More information about the Elephant-cvs
mailing list