Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv22395

Modified Files: bdb-collections.lisp bdb-controller.lisp Log Message:

BUGFIX: add-index to a large, existing btree would fail on the BDB backend due to a transaction that was too large. This transaction has been broken into 1k entry blocks to avoid overflowing the buffer pools.

FEATURE: Added the ability to launch a deadlock detector process for any system that has the :port package loaded. :deadlock-detector is a new keyword option added to open-store that will determine whether to launch or not to launch a detector process.

The location of the deadlock detector is not generic at this time, edit bdb-controller.lisp to change the pathname or default lock policy. Manual launching of the controller can be done by calling start-deadlock-detector.

--- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/04/26 19:19:12 1.7 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2006/06/19 00:47:24 1.8 @@ -103,40 +103,54 @@ ;; absolutely required at present, I think because the copying ;; of objects is calling "make-instance" without an argument. ;; I am sure I can find a way to make this cleaner, somehow. - (if (and (not (null index-name)) - (symbolp index-name) (or (symbolp key-form) (listp key-form))) + (if (and (not (null index-name)) + (symbolp index-name) + (or (symbolp key-form) (listp key-form))) ;; Can it be that this fails? - (let ( - (ht (indices bt)) - (index (build-btree-index sc :primary bt + (let ((ht (indices bt)) + (index (build-btree-index sc + :primary bt :key-form key-form))) (setf (gethash index-name (indices-cache bt)) index) (setf (gethash index-name ht) index) (setf (indices bt) ht) - (when populate - (let ((key-fn (key-fn index))) - (with-buffer-streams (primary-buf secondary-buf) - (with-transaction (:store-controller sc) - (map-btree - #'(lambda (k v) - (multiple-value-bind (index? secondary-key) - (funcall key-fn index k v) - (when index? - (buffer-write-int (oid bt) primary-buf) - (serialize k primary-buf) - (buffer-write-int (oid index) secondary-buf) - (serialize secondary-key secondary-buf) - ;; should silently do nothing if - ;; the key/value already exists - (db-put-buffered - (controller-indices sc) - secondary-buf primary-buf) - (reset-buffer-stream primary-buf) - (reset-buffer-stream secondary-buf)))) - bt))))) + (when populate (populate bt index)) index) - (error "Invalid index initargs!"))) -) + (error "Invalid index initargs!")))) + +(defmethod populate ((bt bdb-indexed-btree) index) + (let ((sc (get-con bt))) + (with-buffer-streams (primary-buf secondary-buf) + (flet ((index (key skey) + (buffer-write-int (oid bt) primary-buf) + (serialize key primary-buf) + (buffer-write-int (oid index) secondary-buf) + (serialize skey secondary-buf) + ;; should silently do nothing if + ;; the key/value already exists + (db-put-buffered + (controller-indices sc) + secondary-buf primary-buf) + (reset-buffer-stream primary-buf) + (reset-buffer-stream secondary-buf))) + (let ((key-fn (key-fn index)) + (last-key nil)) + (loop + (with-transaction (:store-controller sc) + (with-btree-cursor (cursor bt) + (if last-key + (cursor-set cursor last-key) + (cursor-first cursor)) + (loop for i from 0 upto 1000 do + (multiple-value-bind (valid? k v) (cursor-current cursor) + (unless valid? (return-from populate t)) + (multiple-value-bind (index? skey) (funcall key-fn index k v) + (when index? (index k skey)))) + (multiple-value-bind (valid? k v) (cursor-next cursor) + (declare (ignore v)) + (if valid? + (setf last-key k) + (return-from populate t))))))))))))

(defmethod map-indices (fn (bt bdb-indexed-btree)) (maphash fn (indices-cache bt))) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/04/30 01:02:22 1.8 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/06/19 00:47:24 1.9 @@ -28,7 +28,9 @@ (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) - :accessor controller-indices-assoc)) + :accessor controller-indices-assoc) + (deadlock-pid :accessor controller-deadlock-pid :initform nil) + (deadlock-input :accessor controller-deadlock-input :initform nil)) (:documentation "Class of objects responsible for the book-keeping of holding DB handles, the cache, table creation, counters, locks, the root (for garbage collection,) @@ -55,7 +57,8 @@

;; Open/close (defmethod open-controller ((sc bdb-store-controller) &key (recover t) - (recover-fatal nil) (thread t)) + (recover-fatal nil) (thread t) + (deadlock-detect nil)) (let ((env (db-env-create))) ;; thread stuff? (setf (controller-environment sc) env) @@ -112,10 +115,14 @@ (setf (slot-value sc 'class-root) (make-instance 'bdb-btree :from-oid -2 :sc sc))

+ (when deadlock-detect + (start-deadlock-detector sc)) + sc)))

(defmethod close-controller ((sc bdb-store-controller)) (when (slot-value sc 'root) + (stop-deadlock-detector sc) ;; no root (setf (slot-value sc 'class-root) nil) (setf (slot-value sc 'root) nil) @@ -144,6 +151,50 @@ (db-sequence-get-fixnum (controller-oid-seq sc) 1 :transaction +NULL-VOID+ :auto-commit t :txn-nosync t))

+(defparameter *deadlock-type-alist* + '((:oldest . "o") + (:youngest . "y") + (:timeout . "e") + (:most . "m") + (:least . "n"))) + +(defun lookup-deadlock-type (typestring) + (let ((result (assoc typestring *deadlock-type-alist*))) + (unless result + (error "Unrecognized deadlock type '~A'" typestring)) + (cdr result))) + +(eval-when (compile load eval) + (when (find-package :port) + (pushnew :port *features*))) + +(defmethod start-deadlock-detector ((ctrlr bdb-store-controller) &key (type :oldest) (time 0.1) log) + #+port + (multiple-value-bind (str errstr pid) + (port:run-prog (namestring + (make-pathname :directory "/usr/local/BerkeleyDB.4.3/bin/" + :name "db_deadlock")) + :args `("-a" ,(lookup-deadlock-type type) + "-t" ,(format nil "~D" time) + ,@(when log + (list "-L" (format nil "~A" log)))) + :wait nil) + (declare (ignore errstr)) + (setf (controller-deadlock-pid ctrlr) pid) + (setf (controller-deadlock-input ctrlr) str))) + +(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))) + +(defmethod shell-kill (pid) + #+allegro (sys:reap-os-subprocess :pid pid :wait t) + #+(port (not allegro)) (port:run-prog "kill" :wait t :args (list "-9" (format nil "~A" pid))) + )

;; ;; Persistent slot protocol