[elephant-cvs] CVS update: elephant/src/sleepycat.lisp

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 ,@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 ,@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 ,@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 ,@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) + ,@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))