[elephant-cvs] CVS elephant/src/db-bdb
ieslick
ieslick at common-lisp.net
Wed Feb 14 04:36:10 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/db-bdb
In directory clnet:/tmp/cvs-serv32730/src/db-bdb
Modified Files:
bdb-collections.lisp bdb-controller.lisp bdb-transactions.lisp
package.lisp
Log Message:
Documentation, optimizations, deadlock process, etc
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/08 23:05:46 1.17
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/14 04:36:09 1.18
@@ -55,7 +55,6 @@
(defmethod (setf get-value) (value key (bt bdb-btree))
-;; (with-transaction ()
(let ((sc (get-con bt)))
(with-buffer-streams (key-buf value-buf)
(buffer-write-oid (oid bt) key-buf)
@@ -63,26 +62,9 @@
(serialize value value-buf sc)
(db-put-buffered (controller-btrees sc)
key-buf value-buf)))
-;; )
value)
-;; (labels ((write-value ()
-;; (let ((sc (get-con bt)))
-;; (with-buffer-streams (key-buf value-buf)
-;; (buffer-write-oid (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))
-;; (with-transaction (:store-controller (get-con bt))
(let ((sc (get-con bt)) )
(with-buffer-streams (key-buf)
(buffer-write-oid (oid bt) key-buf)
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/04 04:34:56 1.22
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2007/02/14 04:36:10 1.23
@@ -231,47 +231,23 @@
(error "Unrecognized deadlock type '~A'" typestring))
(cdr result)))
-(eval-when (compile load eval)
- (when (find-package :port)
- (pushnew :port *features*)))
-
-(defun launch-background-program (directory program &key (args nil))
- "Launch a program in a specified directory - not all shell interfaces
- or OS's support this"
- #+(and allegro (not mswindows))
- (apply #'excl:run-shell-command (funcall #'vector directory program)
- args)
- #-(and allegro (not mswindows))
- nil)
-
(defmethod start-deadlock-detector ((ctrl bdb-store-controller) &key (type :oldest) (time 0.1) log)
- #+port
(multiple-value-bind (str errstr pid)
(launch-background-program
(second (controller-spec ctrl))
(namestring
- (make-pathname :directory '(:ABSOLUTE "usr" "local" "BerkeleyDB.4.3" "bin")
+ (make-pathname :directory '(:ABSOLUTE "opt" "local" "bin" "db45_deadlock")
:name "db_deadlock"))
:args `("-a" ,(lookup-deadlock-type type)
"-t" ,(format nil "~D" time)
,@(when log (list "-L" (format nil "~A" log)))))
- (declare (ignore errstr))
- (setf (controller-deadlock-pid ctrl) pid)
- (setf (controller-deadlock-input ctrl) str)))
+ (declare (ignore str errstr))
+ (setf (controller-deadlock-pid ctrl) pid)))
(defmethod stop-deadlock-detector ((ctrl bdb-store-controller))
(when (controller-deadlock-pid ctrl)
- (shell-kill (controller-deadlock-pid ctrl))
- (setf (controller-deadlock-pid ctrl) nil))
- (when (controller-deadlock-input ctrl)
- (close (controller-deadlock-input ctrl))
- (setf (controller-deadlock-input ctrl) nil)))
+ (kill-background-program (controller-deadlock-pid ctrl))))
-(defmethod shell-kill (pid)
- #+allegro (sys:reap-os-subprocess :pid pid :wait t)
- #+(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
;;
--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/13 16:49:32 1.6
+++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/14 04:36:10 1.7
@@ -38,8 +38,7 @@
:txn-nosync txn-nosync
:txn-nowait txn-nowait
:txn-sync txn-sync))))
- (declare (type pointer-void txn)
- (dynamic-extent txn))
+ (declare (type pointer-void txn))
(let ((result
(let ((*current-transaction* txn))
(declare (special *current-transaction*))
@@ -56,16 +55,6 @@
(return result))))
finally (error "Too many retries in transaction"))))
-;; (with-bdb-transaction (:transaction ,transaction
-;; :environment env
-;; :parent ,parent
-;; :degree-2 ,degree-2
-;; :dirty-read ,dirty-read
-;; :txn-nosync ,txn-nosync
-;; :txn-nowait ,txn-nowait
-;; :txn-sync ,txn-sync
-;; :retries ,retries)
-
(defmethod controller-start-transaction ((sc bdb-store-controller)
&key
parent
@@ -85,101 +74,12 @@
:degree-2 degree-2))
-(defmethod controller-commit-transaction ((sc bdb-store-controller) transaction &key &allow-other-keys)
+(defmethod controller-commit-transaction ((sc bdb-store-controller) transaction
+ &key txn-nosync txn-sync &allow-other-keys)
(assert (not *current-transaction*))
- (db-transaction-commit transaction))
+ (db-transaction-commit transaction :txn-nosync txn-nosync :txn-sync txn-sync))
(defmethod controller-abort-transaction ((sc bdb-store-controller) transaction &key &allow-other-keys)
(assert (not *current-transaction*))
(db-transaction-abort transaction))
-
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; Old versions of with-transaction
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-#|
-(defmacro with-transaction ((&key transaction environment
- (parent '*current-transaction*)
- (retries 100)
- dirty-read read-uncommitted
- txn-nosync txn-nowait txn-sync)
- &body body)
- (let ((txn (if transaction transaction (gensym)))
- (count (gensym))
- (result (gensym))
- (success (gensym)))
- `(loop
- for ,count fixnum from 1 to ,retries
- for ,success of-type boolean = nil
- do
- (with-alien ((,txn (* t)
- (db-transaction-begin ,environment
- :parent ,parent
- :dirty-read (or ,dirty-read ,read-uncommitted)
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync)))
- (let ((,result
- (let ((*current-transaction* ,txn))
- (declare (special *current-transaction*)
- (dynamic-extent *current-transaction*))
- (catch 'transaction
- (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)))))))
- (unless (and (eq ,result ,txn) (not ,success))
- (return ,result))))
- finally (error "Too many retries"))))
-
-(defmacro with-transaction ((&key transaction environment
- (parent '*current-transaction*)
- (retries 100)
- degree-2 read-committed
- dirty-read read-uncommitted
- txn-nosync txn-nowait txn-sync)
- &body body)
- "Execute a body with a transaction in place. On success,
-the transaction is committed. Otherwise, the transaction is
-aborted. If the body deadlocks, the body is re-executed in
-a new transaction, retrying a fixed number of iterations."
- (let ((txn (if transaction transaction (gensym)))
- (count (gensym))
- (result (gensym))
- (success (gensym)))
- `(loop
- for ,count fixnum from 1 to ,retries
- for ,success of-type boolean = nil
- do
- (let ((,txn
- (db-transaction-begin ,environment
- :parent ,parent
- :degree-2 (or ,degree-2 ,read-committed)
- :dirty-read (or ,dirty-read ,read-uncommitted)
- :txn-nosync ,txn-nosync
- :txn-nowait ,txn-nowait
- :txn-sync ,txn-sync)))
- (declare (type pointer-void ,txn)
- (dynamic-extent ,txn))
- (let ((,result
- (let ((*current-transaction* ,txn))
- (declare (special *current-transaction*)
- (dynamic-extent *current-transaction*))
- (catch 'transaction
- (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)))))))
- (unless (and (eq ,result ,txn) (not ,success))
- (return ,result))))
- finally (error "Too many retries"))))
-|#
--- /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2006/12/16 19:35:10 1.3
+++ /project/elephant/cvsroot/elephant/src/db-bdb/package.lisp 2007/02/14 04:36:10 1.4
@@ -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-backend elephant)
+ (:use common-lisp uffi elephant-memutil elephant-backend elephant-utils elephant)
#+cmu
(:use alien)
#+sbcl
More information about the Elephant-cvs
mailing list