[elephant-cvs] CVS elephant/src/elephant
ieslick
ieslick at common-lisp.net
Wed Feb 14 04:36:12 UTC 2007
Update of /project/elephant/cvsroot/elephant/src/elephant
In directory clnet:/tmp/cvs-serv32730/src/elephant
Modified Files:
classes.lisp classindex.lisp collections.lisp controller.lisp
metaclasses.lisp transactions.lisp
Log Message:
Documentation, optimizations, deadlock process, etc
--- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/12 20:36:45 1.12
+++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/14 04:36:10 1.13
@@ -20,6 +20,8 @@
(defvar *debug-si* nil)
+(declaim #-elephant-without-optimize (optimize (speed 3)))
+
(defmethod initialize-instance :before ((instance persistent)
&rest initargs
&key from-oid
@@ -235,13 +237,11 @@
(defmethod slot-value-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Get the slot value from the database."
- (declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-reader (get-con instance) instance name)))
(defmethod (setf slot-value-using-class) :around (new-value (class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Set the slot value in the database."
- (declare (optimize (speed 3)))
(if (indexed class)
(indexed-slot-writer class instance slot-def new-value)
(let ((name (slot-definition-name slot-def)))
@@ -249,13 +249,11 @@
(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Checks if the slot exists in the database."
- (declare (optimize (speed 3)))
(let ((name (slot-definition-name slot-def)))
(persistent-slot-boundp (get-con instance) instance name)))
(defmethod slot-boundp-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-name symbol))
"Checks if the slot exists in the database."
- (declare (optimize (speed 3)))
(loop for slot in (class-slots class)
for matches-p = (eq (slot-definition-name slot) slot-name)
until matches-p
@@ -266,7 +264,6 @@
(defmethod slot-makunbound-using-class :around ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition))
"Deletes the slot from the database."
- (declare (optimize (speed 3)))
;; NOTE: call remove-indexed-slot here instead?
;; (when (indexed slot-def)
;; (unregister-indexed-slot class (slot-definition-name slot-def)))
@@ -322,8 +319,7 @@
#+(or cmu sbcl)
(defun make-persistent-reader (name)
(lambda (instance)
- (declare (optimize (speed 3))
- (type persistent-object instance))
+ (declare (type persistent-object instance))
(persistent-slot-reader (get-con instance) instance name)))
#+(or cmu sbcl)
@@ -336,8 +332,7 @@
#+(or cmu sbcl)
(defun make-persistent-slot-boundp (name)
(lambda (instance)
- (declare (optimize (speed 3))
- (type persistent-object instance))
+ (declare (type persistent-object instance))
(persistent-slot-boundp (get-con instance) instance name)))
#+sbcl ;; CMU also? Old code follows...
--- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/12 20:36:46 1.16
+++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/14 04:36:10 1.17
@@ -12,6 +12,8 @@
(in-package "ELEPHANT")
+(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1)))
+
;;
;; User level class indexing control protocol
;;
@@ -72,8 +74,7 @@
(con (get-con instance)))
(declare (type fixnum oid))
(if (no-indexing-needed? class instance slot-def oid)
- (ensure-transaction (:store-controller con)
- (persistent-slot-writer con new-value instance slot-name))
+ (persistent-slot-writer con new-value instance slot-name)
(let ((class-idx (find-class-index class)))
;; (format t "Indexing object: ~A oid: ~A~%" instance oid)
(ensure-transaction (:store-controller con)
@@ -375,9 +376,7 @@
(get-instances-by-value (find-class class) slot-name value))
(defmethod get-instances-by-value ((class persistent-metaclass) slot-name value)
-;; (declare
-;; (optimize (speed 3) (safety 1) (space 1))
-;; (type (or string symbol) slot-name))
+ (declare (type (or string symbol) slot-name))
(let ((instances nil))
(with-btree-cursor (cur (find-inverted-index class slot-name))
(multiple-value-bind (exists? skey val pkey) (cursor-pset cur value)
@@ -405,9 +404,8 @@
(get-instances-by-range (find-class class) slot-name start end))
(defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end)
-;; (declare (optimize speed (safety 1) (space 1))
-;; (type fixnum start end)
-;; (type string idx-name))
+ (declare (type fixnum start end)
+ (type string idx-name))
(with-inverted-cursor (cur class idx-name)
(labels ((next-range (instances)
(multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur)
@@ -429,23 +427,6 @@
(next-in-range skey (cons val nil))
nil)))))
-
-(defun subsets (size list)
- (let ((subsets nil))
- (loop for elt in list
- for i from 0 do
- (when (= 0 (mod i size))
- (setf (car subsets) (nreverse (car subsets)))
- (push nil subsets))
- (push elt (car subsets)))
- (setf (car subsets) (nreverse (car subsets)))
- (nreverse subsets)))
-
-
-(defmacro do-subsets ((subset subset-size list) &body body)
- `(loop for ,subset in (subsets ,subset-size ,list) do
- , at body))
-
(defun drop-instances (instances &key (sc *store-controller*))
(when instances
(assert (consp instances))
--- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/02 23:51:58 1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/14 04:36:10 1.8
@@ -325,7 +325,7 @@
(defmethod map-btree (fn (btree btree))
"Like maphash. Default implementation - overridable"
- (ensure-transaction (:store-controller (get-con btree))
+ (with-transaction (:store-controller (get-con btree))
(with-btree-cursor (curs btree)
(loop
(multiple-value-bind (more k v) (cursor-next curs)
@@ -338,15 +338,25 @@
(multiple-value-bind (valid k) (cursor-next cur)
(cond ((not valid) ;; truly empty
t)
- ((eq k *elephant-properties-label*) ;; has properties
+ ((and (eq btree (controller-root (get-con btree)))
+ (eq k *elephant-properties-label*)) ;; has properties
(not (cursor-next cur)))
(t nil))))))
-(defun dump-btree (bt)
+(defun print-btree-node (k v)
+ (format t "k ~A / v ~A~%" k v))
+
+(defun dump-btree (bt &key (print-fn #'print-btree-node) (count nil))
+ "Print the contents of a btree for easy inspection & debugging"
(format t "DUMP ~A~%" bt)
- (map-btree #'(lambda (k v) (format t "k ~A / v ~A~%" k v)) bt)
- )
+ (let ((i 0))
+ (map-btree
+ (lambda (k v)
+ (when (and count (>= (incf i) count))
+ (return-from dump-btree))
+ (funcall print-fn k v))
+ bt)))
(defun btree-keys (bt)
(format t "BTREE keys for ~A~%" bt)
--- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/12 20:36:46 1.31
+++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/14 04:36:10 1.32
@@ -193,7 +193,6 @@
(migrate target source)
(close-store target)))
-
;;
;; Modular serializer support and default serializers for a version
;;
--- /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2006/04/26 17:53:44 1.7
+++ /project/elephant/cvsroot/elephant/src/elephant/metaclasses.lisp 2007/02/14 04:36:10 1.8
@@ -20,6 +20,8 @@
(in-package "ELEPHANT")
+(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1)))
+
(defclass persistent ()
((%oid :accessor oid :initarg :from-oid)
(dbonnection-spec-pst :type (or list string) :accessor :dbcn-spc-pst :initarg :dbconnection-spec-pst))
--- /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/02 23:51:58 1.5
+++ /project/elephant/cvsroot/elephant/src/elephant/transactions.lisp 2007/02/14 04:36:10 1.6
@@ -26,6 +26,39 @@
non-local exist, provides ACID properties for DB operations within the
body and properly binds any relevant parameters."))
+;; Transaction architecture:
+;;
+;; User and designer considerations:
+;; - *current-transaction* is reserved for use by dynamic transaction context. The default global
+;; value must always be null (no transaction). Each backend can set it to a different parameter
+;; within the dynamic context of an execute-transaction.
+;; - Any closures returned from within a transaction cannot bind *current-transaction*
+;; - Only a normal return value will result in the transaction being committed, any non-local exit
+;; results in a transaction abort. If you want to do something more sophisticated, roll your own
+;; using controller-start-transaction, etc.
+;; - The body of a with or ensure transaction can take any action (throw, signal, error, etc)
+;; knowing that the transaction will be aborted
+;;
+;; Designer considerations:
+;; - with-transaction passes *current-transaction* or the user parameter to execute-transaction
+;; in the parent keyword argument. Backends allowing nested transactions can treat the transaction
+;; as a parent, otherwise they can reuse the current transaction by ignoring it (inheriting the dynamic
+;; value of *current-transaction*) or rebinding the dynamic context (whatever makes coding easier).
+;; - ensure-transaction uses *current-transaction* to determine if there is a current transaction
+;; in progress. If so, it jumps to the body directly. Otherwise it executes the body in a
+;; new transaction.
+;; - execute-transaction contract:
+;; - Backends must dynamically bind *current-transaction* to a meaningful identifier for the
+;; transaction in progress and execute the provided closure in that context
+;; - All non-local exists result in an abort; only regular return values result in a commit
+;; - If a transaction is aborted due to a deadlock or read conflict, execute-transaction should
+;; automatically retry with an appropriate default amount
+;; - execute-transaction can take any number of backend-defined keywords, although designers should
+;; make sure there are no semantic conflicts if there is a name overlap with existing backends
+;; - A typical design approach is to make sure that the most primitive interfaces to the backend
+;; database look at *current-transaction* to determine whether a transaction is active. Users code can also
+;; access this parameter to check whether a transaction is active.
+
(defmacro with-transaction ((&rest keyargs &key
(store-controller '*store-controller*)
(parent '*current-transaction*)
@@ -66,7 +99,13 @@
:retries ,retries
,@(remove-keywords '(:store-controller :parent :transaction :retries)
keyargs))))))
-
+
+(defmacro with-batched-transaction ((batch size list &rest txn-options) &body body)
+ "Perform a set of DB operations over a list of elements in batches of size 'size'.
+ Pass specific transaction options after the list reference."
+ `(loop for ,batch in (subsets ,subset-size ,list) do
+ (with-transaction ,txn-options
+ , at body)))
;;
;; An interface to manage transactions explicitly
@@ -82,12 +121,3 @@
(defgeneric controller-abort-transaction (store-controller transaction &key &allow-other-keys)
(:documentation "Abort an elephant transaction"))
-
-;;
-;; Utility
-;
-
-(defun remove-keywords (key-names args)
- (loop for ( name val ) on args by #'cddr
- unless (member name key-names)
- append (list name val)))
More information about the Elephant-cvs
mailing list