February 2007 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv31080/src/elephant Modified Files: package.lisp unicode2.lisp Log Message: Fixed serialization of char codes > #x7F; added appropriate test; fixed symbol export problem --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 03:37:37 1.19 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 20:02:32 1.20 @@ -68,6 +68,7 @@ #:add-symbol-conversion #:add-package-conversion #:*always-convert* + #:translate-and-intern-symbol #:lookup-persistent-symbol #:lookup-persistent-symbol-id #:int-byte-spec --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/24 14:51:59 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/25 20:02:32 1.6 @@ -35,11 +35,12 @@ "Try to write each format type and bail if code is too big" (declare (type buffer-stream bstream) (type string string)) - (cond ((and (not (equal "" string)) (< (char-code (char string 0)) #x7F)) - (serialize-to-utf8 string bstream)) + (cond ((and (not (equal "" string)) (> (char-code (char string 0)) #xFFFF)) + (serialize-to-utf32le string bstream)) ;; Accelerate the common case where a character set is not Latin-1 - ((and (not (equal "" string)) (< (char-code (char string 0)) #xFFFF)) - (serialize-to-utf16le string bstream)) + ((and (not (equal "" string)) (> (char-code (char string 0)) #xFF)) + (or (serialize-to-utf16le string bstream) + (serialize-to-utf32le string bstream))) ;; Actually code pages > 0 are rare; so we can pay an extra cost (t (or (serialize-to-utf8 string bstream) (serialize-to-utf16le string bstream) @@ -73,13 +74,13 @@ (loop for i fixnum from 0 below characters do (let ((code (char-code (schar string i)))) (declare (type fixnum code)) - (when (> code #x7F) (fail)) + (when (> code #xFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code)))) (string (loop for i fixnum from 0 below characters do (let ((code (char-code (char string i)))) (declare (type fixnum code)) - (when (> code #x7F) (fail)) + (when (> code #xFF) (fail)) (setf (uffi:deref-array buffer 'array-or-pointer-char (+ i size)) code))))) (setf (buffer-stream-size bstream) needed) (succeed)))))) @@ -251,7 +252,6 @@ (setf code (dpb (next-byte 1) (byte 8 16) code)) (setf code (dpb (next-byte 2) (byte 8 8) code)) (setf code (dpb (next-byte 3) (byte 8 0) code)) - (print code) (setf (char string i) (code-char code))) (incf (elephant-memutil::buffer-stream-position bstream) (+ pos (* length 4)))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv24359/tests Modified Files: testindexing.lisp Log Message: Fix bug in testindexing; more TODO tweaks --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/21 06:29:32 1.28 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/25 09:37:01 1.29 @@ -201,7 +201,7 @@ (let ((orig-len (length (get-instances-by-class 'idx-unbound-del))) (orig-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) - (slot-makunbound orig-obj 'name) + (slot-makunbound orig-obj 'slot1) (let ((new-len (length (get-instances-by-class 'idx-unbound-del))) (index-obj (get-instance-by-value 'idx-unbound-del 'slot1 10))) (values orig-len new-len index-obj))))

1 0

[elephant-cvs] CVS elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv24359 Modified Files: TODO Log Message: Fix bug in testindexing; more TODO tweaks --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:12:47 1.61 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:36:59 1.62 @@ -72,9 +72,9 @@ x Fixed typos in SQL backend (Ian/Robert/Henrik) x Fixed build bug for linux (Henrik) x Fixed error condition while opening SQLITE3 in SQL backend (Robert) -x Fixed idempotence problem in PREPARE-BDB test -x Review and document or address all NOTE comments in the code -x Review SBCL string serialization performance (fals alarm, comparable to allegro) +x Fixed idempotence problem in PREPARE-BDB test (Ian) +x Review and document or address all NOTE comments in the code (Ian) +x Review SBCL string serialization performance (false alarm, comparable to allegro) Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv20086/src/elephant Modified Files: controller.lisp serializer.lisp Log Message: Fix SBCL struct serialization; cleanup TODO after Trac conversion; remove persistant aggregate stubs --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/24 14:51:59 1.37 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/25 09:12:47 1.38 @@ -492,54 +492,6 @@ (when entry (cdr entry)))) -;; -;; Callback hooks for persistent variables -;; - -;; Design sketch; not sure I'll promote this. -;; To be looked at again for 0.6.2 or 0.7.0 - -;;(defvar *variable-hooks* nil -;; "An alist (specs -> varlist) where varlist is tuple of -;; lisp name, store name (auto) and policy") - -;;(defun add-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (push name (assoc spec *variable-hooks* :test #'equal)) -;; (push (cons spec (list name)) *variable-hooks*))) - -;;(defun remove-hook (name spec) -;; (if (assoc spec *variable-hooks* :test #'equal) -;; (setf (assoc spec *variable-hooks* :test #'equal) -;; (remove name (assoc spec *variable-hooks* :test #'equal))) -;; (error "No hooks declared on ~A" spec))) - -;; (defmacro defpvar (name spec (policy &rest accessors) initial-value &optional (documentation nil)) -;; `(progn -;; (defvar ,name ,initial-value ,documentation) -;; (add-hook ,name ,spec) -;; ,(case policy -;; (:wrap-mutators -;; `(progn -;; ,(loop for accessor in accessors do -;; (let ((gf (ensure-generic-function -;; `(defmethod ,accessor :after ( - -;; (defpvar *agencies* (:wrap-mutators -;; 'add-agent -;; 'remove-agent -;; 'clear-agents) -;; nil -;; "test") - -;; (defmethod add-agent (agent) -;; (push agent *agencies*)) - -;; (defmethod remove-agent (agent) -;; (setf *agencies* (remove agent *agencies*))) - -;; (defmethod clear-agents (agent) -;; (setf *agencies* nil)) --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 03:37:37 1.22 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 09:12:47 1.23 @@ -198,16 +198,14 @@ "List of slot names followed by values for structure object" (let ((result nil) (slots - #+openmcl + #+(or sbcl cmu allegro) + (mapcar #'slot-definition-name (class-slots (class-of object))) + #+openmcl (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) (slots (if sd (ccl::sd-slots sd)))) (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) - #+cmu - (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) #+lispworks - (structure:structure-class-slot-names (class-of object)) - #+allegro - (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))) + (structure:structure-class-slot-names (class-of object)))) (loop for slot in slots do (push (slot-value object slot) result) (push slot result))

1 0

[elephant-cvs] CVS elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv20086 Modified Files: TODO Log Message: Fix SBCL struct serialization; cleanup TODO after Trac conversion; remove persistant aggregate stubs --- /project/elephant/cvsroot/elephant/TODO 2007/02/25 03:40:18 1.60 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 09:12:47 1.61 @@ -1,7 +1,10 @@ -Last updated: February 4, 2007 +Last updated: February 25th, 2007 -Ongoing release plan notes: +Ongoing release plan notes. + +(Note: use of this file is deprecated after 0.6.1, see Trac site at + http://trac.common-lisp.net/elephant) 0.6.1 - performance, safety and portability -------------------------------------------- @@ -75,7 +78,8 @@ Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) -x Tests to validate new map interfaces on top of existing tests +x Tests to validate new map interfaces on top of existing tests (Ian) +x Added support and tests for serializing structure objects on all supported platforms (Ian) DEVELOPMENT CHECKINS: @@ -156,151 +160,6 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.7.0 - Advanded work, low-hanging fruit (Summer '07) ------------------------------------------------------ - -Migrate code base to Darcs and create feature/bug tickets in TRAC - -Storage and Indexing: -- Add :inverse-reader to slot options to create a named method that indexes into objects - based on slot values. Is this a GF or defun? Do we dispatch on class name or bake it in? -- If a class inherits an indexed slot, is it also indexed for that class? This means a - proliferation of indexes, or requires user to explicitly add an index as a derived slot. - (Proposal: any subclass must have an :index specifier that is the same as the base class) - (Imp. option: one index for all instances of primary and subclasses; or index per set?) - (Perhaps slot indices should not be secondary so they can point to different class types?) -- What if we want an index to index into a range of different subclasses or objects sharing - a generic function? (roll your own?) -- Reclaim table storage on index drop? It's nice to be able to reconnect sometimes! - Perhaps an API command that allows explicit dropping of tables for a class and a policy - parameter that determines if this is the default? -- Delete persistent slot values from the slot store with remove-kv to ensure that - there's no data left lying around if you define then redefine a class and add - back a persistent slot name that you thought was deleted and it gets the old - value by default? -- Can we do automatic join cursors? -- Add lazy deserialize to map functions? -- First-cut query interface - -Performance: -- Improve SQL base-64 serializer performance? -- Implement unicode performance hacks for various lisps; validate UTF8 works everywhere -- Metering and understanding locking issues. Large transactions seem - to use a lot of locks. In general understanding how to use Berkeley DB - efficiently seems like a good thing. (From Ben) -- Add dependency information into secondary index callback functions so that - we can more easily compute which indices need to be updated to avoid the - global remove/add in order to maintain consistency (Ian) -- Track derived indices across classes - -Design: - - Move secondary index maintenance to backend; decison on how to call update fn's - Will make lisp backend cheaper due to ability to life tree manipulation ops - - Use SWIG and CFFI to better track changes in defconstant? (too expensive to be useful) - - Evaluate porting elephant to closer-to-MOP to make it easier to - support additional lisps and to seriously clean up - metaclasses.lisp and classes.lisp protocols (no love on first attempt) - - Work to integrate a proper condition system and potential restarts - for various errors (especially recoverable ones) while accessing db data - - deserialize fubar / diagnose & return value - - missing package / add package/symbol translation - - others? - (log these in Track; not part of 0.6.2?) - -Features: - - Backup function: allow users to specify a backup function to archive the database contents - and checkpoint any active functions (how to lock out other threads?) In BDB this means - running checkpoint and copying the DB files and any active log files. - - Class option MOP add-on to support declared persistent baseclass slots for standard base classes - - A wrapper around migration that emulates a stop-and-copy GC - -Documentation: - - Tutorial example rethink: update the blog tutorial using indexed - objects to create different views as well as integrating something - like logging for admin or version control purposes. - - Finish serious update and review of users manual (building on 0.6.0 update) - - A guide to dealing with transactions - - A guide to dealing with multiple open stores - - A guide to performance - - An overview of licensing issues... - -0.8.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------- - -Major features: - - Native Lisp Backend - - All in common-lisp - - Page-based architecture - - Cheap copy-on-write transaction policy w/ concurrent transaction commits - in non-conflicting transactions - - Fast in-memory operations / prevalence like features - - Make storage policy decisions on per-class (or per-instance) basis - - Concurrent mode - - Current default - - For backends that allow multiple processes to connect - - Full ACID functionality - - Single-threaded objects - - Cache values in instance slots for fast reads - - Writes update slots and write to disk as normal - - Violates consistency and isolation; users must enforce single operator - - Prevalence mode - - Standard object model (user enforced ACID properties) - - Read/write to normal slots - - Backup slot values on object creation and explicit synch calls on class or instances - - In-memory slot indexing, write-through disk class indexing - - NoSynch controller switch - - Violates durability - - Offline garbage collection (via migration) - - Class schemas - - Improve synchronization, support class and instance versioning - - POBJs encoded by OID/CID and CID's are cached in working memory - This way we can issue conditions if an object is out of date so the - user can determine how/if to upgrade the reference to the current schema - - From Ben's e-mail: - We are storing persistent objects incorrectly. They should be stored only as OIDs, - and we should have a separate OID->class table. This way change-class can be - handled correctly. This also non-trivially compresses storage in the - database as we only need to store oids rather than serialized class names. - [Ian comment: only problem with this is an extra access to oid table each time a - class is deserialized and overall storage is constant. Would make it easy to - invalidate objects though!] - - Persistent variables (abstraction that allows compound lisp objects at the cost of - full serialization after each write that indirects through the API). Can this be done - with clean semantics or should we punt it? - - Support a simple object query language - -Details: - - Revisit duplicate sorting on primary key (artifact of btree index storage order) - - Usage model examples for new features - - 64-bit oids / 64-bit file sizes - -0.8.1 - Elephant BDB/SQL/Lisp Pre-production Release --------------------------------------------------- - - More work on testing, examples and documentation - - Intent is for this to be a major, long-term supported release prior - to work on the new backend (i.e. patches against this release for - bugs rather than only available in latest development tree) - - Online GC for lisp backend? - - -0.9.0 - Supporting Tools Release --------------------------------------------------- - - Richer query language and query compiler - - Repository browser - a simple REPL tool like the Slime inspector - to see what classes are in a repository and what state they're in...useful - for long-lived repositories or if you've forgotten a variable name - - Add special support (if any) for persistent graph structures & queries (ala AllegroCache) - - Support for cheap persistent sets (medium? can do on SQL?) - - Persistent aggregates for better conceptual integration with lisp? - - pcons, parray, pstruct, etc - - push/pop elements from a list defined on a persistent slot? - -1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------- - - Significant work on test cases & testing framework - - Final pass of performance enhancements and review - - Invite community review and testing - ======================================================== ========================================================

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv17542/src/elephant Modified Files: serializer2.lisp Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:37:37 1.28 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:40:19 1.29 @@ -519,7 +519,7 @@ (if maybe-o maybe-o (let ((typedesig (%deserialize bs))) (let ((o (or (handler-case - (funcall (struct-constructor (find-class typedesig))) + (funcall (struct-constructor typedesig)) (error (v) (format t "got typedesig error for struct: ~A ~A ~%" v typedesig) (list 'caught-error v typedesig))) (list 'uninstantiable-object-of-type typedesig))))

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv17542/tests Modified Files: testserializer.lisp Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/04 10:08:28 1.17 +++ /project/elephant/cvsroot/elephant/tests/testserializer.lisp 2007/02/25 03:40:19 1.18 @@ -332,7 +332,10 @@ (gethash key s2))))) (standard-object (%deep-equalp (ele::slots-and-values s1) - (ele::slots-and-values s2))) + (ele::slots-and-values s2))) + (structure-object + (%deep-equalp (ele::struct-slots-and-values s1) + (ele::struct-slots-and-values s2))) (t (equalp s1 s2)))))))) (%deep-equalp thing another)))) @@ -389,6 +392,26 @@ :slot2 "foo bar")))) t t) +(defstruct struct1 ss1 ss2) + +(deftest structs + (are-not-null + (in-out-deep-equalp (make-struct1)) + (in-out-deep-equalp (make-struct1 :ss1 "test" :ss2 (make-struct1 :ss1 "bottom" :ss2 nil)))) + t t) + +(defstruct (struct2 (:constructor make-a-struct2)) ss3 ss4) + +(defmethod struct-constructor ((class (eql 'struct2))) + #'make-a-struct2) + +(deftest struct-non-std-construct + (are-not-null + (in-out-deep-equalp (make-a-struct2)) + (in-out-deep-equalp (make-a-struct2 :ss3 (make-a-struct2 :ss4 "foo")))) + t t) + + (deftest circular (let ((c1 (cons nil nil)) (c2 (cons nil nil))

1 0

[elephant-cvs] CVS elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv17542 Modified Files: TODO Log Message: struct serialization test and bugfix --- /project/elephant/cvsroot/elephant/TODO 2007/02/24 14:51:59 1.59 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/25 03:40:18 1.60 @@ -12,7 +12,6 @@ - Validate SQL migration 0.6.0->0.6.1 (Robert) Stability and Performance: -- Review SBCL string serialization performance - Migration: Validate that migrate can use either O(c) or O(n/c) where c << n memory for large DBs - Migration: Improve support for nested persistent objects inside standard objects, arrays, etc? - Migration: Improve scaling properties of migration so all objects do not need to be resident in memory? @@ -72,6 +71,7 @@ x Fixed error condition while opening SQLITE3 in SQL backend (Robert) x Fixed idempotence problem in PREPARE-BDB test x Review and document or address all NOTE comments in the code +x Review SBCL string serialization performance (fals alarm, comparable to allegro) Feature tweaking: x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) @@ -156,8 +156,8 @@ x Remove sleepycat name. Change sleepycat to db-bdb to reflect oracle ownership and avoid confusion for new users -0.6.2 - Advanded work, low-hanging fruit (Summer '07) --------------------------------------------------- +0.7.0 - Advanded work, low-hanging fruit (Summer '07) +----------------------------------------------------- Migrate code base to Darcs and create feature/bug tickets in TRAC @@ -180,6 +180,7 @@ value by default? - Can we do automatic join cursors? - Add lazy deserialize to map functions? +- First-cut query interface Performance: - Improve SQL base-64 serializer performance? @@ -190,6 +191,7 @@ - Add dependency information into secondary index callback functions so that we can more easily compute which indices need to be updated to avoid the global remove/add in order to maintain consistency (Ian) +- Track derived indices across classes Design: - Move secondary index maintenance to backend; decison on how to call update fn's @@ -222,7 +224,7 @@ - A guide to performance - An overview of licensing issues... -0.7.0: Native Lisp Backend (beta), Fast In-Memory Operations +0.8.0: Native Lisp Backend (beta), Fast In-Memory Operations ------------------------------------------------------------ Major features: @@ -272,7 +274,7 @@ - Usage model examples for new features - 64-bit oids / 64-bit file sizes -0.7.1 - Elephant BDB/SQL/Lisp Production Release +0.8.1 - Elephant BDB/SQL/Lisp Pre-production Release -------------------------------------------------- - More work on testing, examples and documentation - Intent is for this to be a major, long-term supported release prior @@ -281,9 +283,9 @@ - Online GC for lisp backend? -0.8.0 - Supporting Tools Release +0.9.0 - Supporting Tools Release -------------------------------------------------- - - Richer query language and compiler + - Richer query language and query compiler - Repository browser - a simple REPL tool like the Slime inspector to see what classes are in a repository and what state they're in...useful for long-lived repositories or if you've forgotten a variable name @@ -291,11 +293,12 @@ - Support for cheap persistent sets (medium? can do on SQL?) - Persistent aggregates for better conceptual integration with lisp? - pcons, parray, pstruct, etc + - push/pop elements from a list defined on a persistent slot? 1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------ - Significant work on test cases & testing framework - - Final pass of performance enhancements + - Final pass of performance enhancements and review - Invite community review and testing ========================================================

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 25 Feb '07

25 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv16484 Modified Files: classindex.lisp package.lisp serializer.lisp serializer2.lisp Log Message: Support for struct serialization --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/24 14:51:59 1.24 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/25 03:37:37 1.25 @@ -3,25 +3,28 @@ ;;; classindex.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 +;;; Copyright (c) 2006,2007 Ian Eslick +;;; <ieslick at common-lisp.net> ;;; -;;; License: Lisp Limited General Public License -;;; http://www.franz.com/preamble.html +;;; Elephant users are granted the rights to distribute and use this software +;;; as governed by the terms of the Lisp Limited General Public License +;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; (in-package "ELEPHANT") (declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) +;; ================================= +;; LOW-LEVEL API SPECIFICATION +;; ================================= + ;; -;; User level class indexing control protocol +;; Operates against the current *store-controller* but many +;; accept a :sc keyword to change the controller. The specific +;; indices created can be specialized on the controller type. +;; See the internal implementor protocol below ;; -;; Operates against the current *store-controller* -;; but many accept a :sc keyword to change the controller -;; The specific indices created can be specialized on the -;; controller type. See the internal implementor protocol -;; below. (defgeneric find-class-index (persistent-metaclass &rest rest) (:documentation "This method is the way to access the class index via @@ -60,50 +63,9 @@ (:documentation "Remove a derived index by providing the derived name used to name the derived index")) - -;; =========================== -;; INDEX UPDATE ROUTINE -;; =========================== - -(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) - "Anything that side effects a persistent-object slot should call this to keep - the dependant indices in synch. Only classes with derived indices need to - update on writes to non-indexed slots. This is a side effect of user-managed - indices in Elephant - a necessity because we allow arbitrary lisp expressions to - determine index value so without bi-directional pointers, the indices cannot - automatically update a changed indexed value in derived slots" - (let ((slot-name (slot-definition-name slot-def)) - (oid (oid instance)) - (con (get-con instance))) - (declare (type fixnum oid)) - (if (no-indexing-needed? class instance slot-def oid) - (persistent-slot-writer con new-value instance slot-name) - (let ((class-idx (find-class-index class))) - (ensure-transaction (:store-controller con) - (when (get-value oid class-idx) - (remove-kv oid class-idx)) - (persistent-slot-writer con new-value instance slot-name) - (setf (get-value oid class-idx) instance)))))) - -(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) - (let ((class-idx (find-class-index class)) - (oid (oid instance)) - (sc (get-con instance))) - (ensure-transaction (:store-controller sc) - (let ((obj (get-value oid class-idx))) - (remove-kv oid class-idx) - (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) - (setf (get-value oid class-idx) obj))))) - -(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 - -;; =========================== -;; CLASS INDEX INTERFACE -;; =========================== +;; ================================== +;; LOW-LEVEL CLASS INDEXING API +;; ================================== (defmethod find-class-index ((class-name symbol) &key (sc *store-controller*) (errorp t)) (find-class-index (find-class class-name) :sc sc :errorp errorp)) @@ -148,7 +110,6 @@ :format-control "Class ~A is not enabled for indexing" :format-arguments (list (class-name class))))) - (defmethod find-inverted-index ((class symbol) slot &key (null-on-fail nil)) (find-inverted-index (find-class class) slot :null-on-fail null-on-fail)) @@ -185,9 +146,49 @@ (t (e) (warn "Unable to clear class index caches ~A" e))))) -;; ============================= -;; INDEXING INTERFACE -;; ============================= +;; ============================ +;; METACLASS PROTOCOL HOOKS +;; ============================ + +(defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) + "Anything that side effects a persistent-object slot should call this to keep + the dependant indices in synch. Only classes with derived indices need to + update on writes to non-indexed slots. This is a side effect of user-managed + indices in Elephant - a necessity because we allow arbitrary lisp expressions to + determine index value so without bi-directional pointers, the indices cannot + automatically update a changed indexed value in derived slots" + (let ((slot-name (slot-definition-name slot-def)) + (oid (oid instance)) + (con (get-con instance))) + (declare (type fixnum oid)) + (if (no-indexing-needed? class instance slot-def oid) + (persistent-slot-writer con new-value instance slot-name) + (let ((class-idx (find-class-index class))) + (ensure-transaction (:store-controller con) + (when (get-value oid class-idx) + (remove-kv oid class-idx)) + (persistent-slot-writer con new-value instance slot-name) + (setf (get-value oid class-idx) instance)))))) + +(defmethod indexed-slot-makunbound ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition)) + (let ((class-idx (find-class-index class)) + (oid (oid instance)) + (sc (get-con instance))) + (ensure-transaction (:store-controller sc) + (let ((obj (get-value oid class-idx))) + (remove-kv oid class-idx) + (persistent-slot-makunbound sc instance (slot-definition-name slot-def)) + (setf (get-value oid class-idx) obj))))) + +(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 + +;; ============================ +;; EXPLICIT INDEX MGMT API +;; ============================ (defmethod enable-class-indexing ((class persistent-metaclass) indexed-slot-names &key (sc *store-controller*)) (let ((croot (controller-class-root sc))) @@ -321,9 +322,9 @@ (warn "Derived index ~A does not exist in ~A" name (class-name class)) nil))) -;; ========================= -;; Low level cursor API -;; ========================= +;; =================== +;; USER CURSOR API +;; =================== (defgeneric make-inverted-cursor (persistent-metaclass name) (:documentation "Define a cursor on the inverted (slot or derived) index")) @@ -331,13 +332,6 @@ (defgeneric make-class-cursor (persistent-metaclass) (:documentation "Define a cursor over all class instances")) -;; TODO! -;;(defgeneric make-join-cursor ((class persistent-metaclass) &rest specification) -;; (:documentation "Make a join cursor using the slot-value pairs in -;; the specification assoc-list. Support for complex queries -;; requiring new access to db-functions and a new cursor type")) - -;; implementation (defmethod make-inverted-cursor ((class persistent-metaclass) name) (make-cursor (find-inverted-index class name))) @@ -355,9 +349,9 @@ (cursor-close ,var)))) -;; ==================================== -;; Low Level Mapping API -;; ==================================== +;; ====================== +;; USER MAPPING API +;; ====================== (defun map-class (fn class) "Perform a map operation across all instances of class. Takes a @@ -386,9 +380,9 @@ (map-index #'wrapper index :start start :end end)))) -;; =============================== -;; User-level LIST-oriented API -;; =============================== +;; ================= +;; USER SET API +;; ================= (defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/24 14:51:59 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/25 03:37:37 1.19 @@ -62,6 +62,8 @@ #:btree-index #:get-primary-key #:primary #:key-form #:key-fn + #:struct-constructor + #:migrate #:*inhibit-slot-copy* #:add-symbol-conversion #:add-package-conversion #:*always-convert* @@ -121,6 +123,7 @@ ;; Utilities #:slots-and-values + #:struct-slots-and-values ) #+cmu (:import-from :pcl --- /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/04 04:34:57 1.21 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer.lisp 2007/02/25 03:37:37 1.22 @@ -29,6 +29,20 @@ (funcall (symbol-function (controller-deserialize sc)) bs sc)) ;; +;; Special structure support +;; + +(defgeneric struct-constructor (class) + (:documentation "Called to get the constructor name for a struct class. Users + should overload this when they want to serialize non-standard + constructor names. The default constructor make-xxx will work by + default. The argument is an eql style type: i.e. of type (eql 'my-struct)")) + +(defmethod struct-constructor ((class t)) + (symbol-function (intern (concatenate 'string "MAKE-" (symbol-name class)) + (symbol-package class)))) + +;; ;; SQL encoding support ;; @@ -167,10 +181,8 @@ ;;;; Common utilities ;;;; -;; slot names and values for ordinary objects - (defun slots-and-values (o) - (declare (optimize (speed 3) (safety 0))) + "List of slot names followed by values for object" (loop for sd in (compute-slots (class-of o)) for slot-name = (slot-definition-name sd) with ret = () @@ -182,6 +194,25 @@ (push slot-name ret)) finally (return ret))) +(defun struct-slots-and-values (object) + "List of slot names followed by values for structure object" + (let ((result nil) + (slots + #+openmcl + (let* ((sd (gethash (class-name (class-of object)) ccl::%defstructs%)) + (slots (if sd (ccl::sd-slots sd)))) + (mapcar #'car (if (symbolp (caar slots)) slots (cdr slots)))) + #+cmu + (mapcar #'pcl:slot-definition-name (pcl:class-slots (class-of object))) + #+lispworks + (structure:structure-class-slot-names (class-of object)) + #+allegro + (mapcar #'mop:slot-definition-name (mop:class-slots (class-of object))))) + (loop for slot in slots do + (push (slot-value object slot) result) + (push slot result)) + result)) + ;; array type tags (declaim (type hash-table array-type-to-byte byte-to-array-type)) @@ -229,8 +260,7 @@ (defun int-byte-spec (position) "Shared byte-spec peformance hack; not thread safe so removed from use for serializer2" - (declare (optimize (speed 3) (safety 0)) - (type (unsigned-byte 24) position)) + (declare (type (unsigned-byte 24) position)) #+(or cmu sbcl allegro) (progn (setf (cdr *resourced-byte-spec*) (* 32 position)) *resourced-byte-spec*) --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/24 14:51:59 1.27 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/25 03:37:37 1.28 @@ -218,7 +218,6 @@ (setf (gethash frob circularity-hash) id)) (%serialize (type-of frob)) (let ((svs (slots-and-values frob))) - (declare (dynamic-extent svs)) (%serialize (/ (length svs) 2)) (loop for item in svs do (%serialize item))))))) @@ -261,21 +260,8 @@ (loop for key being the hash-key of frob using (hash-value value) do - (%serialize key) - (%serialize value)))))) - ;; (structure-object - ;; (buffer-write-byte +struct+ bs) - ;; (let ((idp (gethash frob circularity-hash))) - ;; (if idp (buffer-write-int32 idp bs) - ;; (progn - ;; (buffer-write-int32 (incf lisp-obj-id) bs) - ;; (setf (gethash frbo circularity-hash) lisp-obj-id) - ;; (%serialize (type-of frob)) - ;; (let ((svs (slots-and-values frob))) - ;; (declare (dynamic-extent svs)) - ;; (%serialize (/ (length svs) 2)) - ;; (loop for item in svs - ;; do (%serialize item))))))) + (%serialize key) + (%serialize value)))))) (array (buffer-write-byte +array+ bs) (let ((idp (gethash frob circularity-hash))) @@ -300,6 +286,18 @@ (loop for i fixnum from 0 below (array-total-size frob) do (%serialize (row-major-aref frob i))))))) + (structure-object + (buffer-write-byte +struct+ bs) + (let ((idp (gethash frob circularity-hash))) + (if idp (buffer-write-int32 idp bs) + (progn + (buffer-write-int32 (incf lisp-obj-id) bs) + (setf (gethash frob circularity-hash) lisp-obj-id) + (%serialize (type-of frob)) + (let ((svs (struct-slots-and-values frob))) + (%serialize (/ (length svs) 2)) + (loop for item in svs + do (%serialize item))))))) (t (format t "Can't serialize a object: ~A of type ~A~%" frob (type-of frob)))))) (%serialize frob) (release-circularity-hash circularity-hash) @@ -515,6 +513,24 @@ do (setf (row-major-aref a i) (%deserialize bs))) a)))) + ((= tag +struct+) + (let* ((id (buffer-read-fixnum bs)) + (maybe-o (lookup-id id))) + (if maybe-o maybe-o + (let ((typedesig (%deserialize bs))) + (let ((o (or (handler-case + (funcall (struct-constructor (find-class typedesig))) + (error (v) (format t "got typedesig error for struct: ~A ~A ~%" v typedesig) + (list 'caught-error v typedesig))) + (list 'uninstantiable-object-of-type typedesig)))) + (if (listp o) o + (progn + (add-object o) + (loop for i fixnum from 0 below (%deserialize bs) do + (let ((name (%deserialize bs)) + (value (%deserialize bs))) + (setf (slot-value o name) value))) + o))))))) (t (error (format nil "deserialize of object tagged with ~A failed" tag))))))) (etypecase buf-str (null (return-from deserialize nil))

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 24 Feb '07

24 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9022/src/elephant Modified Files: classes.lisp classindex-utils.lisp classindex.lisp controller.lisp migrate.lisp package.lisp serializer2.lisp unicode2.lisp Log Message: Remove or document NOTE comments in Elephant & BDB code --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/21 06:29:31 1.15 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/24 14:51:59 1.16 @@ -184,8 +184,6 @@ ;; (defmethod update-instance-for-redefined-class :around ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; NOTE: probably should delete discarded slots, but we'll worry about that later - ;; (also will want to delete discarded indices since we don't have a good GC) (declare (ignore property-list discarded-slots added-slots)) (prog1 (call-next-method) @@ -215,7 +213,7 @@ (retained-persistent-slots (set-difference raw-retained-persistent-slots retained-unbound-slots))) ;; Apply default values for unbound & new slots (updates class index) (apply #'shared-initialize current (append new-persistent-slots retained-unbound-slots) initargs) - ;; Copy values from old class (NOTE: should delete discarded slots?) (updates class index) + ;; Copy values from old class (updates class index) (ensure-transaction (:store-controller (get-con current)) (loop for slot-def in (class-slots new-class) when (member (slot-definition-name slot-def) retained-persistent-slots) @@ -270,7 +268,6 @@ ;; ====================================================== ;; Handling metaclass overrides of normal slot operation -;; NOTE: Closer to MOP should replace this need... ;; ====================================================== ;; --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/18 23:38:18 1.5 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/24 14:51:59 1.6 @@ -190,18 +190,21 @@ (mapcar #'(lambda (rule-specs) (cons (car rule-specs) (mapcar #'make-synch-rule (cdr rule-specs)))) - '((:class ;; class changes db + '((:class ;; class overwrites db ((not db-slot) class-indexed => add-slot-index) (db-slot (not class-indexed) => remove-slot-index) (db-derived (not class-indexed) (not class-persistent) (not class-transient) => register-derived-index)) - (:union ;; merge both sides + (:union ;; merge both sides - conflicts favor class (db-slot (not class-indexed) => register-indexed-slot) ((not db-slot) class-indexed => add-slot-index) (db-derived (not class-derived) => register-derived-index) (db-derived class-persistent => remove-derived-index warn)) - ;; NOTE: What about cases where we need to remove things as below? - (:db ;; db changes class + (:db + ;; :db updates indexing in classes when indexes and + ;; slots overlapped there may still be problems with + ;; derived indices that refer to missing slots or + ;; conflict with new slotnames ((not db-slot) class-indexed => unregister-indexed-slot) ((not db-derived) class-derived => unregister-derived-index) (db-slot class-persistent => register-indexed-slot) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/22 20:19:57 1.23 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/24 14:51:59 1.24 @@ -68,7 +68,10 @@ (defmethod indexed-slot-writer ((class persistent-metaclass) (instance persistent-object) (slot-def persistent-slot-definition) new-value) "Anything that side effects a persistent-object slot should call this to keep the dependant indices in synch. Only classes with derived indices need to - update on writes to non-indexed slots." + update on writes to non-indexed slots. This is a side effect of user-managed + indices in Elephant - a necessity because we allow arbitrary lisp expressions to + determine index value so without bi-directional pointers, the indices cannot + automatically update a changed indexed value in derived slots" (let ((slot-name (slot-definition-name slot-def)) (oid (oid instance)) (con (get-con instance))) @@ -77,8 +80,6 @@ (persistent-slot-writer con new-value instance slot-name) (let ((class-idx (find-class-index class))) (ensure-transaction (:store-controller con) - ;; NOTE: Quick and dirty hack to ensure consistency -- needs performance improvement - (when (get-value oid class-idx) (remove-kv oid class-idx)) (persistent-slot-writer con new-value instance slot-name) @@ -279,8 +280,6 @@ (defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) - ;; NOTE: Write routines to recover BDB storage when you've wiped an index... - ;; NOTE: If the transaction aborts we should not update class slots? (if (find-inverted-index class slot-name :null-on-fail t) (progn (when update-class (unregister-indexed-slot class slot-name)) @@ -357,7 +356,7 @@ ;; ==================================== -;; User level Mapping API +;; Low Level Mapping API ;; ==================================== (defun map-class (fn class) @@ -373,7 +372,7 @@ (declare (dynamic-extent map-fn)) (map-btree #'map-fn class-idx)))) -(defun map-instances (fn class index start end) +(defun map-class-index (fn class index start end) "If you want to map over a subset of instances, pick an index and specify bounds for the traversal. Otherwise use map-class for all instances" --- /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/21 04:47:42 1.36 +++ /project/elephant/cvsroot/elephant/src/elephant/controller.lisp 2007/02/24 14:51:59 1.37 @@ -82,9 +82,8 @@ (setf (gethash spec *dbconnection-spec*) sc)) sc))) - -;; NOTE: Check for asdf loaded rather than rely on asdf to? (defun load-backend (type) + (assert (find-package :asdf)) (let ((record (assoc type *elephant-backends*))) (when (or (null record) (not (consp record))) (error "Unknown backend type ~A, cannot load" type)) @@ -177,9 +176,9 @@ then it should return nil")) (defmethod database-version :around (sc) - "Default version assumption for unmarked databases is 0.6.0" -;; NOTE: It is possible to check for 0.5.0 databases, but it is not -;; implemented now due to the low (none?) number of users still on 0.5.0" + "Default version assumption for unmarked databases is 0.6.0. + It is possible to check for 0.5.0 databases, but it is not implemented + now due to the low (none?) number of users still on 0.5.0" (declare (ignorable sc)) (let ((db-version (call-next-method))) (if db-version db-version @@ -497,7 +496,8 @@ ;; Callback hooks for persistent variables ;; -;; NOTE: Design sketch; not sure I'll promote this... +;; Design sketch; not sure I'll promote this. +;; To be looked at again for 0.6.2 or 0.7.0 ;;(defvar *variable-hooks* nil ;; "An alist (specs -> varlist) where varlist is tuple of --- /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/17 12:13:19 1.7 +++ /project/elephant/cvsroot/elephant/src/elephant/migrate.lisp 2007/02/24 14:51:59 1.8 @@ -24,7 +24,7 @@ ;; repositories and is used by the upgrade interface. ;; -;; NOTES AND LIMITATIONS: +;; LIMITATIONS: ;; - Migrate currently will not handle circular list objects ;; - Migrate does not support arrays or standard objects with nested persistent objects ;; - There are potential problems with graphs and other deep structures --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/22 20:19:57 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/24 14:51:59 1.18 @@ -110,7 +110,7 @@ ;; Class mapping API #:map-class - #:map-instances + #:map-class-index ;; Instance query API #:get-instances-by-class --- /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/21 04:47:42 1.26 +++ /project/elephant/cvsroot/elephant/src/elephant/serializer2.lisp 2007/02/24 14:51:59 1.27 @@ -89,14 +89,6 @@ (defconstant +adjustable-p+ #x40) ;; -;; NOTE: Used bad coding practice here: without-interrupts is a single-CPU -;; construct, but most lisps are not native multi-CPU capable so -;; no problems in near term. I used it to avoid general locking overhead -;; as queues are an effective lock-free structure when combined with -;; an allocate-on-empty policy -;; - -;; ;; Circularity Hash for Serializer ;; --- /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/03 04:09:13 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/unicode2.lisp 2007/02/24 14:51:59 1.5 @@ -13,7 +13,7 @@ ;;; as governed by the terms of the Lisp Lesser GNU Public License ;;; (http://opensource.franz.com/preamble.html) also known as the LLGPL. ;;; -;;; NOTE: Here UTF8 means 8-bit < #x79 only for efficiency, UTF16 means UTF16 format +;;; Here UTF8 means 8-bit < #x79 only for efficiency, UTF16 means UTF16 format ;;; but only for values < #xFFFF. In the odd cases of non-0 unicode planes we just ;;; use UTF-32 to avoid the time cost of translation. Only when converting from a ;;; serialized UTF-X do we worry about encoding (UTF32->UTF16). If an ascii/utf8 lisp

1 0