elephant-cvs

elephant-cvs@common-lisp.net

858 discussions

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

20 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv13701/src/elephant Modified Files: classindex.lisp collections.lisp package.lisp Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/20 19:12:58 1.19 @@ -345,35 +345,56 @@ (cursor-close ,var)))) -;; ========================= -;; User-level lisp API -;; ========================= +;; ==================================== +;; User level Mapping API +;; ==================================== + +(defun map-class (fn class) + "Perform a map operation across all instances of class. Takes a + function of one argument, the class instance" + (let* ((class (if (symbolp class) + (find-class class) + class)) + (class-idx (find-class-index class))) + (flet ((map-fn (k v) + (declare (ignore k)) + (funcall fn v))) + (declare (dynamic-extent map-fn)) + (map-btree #'map-fn class-idx)))) + +(defun map-instances (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" + (let* ((index (if (symbolp index) + (find-inverted-index class index) + index))) + (flet ((wrapper (key value pkey) + (declare (ignore key pkey)) + (funcall fn value))) + (declare (dynamic-extent wrapper)) + (map-index #'wrapper index :start start :end end)))) + + +;; =============================== +;; User-level LIST-oriented API +;; =============================== (defgeneric get-instances-by-class (persistent-metaclass)) (defgeneric get-instance-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-value (persistent-metaclass slot-name value)) (defgeneric get-instances-by-range (persistent-metaclass slot-name start end)) -;; map instances -;; iterate over instances - (defmethod get-instances-by-class ((class symbol)) (get-instances-by-class (find-class class))) (defmethod get-instances-by-class ((class persistent-metaclass)) - (let ((instances nil) - (cidx (find-class-index class))) - (with-btree-cursor (cur cidx) - (multiple-value-bind (exists? key val) (cursor-first cur) - (declare (ignore key)) - (when exists? - (push val instances) - (loop - (multiple-value-bind (exists? key val) (cursor-next cur) - (declare (ignore key)) - (if exists? - (push val instances) - (return-from get-instances-by-class instances))))))))) + (let ((instances nil)) + (flet ((accum (c) + (declare (dynamic-extent c)) + (push c instances))) + (map-class #'accum class) + (nreverse instances)))) (defmethod get-instances-by-value ((class symbol) slot-name value) (get-instances-by-value (find-class class) slot-name value)) @@ -381,17 +402,14 @@ (defmethod get-instances-by-value ((class persistent-metaclass) slot-name value) (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) - (declare (ignore skey pkey)) - (when exists? - (push val instances) - (loop - (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) - (declare (ignorable skey pkey)) - (if exists? - (push val instances) - (return-from get-instances-by-value instances))))))))) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class slot-name) + :start value :end value)) + (nreverse instances))) (defmethod get-instance-by-value ((class symbol) slot-name value) (let ((list (get-instances-by-value (find-class class) slot-name value))) @@ -409,27 +427,16 @@ (defmethod get-instances-by-range ((class persistent-metaclass) idx-name start end) (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) - (declare (ignore pkey)) - (if (and exists? (<= skey end)) - (next-in-range skey (cons val instances)) - (nreverse instances)))) - (next-in-range (key instances) - (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) - (declare (ignore pkey skey)) - (if exists? - (next-in-range key (cons val instances)) - (progn - (cursor-pset-range cur key) - (next-range instances)))))) - (multiple-value-bind (exists? skey val pkey) (cursor-pset-range cur start) - (declare (ignore pkey)) - (if (and exists? (<= skey end)) - (next-in-range skey (cons val nil)) - nil))))) - + (let ((instances nil)) + (declare (type list instances)) + (flet ((collector (k v pk) + (declare (ignore k pk)) + (push v instances))) + (declare (dynamic-extent collector)) + (map-index #'collector (find-inverted-index class idx-name) + :start start :end end)) + (nreverse instances))) + (defun drop-instances (instances &key (sc *store-controller*)) (when instances (assert (consp instances)) @@ -440,5 +447,3 @@ (drop-pobject instance)) subset))))) - - --- /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/16 07:11:02 1.9 +++ /project/elephant/cvsroot/elephant/src/elephant/collections.lisp 2007/02/20 19:12:58 1.10 @@ -314,27 +314,71 @@ primary key.")) -;; -;; Some generic utility functions -;; +;; ======================================= +;; Generic Mapping Functions +;; ======================================= (defmacro with-btree-cursor ((var bt) &body body) "Macro which opens a named cursor on a BTree (primary or not), evaluates the forms, then closes the cursor." `(let ((,var (make-cursor ,bt))) - (unwind-protect - (progn ,@body) - (cursor-close ,var)))) + (unwind-protect + (progn ,@body) + (cursor-close ,var)))) (defmethod map-btree (fn (btree btree)) - "Like maphash. Default implementation - overridable" - (with-transaction (:store-controller (get-con btree)) + "Like maphash. Default implementation - overridable + Function of two arguments key and value" + (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (curs btree) (loop (multiple-value-bind (more k v) (cursor-next curs) + (declare (dynamic-extent more k v)) (unless more (return nil)) (funcall fn k v)))))) +(defmethod map-index (fn (index btree-index) &rest args &key start end) + "Like map-btree, but takes a function of three arguments key, value and primary key + if you want to get at the primary key value, otherwise use map-btree" + (declare (dynamic-extent args)) + (let ((sc (get-con index))) + (ensure-transaction (:store-controller sc) + (with-btree-cursor (cur index) + (labels ((next-range () + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-nodup cur) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + (return-from map-index nil)))) + (next-in-range (key) + (multiple-value-bind (exists? skey val pkey) (cursor-pnext-dup cur) + (if exists? + (progn + (funcall fn skey val pkey) + (next-in-range key)) + (progn + (cursor-pset-range cur key) + (next-range)))))) + (declare (dynamic-extent next-range next-in-range)) + (multiple-value-bind (exists? skey val pkey) + (if start + (cursor-pset-range cur start) + (cursor-pfirst cur)) + (if (or (and exists? (not end)) + (and exists? (<= skey end))) + (progn + (funcall fn skey val pkey) + (next-in-range skey)) + nil))))))) + + + +;; =============================== +;; Some generic utility functions +;; =============================== + (defmethod empty-btree-p ((btree btree)) (ensure-transaction (:store-controller (get-con btree)) (with-btree-cursor (cur btree) @@ -345,10 +389,9 @@ (eq k *elephant-properties-label*)) ;; has properties (not (cursor-next cur))) (t nil)))))) - -(defun print-btree-node (k v) - (format t "k ~A / v ~A~%" k v)) +(defun print-btree-entry (k v) + (format t "key: ~A / value: ~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" @@ -361,13 +404,16 @@ (funcall print-fn 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 print-btree-key-and-type (k v) + (format t "key ~A / value type ~A~%" k (type-of v))) -(defun btree-differ (x y) +(defun btree-keys (bt &key (print-fn #'print-btree-key-and-type) (count nil)) + (format t "BTREE keys and types for ~A~%" bt) + (dump-btree bt :print-fn print-fn :count count)) + +(defmethod btree-differ-p ((x btree) (y btree)) + (assert (eq (get-con x) (get-con y))) + (ensure-transaction (:store-controller (get-con x)) (let ((cx1 (make-cursor x)) (cy1 (make-cursor y)) (done nil) @@ -402,4 +448,4 @@ (cursor-close cx1) (cursor-close cy1) rv - )) + ))) --- /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/16 07:11:02 1.14 +++ /project/elephant/cvsroot/elephant/src/elephant/package.lisp 2007/02/20 19:12:58 1.15 @@ -55,7 +55,7 @@ #:persistent #:persistent-object #:persistent-metaclass #:persistent-collection #:defpclass - #:btree #:make-btree #:get-value #:remove-kv #:existp #:map-btree + #:btree #:make-btree #:get-value #:remove-kv #:existp #:indexed-btree #:make-indexed-btree #:add-index #:get-index #:remove-index #:map-indices #:btree-index #:get-primary-key @@ -69,7 +69,7 @@ #:int-byte-spec #:cursor #:secondary-cursor #:make-cursor - #:with-btree-cursor #:cursor-close #:cursor-init + #:cursor-close #:cursor-init #:cursor-duplicate #:cursor-current #:cursor-first #:cursor-last #:cursor-next #:cursor-next-dup #:cursor-next-nodup #:cursor-prev #:cursor-prev-nodup @@ -95,6 +95,21 @@ #:make-inverted-cursor #:make-class-cursor #:with-inverted-cursor #:with-class-cursor + ;; Primitive mapping API + #:with-btree-cursor + #:map-btree + #:map-index + + ;; BTREE Utilities + #:empty-btree-p + #:dump-btree + #:btree-keys + #:btree-differ-p + + ;; Class mapping API + #:map-class + #:map-instances + ;; Instance query API #:get-instances-by-class #:get-instance-by-value

1 0

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

20 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv13701/tests Modified Files: MigrationTests.lisp testcollections.lisp testindexing.lisp Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2006/02/23 14:42:16 1.2 +++ /project/elephant/cvsroot/elephant/tests/MigrationTests.lisp 2007/02/20 19:12:59 1.3 @@ -34,9 +34,9 @@ ;; use for the migration tests. ;; This this configuration for testing between BDB and SQL.... -(setq *test-path-primary* *testpg-spec*) +;;(setq *test-path-primary* *testpg-spec*) ;; (setq *test-path-primary* *testsqlite3-path*) -(setq *test-path-secondary* *testbdb-spec*) +;;(setq *test-path-secondary* *testbdb-spec*) ;; This this configuration for testing from one BDB repository to another... @@ -45,5 +45,5 @@ (setq *test-path-secondary* *testbdb-spec2*) (do-migration-tests *testbdb-spec* *testbdb-spec2*) -(do-migration-tests *testbdb-spec2* *testpg-spec*) +;;(do-migration-tests *testbdb-spec2* *testpg-spec*) --- /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/04 10:08:28 1.16 +++ /project/elephant/cvsroot/elephant/tests/testcollections.lisp 2007/02/20 19:12:59 1.17 @@ -312,6 +312,17 @@ (= (slot2 v) 600)))) t) +(deftest map-indexed-index + (let ((sum 0)) + (flet ((collector (key value pkey) + (incf sum (slot1 value)))) + (map-index #'collector index1 :start nil :end 10) + (map-index #'collector index1 :start 690 :end nil) + (map-index #'collector index1 :start 400 :end 410)) + sum) + 267299) + + (deftest rem-kv (with-transaction (:store-controller *store-controller*) (let ((ibt (make-indexed-btree *store-controller*))) --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/08 22:33:35 1.26 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2007/02/20 19:12:59 1.27 @@ -428,6 +428,13 @@ (push val objects))))) objects))) +(defun normal-lookup () + (let ((normal-check nil)) + (dotimes (i *range-size*) + (push (length (normal-range-lookup *stress-count* *range-size*)) + normal-check)) + normal-check)) + (defun indexed-range-lookup (class count size) (let* ((start (/ count 2)) (end (1- (+ start size))) @@ -436,8 +443,13 @@ res )) - - +(defun index-lookup () + (let ((index-check nil)) + (dotimes (i *range-size*) + (push (length (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + index-check)) + index-check)) + (deftest indexing-timing (progn (make-stress-classes) @@ -458,18 +470,12 @@ (indexed-stress-setup *stress-count* 'stress-index :stress2 10)) (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (push (length (normal-range-lookup *stress-count* *range-size*)) - normal-check)) + (setf normal-check (normal-lookup)) (setf end (get-internal-run-time)) (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (push (length (indexed-range-lookup 'stress-index *stress-count* *range-size*)) - index-check)) + (setf index-check (index-lookup)) (setf end (get-internal-run-time)) (setf index-time (/ (- end start 0.0) internal-time-units-per-second)) (format t "~%Ranged get of ~A/~A objects = Linear: ~A sec Indexed: ~A sec~%"

1 0

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

20 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv13701 Modified Files: TODO elephant.asd Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/TODO 2007/02/18 10:58:58 1.54 +++ /project/elephant/cvsroot/elephant/TODO 2007/02/20 19:12:57 1.55 @@ -6,15 +6,13 @@ 0.6.1 - performance, safety and portability -------------------------------------------- -TASKS TO GET TO ALPHA: +TASKS TO GET TO BETA: Migration: - Validate SQL migration 0.6.0->0.6.1 (Robert) -TASKS TO GET TO BETA: - -BDB Features/Cleanup: -- Derived indices used to fail on re-connect, verify that this is fixed +Ian todo: +- Apply Robert's package translation changes Lisp Support: - Win32 builds @@ -35,12 +33,15 @@ - Migration: Improve printing and informative messages Test coverage: +- Make tests idempotent, clean up interface to tests - Test for optimize storage method (just add probe-file methods to get file size?) - Multi-threading stress tests? Ensure that there are conflicts and lots of serialization happening concurrently to make sure that multi-threading is in good shape (Henrik's code) - Unicode tests - Test with UTF-16 and UTF-32 strings (construct with char-code?) - Ensure that variable length UTF-8 is automatically stored as UTF-16 +- Map tests +- Class index sychronization tests TASKS TO GET TO FINAL RELEASE: @@ -58,7 +59,20 @@ 0.6.1 - Features COMPLETED to date ---------------------------------- -February +POST ALPHA CHECKINS: + +Major Bugs: +x Derived indices fail to re-connect after reopening a database under :class synchronization policy (Ian) + +Minor Bugs: +x Enable with-transactions to properly process forms returning multiple values (Ian) +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 + +Feature tweaking: +x Orthogonal feature addition: map-index, map-class and map-instances to avoid consing (Ian) February 13-17th, 2007: x Allow checkpoint of BDB via db-bdb::checkpoint @@ -152,6 +166,8 @@ 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? Performance: - Implement unicode performance hacks for various lisps; validate UTF8 works everywhere @@ -167,15 +183,12 @@ - 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) - (log these in Track) + (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. - - 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? - 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 @@ -191,32 +204,53 @@ 0.7.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) - - Full support for DCM or integration of DCM functionality - - Integrate prevalence-like in-memory database system for single image, - multiple-thread operation - - Richer set of policy decisions on per-class basis - - Concurrent mode (for backends that allow multiple processes to connect, current default) - - Single-user mode (cache values in instance slots for fast reads, write-through) - - Backing store mode (read/write to normal slots except on object creation or synch) - (in-memory slot indexing, on disk class) - (works for any backend) - - Backing-store mode - - Controller 'switches' - - NoSynch - allow transactions to be lost on failure but maintains consistency - instead of performance - - Upgrade overall functionality - - Solid garbage collection strategy - - 64-bit oids / 64-bit file sizes? - - class templates stored and cached - - (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!] - - Usage model examples + - Usage model examples for new features + - 64-bit oids / 64-bit file sizes 0.7.1 - Elephant BDB/SQL/Lisp Production Release -------------------------------------------------- @@ -224,20 +258,19 @@ - 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.8.0 - Supporting Tools Release -------------------------------------------------- - - Add special support (if any) for persistent graph structures & queries - (ala AllegroCache) - - Support for cheap persistent sets (medium? can do on SQL?) - - Native persistent hashes (easy for BDB; can do on SQL backends?) - - Persistent aggregates for better conceptual integration with lisp? - - pcons, parray, pstruct, etc - - Support a simple object query language over the database + - Richer query language and 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 1.0 - Final Production release (1st long-term version since 0.7.1) ------------------------------------------------------------------------ --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/18 22:45:39 1.31 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/20 19:12:57 1.32 @@ -118,6 +118,31 @@ input-file "-lm")) +;;(defmethod compiler-options ((compiler (eql :gcc-cygwin)) (c elephant-c-source) &key input-file output-file) +;; (unless (and input-file output-file) +;; (error "Must specify both input and output files")) +;; (list +;; "-shared" +;; "-mno-cygwin" +;; "-mwindows" +;; "-std=c99" +;; input-file +;; "-o" output-file +;; "--export-symbols" +;; (namestring (make-pathname :defaults output-file :type "def")))) + +;;gcc -mno-cygwin -mwindows -std=c99 -c libmemutil.c +;;dlltool -z libmeutil.def --export-all-symbols -e exports.o -l libmemutil.lib libmemutil.o +;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll + +;;gcc -shared -mno-cygwin -mwindows libmemutil.o exports.o -o libmemutil.dll + +;;And this is the script for libsleepycat.dll: +;; +;;gcc -mno-cygwin -mwindows -c -Wall -std=c99 -L/c/DB/Berkeley\ DB\ 4.4.20/lib/ -I/c/DB/Berkeley\ DB\ 4.4.20/include/ libsleepycat.c +;;dlltool -z libsleepycat.def --export-all-symbols -e exports.o -l libsleepycat.lib libsleepycat.o +;;gcc -shared -mno-cygwin -mwindows -L/c/DB/Berkeley\ DB\ 4.4.20/bin/ -llibdb44 libsleepycat.o exports.o -o libsleepycat.dll + (defmethod compiler-options ((compiler (eql :msvc)) (c elephant-c-source) &key input-file output-file) (error "MSVC compiler option not supported yet"))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Feb '07

20 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv13701/src/db-bdb Modified Files: bdb-collections.lisp bdb-transactions.lisp libberkeley-db.def Log Message: Export btree utilities; implement efficient map operators, reimplement get-instance methods; add test of map-index; better declarations --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/17 12:13:19 1.20 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-collections.lisp 2007/02/20 19:12:58 1.21 @@ -113,13 +113,16 @@ (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 - :key-form key-form))) - (setf (gethash index-name (indices-cache bt)) index) - (setf (gethash index-name ht) index) - (setf (indices bt) ht) + (let ((index + (ensure-transaction (:store-controller sc) + (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) + index)))) (when populate (populate bt index)) index) (error "Invalid index initargs!")))) @@ -150,7 +153,7 @@ (if last-key (cursor-set cursor last-key) (cursor-first cursor)) - (loop for i from 0 upto 1000 + (loop for i from 0 upto 1000 while continue do (multiple-value-bind (valid? k v) (cursor-current cursor) --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 02:33:59 1.9 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 19:12:58 1.10 @@ -47,7 +47,8 @@ (unwind-protect (multiple-value-prog1 (funcall txn-fn) - (db-transaction-commit txn :txn-nosync txn-nosync + (db-transaction-commit txn + :txn-nosync txn-nosync :txn-sync txn-sync) (setq success t)) (unless success --- /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/01/20 22:12:17 1.2 +++ /project/elephant/cvsroot/elephant/src/db-bdb/libberkeley-db.def 2007/02/20 19:12:58 1.3 @@ -67,8 +67,11 @@ db_env_get_timeout db_env_set_lk_detect db_env_get_lk_detect + db_env_txn_checkpoint db_env_lock_detect + db_set_error_file db_associate + db_compact never_index db_fake_associate next_counter \ No newline at end of file

1 0

[elephant-cvs] CVS elephant/src/contrib/rread/dcm
by rread 20 Feb '07

20 Feb '07

Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm In directory clnet:/tmp/cvs-serv2139 Modified Files: dcm-macros.lisp dcm-package.lisp dcm-tests.lisp dcm.asd dcm.lisp gdcm.lisp Log Message: Latest version of DCM --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2007/02/20 15:54:21 1.2 @@ -1,22 +1,7 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; dcm-macros -;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> - (in-package "DCM") +(use-package "SB-THREAD") + (defmacro init-director (cls dirclass &rest x) `(let ((dir (make-instance ,cls ,@x))) (initialize dir ,cls ,dirclass) @@ -31,3 +16,30 @@ ;; (load-all dir) dir)) +(defvar *dcm-mutexes* (make-hash-table :test 'equal)) + +(defvar *a-mutex* (sb-thread::make-mutex :name "my lock")) + +(defun insure-mutex (name) + (let ((mtx (gethash name *dcm-mutexes*)) + ) + (or mtx (setf (gethash name *dcm-mutexes*) (sb-thread:make-mutex :name name))) + ) + ) + +;; This assumes that the the variable "dir" is being defined and that we can can +;; create +(defmacro defmethodex (mname dir args &body body) + `(defmethod ,mname ,(cons dir args) +;; (format t "Thread ~A running ~%" sb-thread::*current-thread*) + (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" ,(car dir)))) +;; (format t "Thread ~A got the lock~%" sb-thread::*current-thread*) + (let ((ret + ,@body)) +;; (format t "Thread ~A dropping lock~%" sb-thread::*current-thread*) + ret + ) + ) + ) + ) + --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2007/02/20 15:54:21 1.2 @@ -1,19 +1,9 @@ ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; -;;; dcm-package.lisp +;;; dcm-package.asd -- package definition for DCM ;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> +;;; Copyright (c) 2005 Robert L. Read <read(a)robertlread.net> +;;; All rights reserverd. (defpackage dcm (:documentation @@ -31,6 +21,7 @@ #:*DEF-STORE-NAME* #:key + #:mtype #:key-equal #:dcm-equal #:max-key-value @@ -98,6 +89,7 @@ #:get-all-cur-objects #:get-all-objects-gen #:retire + #:promote #:find-generation #:GenDir ) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2007/02/20 15:54:21 1.2 @@ -1,23 +1,23 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; dcm-tests.lisp -;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> - (in-package "DCM") - +(defclass UserObject (managed-object) + ((username :type 'string :initform "" :initarg :uname :accessor :username) + (password :type 'string :initform "" :initarg :pword :accessor :password) + (email :type 'string :initform "" :initarg :email :accessor :eml) + (fullname :type 'string :initform "" :initarg :fullname :accessor :fllnm) + (profile :type 'string :initform "" :initarg :profile :accessor :prfl) + (motto :type 'string :initform "" :initarg :motto :accessor :mtt) + (privileges :type 'list :initform '() :initarg :privileges :accessor :prvlgs) + (preflang :type 'string :initform "en" :initarg :preflang :accessor :prflng) +;; For now, this will just be a nice big association list, and +;; the only prefs I have right now are gridconfigurations + (prefs :type 'list :initform '() :initarg :prefs :accessor :prfs) +;; These controls the markets that a user is a allowed to read or create an offer in +;; (keys identifying markets are stored here.) +;; We DO NOT give privilege to the public market; We don't want to +;; store more than necessary. If a market is public, it is not represented here +;; (in the read list!) +)) (defclass ExObjectDirector (hash-ele-director) ((mtype :initform 'ExObject @@ -99,6 +99,15 @@ ((null dirs)) (setf s (+ s (length (get-all-objects (car dirs)))))) (assert (= s 1)))) + +(defun many-threads () + (let ( + (ed (init-director 'ExObjectDirector 'ExObjectDirector)) + ) + (dotimes (x 100) + (sb-thread:make-thread + #'(lambda () (format t "YYY~A~%" (get-unused-key-value ed))))) +)) ;; This command should test everything so far.... @@ -108,4 +117,5 @@ (tm-register-then-lookup dt) (tm-get-all-objects dt) (tm-test-elephant dt) + (many-threads) )) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 15:27:36 1.2 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2007/02/20 15:54:21 1.3 @@ -2,25 +2,14 @@ ;;; ;;; dcm.asd -- ASDF system definition for DCM ;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> - +;;; Copyright (c) 2005 Robert L. Read <read(a)robertlread.net> +;;; All rights reserverd. (defsystem dcm :name "dcm" :author "Robert L. Read <read(a)robertlread.net>" :version "0.1" :maintainer "Robert L. Read <read(a)robertlread.net" - :licence "LLGPL; part of Elephant" + :licence "All Rights Reserverd" :description "A simple object prevalence system with strategies" :long-description "An object prevalence system with strategies built on Elephant" :depends-on (:elephant) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2007/02/20 15:54:21 1.2 @@ -1,19 +1,26 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; Copyright 2004, Robert L. Read. All rights reserved. ;;; -;;; dcm-tests.lisp -;;; -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> + +;; It seems silly to have to do this, but I suspect it +;; will make the inheritance work better. +;; An open question is do we want to have to subclass keys +;; or not; certainly a common error is to pass in the +;; wrong key. + +;; I'm currently not sure how to load this file properly +;; and how to run ALL the test with a single command. + +;; Note: as of Jun. 12, 2006, I am trying to make this thread safe. +;; according to my understanding and experiments there are two +;; problems: SBCL itself is not threadsafe (hash tables are mentioned +;; in particular) although it is probably improving with every release. +;; By my experiments, I have specifically duplicated a terrible, unrecoverable +;; hang in the CLSQL connection both through elephant and with direct queries. +;; +;; Therefore, since everything I personally do is built on top +;; of DCM, I am imposing thread-safety at the DCM level (even though in +;; the best case this probably does not allow as much concurrency as one might like.) +;; (in-package "DCM") @@ -23,10 +30,12 @@ (defparameter *ELEPHANT-CAT* "elephant director") (defparameter *DEF-STORE-NAME* "DefaultStoreX") + (asdf:operate 'asdf:load-op :elephant) (use-package "ELEPHANT") ;; (asdf:operate 'asdf:load-op :ele-bdb) (asdf:operate 'asdf:load-op :ele-clsql) +(use-package "SB-THREAD") (defclass key () ((id :type 'integer @@ -80,13 +89,17 @@ (k (mid a)) (if (typep a 'key) (k a) - a))) + (if (typep a 'string) + (parse-integer a) + a)))) (kb (if (typep b 'managed-object) (k (mid b)) (if (typep b 'key) (k b) - b)))) + (if (typep a 'string) + (parse-integer a) + b))))) (and ka kb (= ka kb)) ) @@ -188,7 +201,10 @@ (defgeneric register-obj (director managed-object) ) -(defgeneric lookup-obj (director key) +(defgeneric lookup-obj (director obj) + + ) +(defgeneric lookup-obj-key (director key) ) (defgeneric delete-obj (director key) @@ -197,6 +213,18 @@ (defgeneric get-all-objects (director) ) +(defmethod lookup-obj ((dir director) (id key)) + (lookup-obj-key dir id) +) + +(defmethod lookup-obj ((dir director) (id integer)) + (lookup-obj-key dir (make-instance 'key :id id)) +) + +(defmethod lookup-obj ((dir director) (id string)) + (lookup-obj-key dir (make-instance 'key :id (parse-integer id))) +) + (defmethod get-all-cur-objects ((dir director)) (get-all-objects dir)) @@ -213,6 +241,14 @@ (delete-obj dir (mid mo))) (get-all-objects dir))) + +;; (defmethodex delete-all-objects-from-director (dir director) (tp) +;; (mapc +;; #'(lambda (mo) +;; (delete-obj dir (mid mo))) +;; (get-all-objects dir))) + + ;; Create a hash-based subclass (defparameter *HASH-CAT* "hash director") @@ -227,7 +263,9 @@ (defmethod get-all-objects ((dir hash-director)) (get-all-objects-type dir 'managed-object)) -(defmethod get-all-objects-type ((dir hash-director) tp) + +(defmethodex get-all-objects-type (dir hash-director) (tp) + ;; (defmethod get-all-objects-type ((dir hash-director) tp) (let ((objs '())) (maphash #'(lambda (k v) (if (typep v tp) @@ -235,7 +273,8 @@ (slot-value dir 'key-to-mo)) objs)) -(defmethod get-all-objects-owned-by ((dir hash-director) (o key)) +(defmethodex get-all-objects-owned-by (dir hash-director) ((o key)) + ;; (defmethod get-all-objects-owned-by ((dir hash-director) (o key)) (let ((objs '())) (maphash #'(lambda (key v) (if (equal (k (:ownr v)) (k o)) @@ -248,7 +287,10 @@ ;; There does not appear to be a "hash-reduce". ;; That would be an elegant function to have for ;; this and other purposes. -(defmethod get-unused-key-value ((dir hash-director)) +(defmethodex get-unused-key-value (dir hash-director) () + (get-unused-key-value-naked dir)) + +(defmethod get-unused-key-value-naked ((dir hash-director)) (the integer (+ 1 (hash-keys-reduce #'max (slot-value dir 'key-to-mo) @@ -280,14 +322,17 @@ (setf r (funcall fun r key))))) r)) -(defmethod register-obj ((dir hash-director) (mo managed-object)) - (unless (mid mo) - (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir)))) + +(defmethodex register-obj (dir hash-director) ((mo managed-object)) + (progn + (unless (mid mo) + (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir)))) (with-slots (key-to-mo) dir - (setf (gethash (k (mid mo)) key-to-mo) mo))) + (setf (gethash (k (mid mo)) key-to-mo) mo)))) -(defmethod lookup-obj ((dir hash-director) (id key)) +;; (defmethodex lookup-obj-key (dir hash-director) ((id key)) +(defmethod lookup-obj-key ((dir hash-director) (id key)) (with-slots (key-to-mo) dir (gethash (k id) key-to-mo))) @@ -295,7 +340,8 @@ ;; I would really like to insist on create-read-update-delete functions ;; for the abstract class of director. -(defmethod delete-obj ((dir hash-director) (id key)) +(defmethodex delete-obj (dir hash-director) ((id key)) + ;; (defmethod delete-obj ((dir hash-director) (id key)) (with-slots (key-to-mo) dir (remhash (k id) key-to-mo))) @@ -310,14 +356,16 @@ ;; These functions will have to be expanded later to include ;; multiple controllers. It would be really nice if I could tie ;; this to garabase collection instead. -(defvar *basic-store-controller* (open-store *DCM-DEFAULT*)) +;; (defvar *basic-store-controller* (open-store *DCM-DEFAULT*)) +(defvar *basic-store-controller* nil) (defun reconnect-db () (reconnect-controller *basic-store-controller*)) (defun init-elephant-controllers (dcm-default) - (setq *basic-store-controller* (open-store dcm-default))) + (setq *basic-store-controller* (open-store dcm-default)) + (setq elephant::*store-controller* *basic-store-controller*)) (defun release-elephant-controllers () (close-controller *basic-store-controller*)) @@ -346,6 +394,7 @@ (let* ((name (format nil "DCM-SPECIAL-~A" c)) (sc (slot-value dir 'root)) (bt (get-from-root name :store-controller sc))) + (format t "bt of name ~A is: ~A~%" name bt) (unless bt (setf bt (add-to-root name (make-btree sc) :store-controller sc))) (setf (slot-value dir 'dcm-btree) bt)) @@ -359,11 +408,13 @@ ;; and in fact, pushing this into Elephant), would be an ;; excellent idea. ;; (defun empty-out-corrupted-btree (c sc) -;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c))) -;; (bt (get-from-root name :store-controller sc))) -;; ; "delete from keyvalue where clct_id = ") -;; )) -(defmethod register-many-random ((dir director) n) +;; (let* ((name (format nil "DCM-SPECIAL-~A" (class-name c))) +;; (bt (get-from-root name :store-controller sc))) +;; "delete from keyvalue where clct_id = ") +;; ) + +(defmethodex register-many-random (dir director) (n) + ;; (defmethod register-many-random ((dir director) n) (with-slots (mtype) dir @@ -374,15 +425,30 @@ (make-instance mtype)))))) ;; I'm goint to try using the ele::next-oid fuction here: -(defmethod get-unused-key-value ((dir elephant-director)) +(defmethodex get-unused-key-value (dir elephant-director) () + (get-unused-key-value-naked dir)) + +(defmethod get-unused-key-value-naked ((dir elephant-director)) (the integer (with-slots (root) dir (ELEPHANT::next-oid root)))) +;; (defmethodex get-all-objects (dir elephant-director) () (defmethod get-all-objects ((dir elephant-director)) (get-all-objects-type dir 'managed-object)) -(defmethod get-all-objects-type ((dir elephant-director) tp) +(defmethodex get-all-objects-type (dir elephant-director) (tp) + ;; (defmethod get-all-objects-type ((dir elephant-director) tp) + (with-slots (dcm-btree) dir + (let ((objs '())) + (map-btree #'(lambda (k x) + (declare (ignore k)) + (if (typep x (:mtype dir)) + (push x objs))) + dcm-btree) + objs))) + +(defmethod get-all-objects-type-xxxx ((dir elephant-director) tp) (with-slots (dcm-btree) dir (let ((objs '())) (map-btree #'(lambda (k x) @@ -392,7 +458,8 @@ dcm-btree) objs))) -(defmethod get-all-objects-owned-by ((dir elephant-director) (o key)) +(defmethodex get-all-objects-owned-by (dir elephant-director) ((o key)) + ;; (defmethod get-all-objects-owned-by ((dir elephant-director) (o key)) (with-slots (dcm-btree) dir (let ((objs '())) (map-btree #'(lambda (k x) @@ -414,18 +481,23 @@ x) :accessor :elefdir))) -(defmethod register-obj ((dir elephant-director) (mo managed-object)) +(defmethodex register-obj (dir elephant-director) ((mo managed-object)) + ;; (defmethod register-obj ((dir elephant-director) (mo managed-object)) + (progn (unless (mid mo) - (setf (mid mo) (make-instance 'key :id (get-unused-key-value dir)))) + (setf (mid mo) (make-instance 'key :id (get-unused-key-value-naked dir)))) + ;; (sb-thread:with-mutex ((insure-mutex (format nil "mutex-~A" dir))) (with-slots (dcm-btree) dir (progn - (setf (get-value (mid mo) dcm-btree) mo)))) + (setf (get-value (mid mo) dcm-btree) mo))))) -(defmethod lookup-obj ((dir elephant-director) (id key)) +(defmethodex lookup-obj-key (dir elephant-director) ((id key)) + ;; (defmethod lookup-obj-key ((dir elephant-director) (id key)) (with-slots (dcm-btree) dir (get-value id dcm-btree))) -(defmethod delete-obj ((dir elephant-director) (id key)) +(defmethodex delete-obj (dir elephant-director) ((id key)) + ;; (defmethod delete-obj ((dir elephant-director) (id key)) (with-slots (dcm-btree) dir (remove-kv id dcm-btree))) @@ -449,11 +521,11 @@ ((hed :initform (make-instance 'hash-ele-director) :accessor :hed))) -(defmethod load-all ((dir hash-ele-director)) - (let ((obs (get-all-objects (:ed dir)))) - (mapc #'(lambda (x) (register-obj (:hd dir) x)) - obs) - )) +(defmethodex load-all (dir hash-ele-director) () + (let ((obs (get-all-objects (:ed dir)))) + (mapc #'(lambda (x) (register-obj (:hd dir) x)) + obs) + )) (defmethod register-obj ((dir hash-ele-director) (mo managed-object)) (register-obj (:ed dir) mo) @@ -465,8 +537,8 @@ (get-unused-key-value (:ed dir)))) -(defmethod lookup-obj ((dir hash-ele-director) (id key)) - (lookup-obj (:hd dir) id)) +(defmethod lookup-obj-key ((dir hash-ele-director) (id key)) + (lookup-obj-key (:hd dir) id)) (defmethod delete-obj ((dir hash-ele-director) (id key)) (delete-obj (:hd dir) id) @@ -487,7 +559,7 @@ (defparameter *DIR-STRATEGIES* '(hash hash-ele elephant simple)) -o ;; I might have to rehabilitate this function... +;; I might have to rehabilitate this function... (defun directory-factory (strategy btreeclassname type repos) (case strategy (hash (init-director 'hash-director btreeclassname :managed-type type)) @@ -538,7 +610,7 @@ (let ((mo (make-instance 'managed-object))) (register-obj dir mo) (assert (key-equal (mid mo) - (mid (lookup-obj dir (mid mo)))))))) + (mid (lookup-obj-key dir (mid mo)))))))) dirs)) ) @@ -580,7 +652,7 @@ (time (and (mapcar #'(lambda (k) - (not (lookup-obj dir (make-instance 'key :id k)))) + (not (lookup-obj-key dir (make-instance 'key :id k)))) key-values))))) ) dirs)) @@ -624,7 +696,7 @@ (time (and (mapcar #'(lambda (k) - (not (lookup-obj dir (make-instance 'key :id k)))) + (not (lookup-obj-key dir (make-instance 'key :id k)))) key-values))))) )))) dirs)) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2007/02/20 15:54:21 1.2 @@ -1,35 +1,20 @@ -;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- -;;; -;;; gdcm.lisp -- This file implements generational data collection management -;;; based on the basic data collection management functionality. -;;; The basic idea is that every object in the collection exists -;;; within a generation. Each generation can have a different storage -;;; strategy --- in general, the lower the generation number, the -;;; faster and smaller the storage strategy. -;;; Increasing the generation is a fundamental operation. - -;;; One fundamental feature of a GenDir is that the -;;; objects managed retain their identities across these issue. - -;;; A GenDir is a kind of director, but it offers generational -;;; aware operations that it's superclass does not. - -;;; Given an object with it's id, how do you efficiently find -;;; its generation? --- you always have an index, so in theory -;;; it can't take that long to find what generation it's in. - -;;; Initial version by Robert L. Read -;;; -;;; part of -;;; -;;; Elephant: an object-oriented database for Common Lisp -;;; -;;; -;;; Elephant users are granted the rights to distribute and use this software -;;; as governed by the terms of the Lisp Lesser GNU Public License -;;; (http://opensource.franz.com/preamble.html), also known as the LLGPL. -;;; -;;; Copyright (c) 2005 Robert L. Read <read at robertlread.net> +;; gdcm.lisp -- This file implements generational data collection management +;; based on the basic data collection management functionality. +;; The basic idea is that every object in the collection exists +;; within a generation. Each generation can have a different storage +;; strategy --- in general, the lower the generation number, the +;; faster and smaller the storage strategy. +;; Increasing the generation is a fundamental operation. + +;; One fundamental feature of a GenDir is that the +;; objects managed retain their identities across these issue. + +;; A GenDir is a kind of director, but it offers generational +;; aware operations that it's superclass does not. + +;; Given an object with it's id, how do you efficiently find +;; its generation? --- you always have an index, so in theory +;; it can't take that long to find what generation it's in. (in-package "DCM") @@ -40,7 +25,7 @@ (defclass GenDir (director) ((strategy - :initform '((0 . hash-ele)) ;; This means that 0 and anything less is hash-ele + :initform '((0 . hash-ele) (1 . elephant)) ;; This means that 0 and anything less is hash-ele :accessor strategy) (final-strategy :initform 'elephant :accessor final-strategy) @@ -58,6 +43,11 @@ "Increment the generation number of a object, making number is properly stored there.") ) +(defgeneric promote (GenDir key) + (:documentation + "Decrement the generation number of a object, making number is properly stored there.") +) + (defgeneric find-generation (GenDir key) ) @@ -77,6 +67,20 @@ ) ) +(defmethod promote ((gdcm GenDir) (mid key)) + (multiple-value-bind (obj gen) + (lookup-obj-aux gdcm mid) + (unless (= gen 0) + (let ((ndir (nth (- gen 1) (subdirs gdcm))) + (odir (nth gen (subdirs gdcm))) + ) + (register-obj ndir obj) + (delete-obj odir mid) + ) + ) + ) + ) + (defmethod load-all ((dir GenDir)) (do ((i 0 (1+ i)) (dirs (subdirs dir) (rest dirs))) @@ -124,7 +128,7 @@ (delete-obj (nth gen (subdirs dir)) id)) ) ) -(defmethod lookup-obj ((dir GenDir) (mid key)) +(defmethod lookup-obj-key ((dir GenDir) (mid key)) (multiple-value-bind (obj gen) (lookup-obj-aux dir mid) obj)

1 0

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

20 Feb '07

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv1677 Modified Files: testbdb.lisp Log Message: Fix idempotence problem in prepares-bdb --- /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/03 00:57:35 1.4 +++ /project/elephant/cvsroot/elephant/tests/testbdb.lisp 2007/02/20 15:48:14 1.5 @@ -18,6 +18,11 @@ (defvar db) (defun prepare-bdb () + (ignore-errors + (delete-file (make-pathname :defaults (cdr *bdb-spec*) + :name "testsbdb")) + (delete-file (make-pathname :defaults (cdr *bdb-spec*) + :name "log.0000000001"))) (setq env (db-bdb::db-env-create)) (db-bdb::db-env-open env (cdr *bdb-spec*) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread t

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by ieslick 20 Feb '07

20 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv7106a/db-clsql Modified Files: sql-transaction.lisp Log Message: Enable with-transaction to return multiple values in both backends --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2007/02/02 23:51:58 1.4 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-transaction.lisp 2007/02/20 02:33:59 1.5 @@ -31,10 +31,17 @@ (funcall txn-fn) (progn (clsql::set-autocommit nil) - (unwind-protect - (clsql::with-transaction (:database (controller-db sc)) - (funcall txn-fn)) - (clsql::set-autocommit t))))) + (let ((db (controller-db sc))) + (unwind-protect + (multiple-value-prog1 + (progn + (clsql-sys::database-start-transaction db) + (funcall txn-fn)) + (clsql-sys::mark-transaction-committed db)) + (if (eq (clsql-sys::transaction-status (clsql-sys::transaction db)) :committed) + (clsql-sys::database-commit-transaction db) + (clsql-sys::database-abort-transaction db)) + (clsql::set-autocommit t)))))) (defmethod controller-start-transaction ((sc sql-store-controller) &key &allow-other-keys) (clsql:start-transaction :database (controller-db sc))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 20 Feb '07

20 Feb '07

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv7106a/db-bdb Modified Files: bdb-transactions.lisp Log Message: Enable with-transaction to return multiple values in both backends --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/16 23:02:51 1.8 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-transactions.lisp 2007/02/20 02:33:59 1.9 @@ -45,7 +45,7 @@ (declare (special *current-transaction* *store-controller*)) (catch 'transaction (unwind-protect - (prog1 + (multiple-value-prog1 (funcall txn-fn) (db-transaction-commit txn :txn-nosync txn-nosync :txn-sync txn-sync)

1 0

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

18 Feb '07

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv9012 Modified Files: classes.lisp classindex-utils.lisp classindex.lisp Log Message: Fix reconnect to derived index bug under :class synchronization policy --- /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/14 04:36:10 1.13 +++ /project/elephant/cvsroot/elephant/src/elephant/classes.lisp 2007/02/18 23:38:18 1.14 @@ -130,14 +130,14 @@ (let* ((class (find-class (class-name (class-of instance)))) (oid (oid instance)) (persistent-slot-names (persistent-slot-names class))) - (flet ((persistent-slot-p (item) + (flet ((persistent-slot-p (item) (member item persistent-slot-names :test #'eq))) (let ((transient-slot-inits (if (eq slot-names t) ; t means all slots (transient-slot-names class) (remove-if #'persistent-slot-p slot-names))) (persistent-slot-inits - (if (eq slot-names t) + (if (eq slot-names t) persistent-slot-names (remove-if-not #'persistent-slot-p slot-names)))) (inhibit-indexing oid) --- /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/02 23:51:58 1.4 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex-utils.lisp 2007/02/18 23:38:18 1.5 @@ -12,6 +12,8 @@ (in-package :elephant) +(declaim #-elephant-without-optimize (optimize (speed 3) (safety 1))) + ;; ;; Simple utilities for managing synchronization between class ;; definitions and database state @@ -226,7 +228,6 @@ (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) @@ -252,7 +253,6 @@ (warn (warn "Performing slot synchronization actions: ~A" (synch-rule-rhs rule)))))) (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 @@ -267,8 +267,7 @@ (let* ((*store-controller* store-controller) ;; db info (db-indices (find-inverted-index-names class)) - (db-derived (mapcar #'get-derived-name-root - (remove-if-not #'derived-name? db-indices))) + (db-derived (remove-if-not #'derived-name? db-indices)) (db-slot (set-difference db-indices db-derived)) ;; class info (marked-slots (indexing-record-slots (indexed-record class))) --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/14 04:36:10 1.17 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2007/02/18 23:38:18 1.18 @@ -266,7 +266,8 @@ (defmethod remove-class-slot-index ((class symbol) slot-name &key (sc *store-controller*)) (remove-class-slot-index (find-class class) slot-name :sc sc)) -(defmethod remove-class-slot-index ((class persistent-metaclass) slot-name &key (sc *store-controller*) (update-class t)) +(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) @@ -282,7 +283,8 @@ (defmethod add-class-derived-index ((class symbol) name derived-defun &key (sc *store-controller*) (populate t)) (add-class-derived-index (find-class class) name derived-defun :sc sc :populate populate)) -(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key (populate t) (sc *store-controller*) (update-class t)) +(defmethod add-class-derived-index ((class persistent-metaclass) name derived-defun &key + (populate t) (sc *store-controller*) (update-class t)) (let ((class-idx (find-class-index class :sc sc))) (if (find-inverted-index class (make-derived-name name) :null-on-fail t) (error "Duplicate derived index requested named ~A on class ~A" name (class-name class)) @@ -297,7 +299,8 @@ (defmethod remove-class-derived-index ((class symbol) name &key (sc *store-controller*)) (remove-class-derived-index (find-class class) name :sc sc)) -(defmethod remove-class-derived-index ((class persistent-metaclass) name &key (sc *store-controller*) (update-class t)) +(defmethod remove-class-derived-index ((class persistent-metaclass) name &key + (sc *store-controller*) (update-class t)) (if (find-inverted-index class name :null-on-fail t) (progn (when update-class (unregister-derived-index class name))

1 0

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

18 Feb '07

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv392 Modified Files: elephant.asd Log Message: Fixed typo (again:) that Henrik pointed out --- /project/elephant/cvsroot/elephant/elephant.asd 2007/02/16 03:43:47 1.30 +++ /project/elephant/cvsroot/elephant/elephant.asd 2007/02/18 22:45:39 1.31 @@ -110,7 +110,7 @@ #-(or darwin macosx darwin-host) "-shared" #+(or darwin macosx darwin-host) "-bundle" #+(and X86-64 (or macosx darwin darwin-host)) "-arch x86_64" - #+(and X86-64 linux) "-march x86-64" + #+(and X86-64 linux) "-march=x86-64" "-Wall" "-fPIC" "-O3"

1 0

← Newer
1
...
22
23
24
25
26
27
28
...
86
Older →

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

elephant-cvs