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