[elephant-cvs] CVS elephant/src/db-bdb
ieslick
ieslick at common-lisp.net
Mon Jun 19 00:47:25 UTC 2006
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
More information about the Elephant-cvs
mailing list