From rread at common-lisp.net Thu Jun 1 12:55:43 2006 From: rread at common-lisp.net (rread) Date: Thu, 1 Jun 2006 08:55:43 -0400 (EDT) Subject: [elephant-cvs] CVS elephant Message-ID: <20060601125543.6D58A1600D@common-lisp.net> Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv23768 Modified Files: ele-bdb.asd elephant.asd Log Message: A patch submitted by Julian Stecklina for freebsd --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/04/30 01:03:48 1.9 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/06/01 12:55:43 1.10 @@ -52,7 +52,7 @@ (unless (zerop (uffi:run-shell-command (format nil #-freebsd "cd ~A; make bdb" - #+freebds "cd ~A; gmake bdb" + #+freebsd "cd ~A; gmake bdb" (make-pathname :directory *root-dir*)))) (format t "Couldn't build library from libsleepycat.c via 'make bdb'~%") (error 'operation-error :component c :operation o)))) @@ -73,8 +73,9 @@ "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" (and (and (find-package '#:sleepycat) - (symbol-function (intern (symbol-name '#:%db-strerror) - (find-package '#:sleepycat)))) + (ignore-errors + (symbol-function (intern (symbol-name '#:%db-strerror) + (find-package '#:sleepycat))))) t)) --- /project/elephant/cvsroot/elephant/elephant.asd 2006/04/26 17:53:43 1.17 +++ /project/elephant/cvsroot/elephant/elephant.asd 2006/06/01 12:55:43 1.18 @@ -52,7 +52,7 @@ (unless (zerop (uffi:run-shell-command (format nil #-freebsd "cd ~A; make" - #+freebds "cd ~A; gmake" + #+freebsd "cd ~A; gmake" (make-pathname :directory *root-dir*)))) (error 'operation-error :component c :operation o)))) @@ -72,8 +72,9 @@ "Operation is done when the foreign library is loaded which should happen when we compile the interface lisp file" (and (find-package "ELEPHANT-MEMUTIL") - (symbol-function (intern "COPY-BUFS" - (find-package "ELEPHANT-MEMUTIL"))) + (ignore-errors + (symbol-function (intern "COPY-BUFS" + (find-package "ELEPHANT-MEMUTIL")))) t)) (defsystem elephant From ieslick at common-lisp.net Mon Jun 19 00:47:25 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Jun 2006 20:47:25 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/db-bdb Message-ID: <20060619004725.1D70E67003@common-lisp.net> 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 From ieslick at common-lisp.net Mon Jun 19 01:03:30 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Jun 2006 21:03:30 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060619010330.4B5DE75027@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv24577 Modified Files: classindex.lisp collections.lisp controller.lisp serializer.lisp transactions.lisp Log Message: Various edits and fixes on the way to 0.6.1 --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/30 01:01:05 1.12 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/06/19 01:03:30 1.13 @@ -257,12 +257,12 @@ slot-name (class-name class)) (progn (when update-class (register-indexed-slot class slot-name)) - (with-transaction (:store-controller sc) +;; (with-transaction (:store-controller sc) (add-index (find-class-index class :sc sc) :index-name slot-name :key-form (make-slot-key-form class slot-name) :populate populate)) - t))) + t)) (defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) (remove-class-slot-index (find-class class) slot-name :sc sc)) @@ -289,11 +289,11 @@ (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) (progn (when update-class (register-derived-index class name)) - (with-transaction (:store-controller sc) +;; (with-transaction (:store-controller sc) (add-index class-idx :index-name (make-derived-name name) :key-form (make-derived-key-form derived-defun) - :populate populate)))))) + :populate populate))))) (defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) (remove-class-derived-index (find-class class) name :sc sc)) --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/04/26 17:53:44 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2006/06/19 01:03:30 1.5 @@ -348,6 +348,12 @@ (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt) ) +(defun btree-keys (bt) + (format t "BTREE keys for ~A~%" bt) + (map-btree #'(lambda (k v) + (format t "key ~A / value type ~A~%" k (type-of v))) + bt)) + (defun btree-differ (x y) (let ((cx1 (make-cursor x)) (cy1 (make-cursor y)) --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/05/06 19:19:26 1.10 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2006/06/19 01:03:30 1.11 @@ -113,13 +113,12 @@ ;; Open a Store ;; -(defun open-store (spec &key (recover nil) (recover-fatal nil) (thread t)) +(defun open-store (spec &rest args) "Conveniently open a store controller." (assert (consp spec)) (setq *store-controller* (get-controller spec)) (ensure-marked-version - (open-controller *store-controller* :recover recover - :recover-fatal recover-fatal :thread thread))) + (apply #'open-controller *store-controller* args))) (defun close-store (&optional sc) "Conveniently close the store controller." @@ -303,7 +302,7 @@ ;; STORE CONTROLLER PROTOCOL ;; -(defgeneric open-controller (sc &key recover recover-fatal thread) +(defgeneric open-controller (sc &key recover recover-fatal thread &allow-other-keys) (:documentation "Opens the underlying environment and all the necessary database tables.")) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/05/06 19:21:23 1.6 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/06/19 01:03:30 1.7 @@ -90,7 +90,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs2-symbol+) ;; +ucs1-symbol+ + (base-string +ucs1-symbol+) ;; +ucs1-symbol+ (string +ucs2-symbol+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s @@ -110,7 +110,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase frob - (base-string +ucs2-string+) ;; +ucs1-string+ + (base-string +ucs1-string+) ;; +ucs1-string+ (string +ucs2-string+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase frob @@ -152,7 +152,7 @@ (buffer-write-byte #+(and allegro ics) (etypecase s - (base-string +ucs2-pathname+) ;; +ucs1-pathname+ + (base-string +ucs1-pathname+) ;; +ucs1-pathname+ (string +ucs2-pathname+)) #+(or (and sbcl sb-unicode) lispworks) (etypecase s --- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/04/26 17:53:44 1.2 +++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2006/06/19 01:03:30 1.3 @@ -33,7 +33,7 @@ (parent '*current-transaction*) degree-2 dirty-read txn-nosync txn-nowait txn-sync - (retries 100)) + (retries 200)) &body body) "Execute a body with a transaction in place. On success, the transaction is committed. Otherwise, the transaction is From ieslick at common-lisp.net Mon Jun 19 01:31:59 2006 From: ieslick at common-lisp.net (ieslick) Date: Sun, 18 Jun 2006 21:31:59 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/memutil Message-ID: <20060619013159.A26BE17039@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/memutil In directory clnet:/tmp/cvs-serv673 Modified Files: memutil.lisp Log Message: Complete allegro encoding efficiency patch. --- /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/04/26 21:41:24 1.6 +++ /project/elephant/cvsroot/elephant/src/memutil/memutil.lisp 2006/06/19 01:31:59 1.7 @@ -323,8 +323,8 @@ #+(and allegro ics) ;; old: `(let ((l (length ,s))) (+ l l)) `(etypecase ,s - (base-string (excl:native-string-sizeof ,s :external-format :unicode)) - ;; fast 0.6.1 (length ,s) + (base-string ;; (excl:native-string-sizeof ,s :external-format :unicode)) + (length ,s)) ;; fast 0.6.1 (string (excl:native-string-sizeof ,s :external-format :unicode))) #+(or (and sbcl sb-unicode) lispworks) `(etypecase ,s @@ -574,8 +574,12 @@ #-allegro (copy-str-to-buf buf size s 0 str-bytes) #+allegro - (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) - ;; v0.6.0 (copy-str-to-buf buf size s 0 str-bytes) + (etypecase s + (base-string + (copy-str-to-buf buf size s 0 str-bytes)) ;; v0.6.0 + (string + (excl:string-to-native s :address (offset-char-pointer buf size) :external-format :unicode) + )) (setf size needed) nil))) From ieslick at common-lisp.net Mon Jun 19 16:43:51 2006 From: ieslick at common-lisp.net (ieslick) Date: Mon, 19 Jun 2006 12:43:51 -0400 (EDT) Subject: [elephant-cvs] CVS elephant/src/elephant Message-ID: <20060619164351.3168A39008@common-lisp.net> Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv3492 Modified Files: serializer.lisp Log Message: The serializer will silently ignore objects (like structs) that it cannot serialize. If you think you've saved something (because you forgot it cannot save structs) you will lose horribly (like I did). This patch asserts an error in the serializer if you try to serialize something the system cannot handle. --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/06/19 01:03:30 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2006/06/19 16:43:51 1.8 @@ -78,7 +78,7 @@ (labels ((%serialize (frob) (declare (optimize (speed 3) (safety 0))) - (typecase frob + (etypecase frob (fixnum (buffer-write-byte +fixnum+ bs) (buffer-write-int frob bs))