Update of /project/elephant/cvsroot/elephant/src In directory common-lisp:/tmp/cvs-serv713/src
Modified Files: indexing.lisp Log Message:
Minor cleanup of indexing tests, declarations and rule-based code. 100% of tests pass under allegro 7.0 and Mac OS X.
--- /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/07 23:23:50 1.2 +++ /project/elephant/cvsroot/elephant/src/indexing.lisp 2006/02/08 03:23:12 1.3 @@ -1,7 +1,7 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; slot-index.lisp -- use btree collections to track objects by slot values -;;; via metaclass options or accessor :after methods +;;; indexing.lisp -- use btree collections to track objects by slot values +;;; via metaclass options or accessor :after methods ;;; ;;; Initial version 1/24/2006 Ian Eslick ;;; eslick at alum mit edu @@ -100,6 +100,7 @@
(defun no-indexing-needed? (class instance slot-def oid) + (declare (ignore instance)) (or (and (not (indexed slot-def)) ;; not indexed (not (indexing-record-derived (indexed-record class)))) ;; no derived indexes (member oid *inhibit-indexing-list*))) ;; currently inhibited @@ -199,7 +200,7 @@ (when class (disable-class-indexing class :sc sc))))
-(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*) (errorp t)) +(defmethod disable-class-indexing ((class persistent-metaclass) &key (sc *store-controller*)) (let ((class-idx (find-class-index class :sc sc))) (unless class-idx (return-from disable-class-indexing nil)) ;; Remove all instance key/value data from the class index (& secondary indices) @@ -354,6 +355,8 @@ (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)) (let ((instances nil)) (with-btree-cursor (cur (find-inverted-index class slot-name)) (multiple-value-bind (exists? skey val pkey) (cursor-pset cur value) @@ -371,6 +374,9 @@ (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)) (with-inverted-cursor (cur class idx-name) (labels ((next-range (instances) (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) @@ -406,16 +412,21 @@
;; TO READER: I got really tired of trying to figure out all ;; the messy conditionals and I figure default behaviors are something -;; others might want to modify, so here's what determines the -;; rule behavior. - -;; Rules match on the following state of the metaclass and -;; the current class-index in the database for a given slotname: +;; others might want to modify, so here's what determines the rule +;; behavior. +;; +;; Rules match on the following states of the metaclass and current +;; database class-index for each slotname currently in either of +;; those sources. Actions are taken, typically when a slot exists +;; in one but not the other or features like indexed/persistent +;; differ between the slots +;; ;; class state: ;; class-indexed - the slot is marked as indexed ;; class-persistent - the slot is marked as persistent (not indexed) ;; class-transient - the slot is marked transient ;; class-derived - the slot is in the derived list of the class +;; ;; database ;; db-slot - the database has a slot index ;; db-derived - the database has a derived index @@ -424,10 +435,12 @@ ;; (not indexed-slot) for example, to cover more than one feature ;; combination ;; -;; Each rule should apply uniquely to a given feature set -;; Actions taken include: -;; add-slot-index - add a new index to the db -;; remove-slot-index - remove a slot from the db +;; Each rule should apply uniquely to a given feature set. +;; +;; Actions taken when rules match can include: +;; +;; add-slot-index - add a new index with the slotname to the db +;; remove-slot-index - remove a slot with the slotname from the db ;; add-derived-index - xxx this makes no sense! xxx ;; remove-derived-index - remove a derived index from the db ;; unregister-indexed-slot - remove an indexed slot from the class metaobject @@ -436,6 +449,8 @@ ;; register-derived-index - register a derived index with the class metaobject ;;
+;; DEFINE THE SYNCHRONIZATION RULES + (eval-when (:compile-toplevel) (defclass synch-rule () ((lhs :accessor synch-rule-lhs :initarg :lhs :initform nil) @@ -461,10 +476,8 @@ (db-derived class-persistent => remove-derived-index warn)) ;; NOTE: What about cases where we need to remove things as below? (:db ;; db changes class - ((not db-slot) class-indexed => - unregister-indexed-slot) - ((not db-derived) class-derived => - unregister-derived-index) + ((not db-slot) class-indexed => unregister-indexed-slot) + ((not db-derived) class-derived => unregister-derived-index) (db-slot class-persistent => register-indexed-slot) (db-slot class-transient => remove-indexed-slot) (db-derived class-transient => remove-derived-index warn) @@ -474,22 +487,34 @@ (not class-persistent) (not class-transient) => register-derived-slot))))) ) - + +;; TOP LEVEL METHOD + +(defun synchronize-class-to-store (class &key (sc *store-controller*) + (method *default-indexed-class-synch-policy*)) + (let ((slot-records (compute-class-and-ele-status class sc)) + (rule-set (cdr (assoc method *synchronize-rules*)))) + (apply-synch-rules class slot-records rule-set))) + +;; COMPUTING RULE APPLICABILITY AND FIRING
(defun synch-rule-applicable? (rule features) (simple-match-set (synch-rule-lhs rule) features))
(defun simple-match-set (a b) + (declare (optimize (speed 3) (safety 1))) (cond ((null a) t) ((and (not (null a)) (null b)) nil) ((member (first a) b :test #'equal) (simple-match-set (cdr a) (remove (first a) b :test #'equal))) (t nil)))
+(defparameter *print-synch-messages* nil) + (defun apply-synch-rule (rule class name) - (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" - (synch-rule-lhs rule) (synch-rule-rhs rule) name) -;; (return-from apply-synch-rule nil) + (when *print-synch-messages* + (format t "Class/DB Synch: converting state ~A using ~A for ~A~%" + (synch-rule-lhs rule) (synch-rule-rhs rule) name)) (loop for action in (synch-rule-rhs rule) do (case action (add-slot-index (add-class-slot-index class name :update-class nil)) @@ -502,9 +527,20 @@ (register-derived-index (register-derived-index class name)) (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule))))))
-(defun synchronize-class-to-store (class &key (sc *store-controller*) - (method *default-indexed-class-synch-policy*)) - (let* ((*store-controller* sc) +(defun apply-synch-rules (class records rule-set) + (declare (optimize (speed 3) (safety 1))) + (labels ((slotname (rec) (car rec)) + (feature-set (rec) (cdr rec))) + (loop for record in records do + (loop for rule in rule-set + when (synch-rule-applicable? rule (feature-set record)) + do + (apply-synch-rule rule class (slotname record)))))) + +;; COMPUTE CURRENT STATE OF CLASS OBJECT AND DATABASE AFTER CHANGES + +(defun compute-class-and-ele-status (class &optional (store-controller *store-controller*)) + (let* ((*store-controller* store-controller) ;; db info (db-indices (find-inverted-index-names class)) (db-derived (mapcar #'get-derived-name-root @@ -525,24 +561,16 @@ (class-transient . ,other-slots) (db-slot . ,db-slot) (db-derived . ,db-derived)))) - (labels ((compute-feature (name set label) - (if (member name set) - label - `(not ,label))) - (compute-features (slotname) + (labels ((compute-features (slotname) (let ((features nil)) (loop for set in all-sets do (push (compute-feature slotname (cdr set) (car set)) features)) (cons slotname features))) - (slotname (rec) (car rec)) - (feature-set (rec) (cdr rec))) - (let ((rule-set (cdr (assoc method *synchronize-rules*))) - (slot-records (mapcar #'compute-features all-names))) - (loop for record in slot-records do - (loop - for rule in rule-set - when (synch-rule-applicable? rule (feature-set record)) - do - (apply-synch-rule rule class (slotname record)))))))) + (compute-feature (name set label) + (if (member name set) + label + `(not ,label)))) + (mapcar #'compute-features all-names)))) +