April 2006 - elephant-cvs@common-lisp.net

[elephant-cvs] CVS elephant
by ieslick 30 Apr '06

30 Apr '06

Update of /project/elephant/cvsroot/elephant In directory clnet:/tmp/cvs-serv29682 Modified Files: config.lisp ele-bdb.asd Log Message: FEATURE: Allow linux users to configure pthreads location in config.lisp (NEEDS TESTING!) --- /project/elephant/cvsroot/elephant/config.lisp 2006/02/22 21:03:47 1.2 +++ /project/elephant/cvsroot/elephant/config.lisp 2006/04/30 01:03:48 1.3 @@ -1,3 +1,14 @@ +;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- +;;; +;;; config.lisp -- Site specific library references for Elephant +;;; +;;; Initial version 8/26/2004 by Ian Eslick +;;; <ieslick(a)common-lisp.net> +;;; +;;; part of +;;; +;;; Elephant: an object-oriented database for Common Lisp +;;; (in-package :elephant) @@ -5,12 +16,14 @@ ;; Make sure the libraries that CLSQL needs for a particular system ;; are pointed to by these libraries. ;; These values will be irrelevant if you don't use a CLSQL-based backend. + (defparameter *clsql-foreign-lib-path* #p"/usr/local/share/common-lisp/elephant/") ;; BerkeleyDB ;; Make sure the libraries that CLSQL needs for a particular system ;; are pointed to by these libraries. + (defparameter *sleepycat-foreign-library-path* ;; Sleepycat: this works on linux #+linux @@ -24,3 +37,8 @@ ;; "/sw/lib/libdb-4.3.dylib" ;; a possible manual install "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib") + +(defparameter *sleepycat-pthreads-path* + #-linux nil ;; don't open on non-linux environments + #+linux "/lib/tls/libpthread.so.0" ;; most linux distros + ) \ No newline at end of file --- /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/02/19 20:06:03 1.8 +++ /project/elephant/cvsroot/elephant/ele-bdb.asd 2006/04/30 01:03:48 1.9 @@ -28,28 +28,6 @@ (unless (find-package 'uffi) (asdf:operate 'asdf:load-op 'uffi))) -;; -;; EDIT ME FOR YOUR SYSTEM -;; -;; An attempt at good defaults is here. We should -;; later add a search function that users can add to -;; so they don't have to edit source -;; - -(defparameter *sleepycat-foreign-library-path* - ;; Sleepycat: this works on linux - #+linux -;; "/db/ben/lisp/db43/lib/libdb.so" - "/usr/local/BerkeleyDB.4.3/lib/libdb-4.3.so" - ;; this works on FreeBSD - #+(and (or bsd freebsd) (not (or darwin macosx))) - "/usr/local/lib/db43/libdb.so" - #+(or darwin macosx) - ;; for Fink (OS X) -- but I will assume Linux more common... -;; "/sw/lib/libdb-4.3.dylib" - ;; a possible manual install - "/usr/local/BerkeleyDB.4.3/lib/libdb.dylib") - (defclass bdb-c-source (c-source-file) ())

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 30 Apr '06

30 Apr '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv29682/src/db-bdb Modified Files: sleepycat.lisp Log Message: FEATURE: Allow linux users to configure pthreads location in config.lisp (NEEDS TESTING!) --- /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/04/26 17:53:44 1.4 +++ /project/elephant/cvsroot/elephant/src/db-bdb/sleepycat.lisp 2006/04/30 01:03:49 1.5 @@ -57,7 +57,9 @@ #+linux (unless - (uffi:load-foreign-library "/lib/tls/libpthread.so.0" :module "pthread") + (uffi:load-foreign-library + elephant::*sleepycat-pthreads-path* + :module "pthread") (error "Couldn't load libpthread!")) ;; @@ -66,7 +68,7 @@ (unless (uffi:load-foreign-library - ele-bdb-system::*sleepycat-foreign-library-path* + elephant::*sleepycat-foreign-library-path* :module "sleepycat") (error "Couldn't load libdb (Sleepycat)!"))

1 0

[elephant-cvs] CVS elephant/src/db-bdb
by ieslick 30 Apr '06

30 Apr '06

Update of /project/elephant/cvsroot/elephant/src/db-bdb In directory clnet:/tmp/cvs-serv29635 Modified Files: bdb-controller.lisp Log Message: BUGFIX: specs with pathnames instead of strings fail in open-store --- /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/04/26 17:53:44 1.7 +++ /project/elephant/cvsroot/elephant/src/db-bdb/bdb-controller.lisp 2006/04/30 01:02:22 1.8 @@ -59,7 +59,7 @@ (let ((env (db-env-create))) ;; thread stuff? (setf (controller-environment sc) env) - (db-env-open env (second (controller-spec sc)) + (db-env-open env (namestring (second (controller-spec sc))) :create t :init-txn t :init-lock t :init-mpool t :init-log t :thread thread :recover recover :recover-fatal recover-fatal)

1 0

[elephant-cvs] CVS elephant/src/elephant
by ieslick 30 Apr '06

30 Apr '06

Update of /project/elephant/cvsroot/elephant/src/elephant In directory clnet:/tmp/cvs-serv28175 Modified Files: classindex.lisp Log Message: BUGFIX: Allow enable-class-indexing to connect to existing database index when class definition is out of synch with actual db indexing. --- /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/26 21:41:24 1.11 +++ /project/elephant/cvsroot/elephant/src/elephant/classindex.lisp 2006/04/30 01:01:05 1.12 @@ -182,22 +182,30 @@ (let ((croot (controller-class-root sc))) (multiple-value-bind (btree found) (get-value (class-name class) croot) - (declare (ignore btree)) - (when found (error "Class is already enabled for indexing! Run disable class indexing to clean up."))) - ;; Put class instance index into the class root & cache it in the class object - (update-indexed-record class indexed-slot-names :class-indexed t) - (with-transaction (:store-controller sc) - (let ((class-idx (build-indexed-btree sc))) - (setf (get-value (class-name class) croot) class-idx) - (setf (%index-cache class) class-idx) + (when found + (if (indexed class) + (error "Class is already enabled for indexing! Run disable class indexing to clean up.") + (progn + (let ((slots nil)) + (map-indices (lambda (k v) (declare (ignore v)) (push k slots)) btree) + (warn "Class has pre-existing database index, enabling indexing for slots: ~A" + (setf indexed-slot-names (union slots indexed-slot-names))))))) + ;; Put class instance index into the class root & cache it in the class object + (update-indexed-record class indexed-slot-names :class-indexed t) + (with-transaction (:store-controller sc) + (when (not found) + (let ((class-idx (build-indexed-btree sc))) + (setf (get-value (class-name class) croot) class-idx) + (setf (%index-cache class) class-idx))) ;; Add all the indexes (loop for slot in indexed-slot-names do - (add-class-slot-index class slot :populate nil :sc sc)) + (unless (find-inverted-index class slot :null-on-fail t) + (add-class-slot-index class slot :populate nil :sc sc)))) ;; Sanity check - (let ((record (indexed-record class))) - (declare (ignorable record)) - (assert (indexed class))) - class-idx)))) + (let ((record (indexed-record class))) + (declare (ignorable record)) + (assert (indexed class))) + (find-class-index class :sc sc :errorp t)))) (defmethod disable-class-indexing ((class-name symbol) &key (errorp t) (sc *store-controller*)) (let ((class (find-class class-name errorp)))

1 0

[elephant-cvs] CVS elephant/src/contrib/rread/dcm
by rread 27 Apr '06

27 Apr '06

Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm In directory clnet:/tmp/cvs-serv16667 Modified Files: dcm.asd Log Message: Fixing the license line in the asd --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 02:00:02 1.1 +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 15:27:36 1.2 @@ -20,7 +20,7 @@ :author "Robert L. Read <read(a)robertlread.net>" :version "0.1" :maintainer "Robert L. Read <read(a)robertlread.net" - :licence "All Rights Reserverd" + :licence "LLGPL; part of Elephant" :description "A simple object prevalence system with strategies" :long-description "An object prevalence system with strategies built on Elephant" :depends-on (:elephant)

1 0

[elephant-cvs] CVS elephant/src/contrib/rread/dcm
by rread 27 Apr '06

27 Apr '06

Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm In directory clnet:/tmp/cvs-serv9657/rread/dcm Added Files: dcm-macros.lisp dcm-package.lisp dcm-tests.lisp dcm.asd dcm.lisp gdcm.lisp Log Message: Adding "Data Collection Management". --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-macros.lisp 2006/04/27 02:00:02 1.1 ;;; -*- 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") (defmacro init-director (cls dirclass &rest x) `(let ((dir (make-instance ,cls ,@x))) (initialize dir ,cls ,dirclass) (setf (gethash ,cls *director-class-map*) dir) (load-all dir) dir)) (defmacro init-director-noload (cls dirclass &rest x) `(let ((dir (make-instance ,cls ,@x))) (initialize dir ,cls ,dirclass) (setf (gethash ,cls *director-class-map*) dir) ;; (load-all dir) dir)) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-package.lisp 2006/04/27 02:00:02 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; dcm-package.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> (defpackage dcm (:documentation "DCM is a very simple in-memory object prevalence system.") (:nicknames dcm :dcm) ;; (:use common-lisp elephant ele-clsql) (:use common-lisp elephant) (:export ;; These parameters are used to tell DCM how to connect ;; to repositories #:*SLEEPYCAT-HOME* #:*POSTGRES-SPEC* #:*DCM-DEFAULT* #:*ELEPHANT-CAT* #:*DEF-STORE-NAME* #:key #:key-equal #:dcm-equal #:max-key-value #:max-key #:managed-object #:mid #:k #:owner #:ownr #:tstamp #:dcm-tstmp #:mo-equal #:get-values #:randomize-slot-value #:get-user-defined-slots #:randomize-managed-object #:ExObject #:managed-handle #:test-randomize-managed-object #:max-key-value #:*DIR-CAT* #:director #:load-all #:delete-all-objects-from-director #:*HASH-CAT* #:hash-director #:get-all-objects #:get-all-objects-type #:get-all-objects-owned-by #:get-unused-key-value #:hash-values-reduce #:hash-keys-reduce #:register-obj #:lookup-obj #:delete-obj #:hash-dir-test #:*ELEPHANT-CAT* #:*basic-store-controller* #:init-elephant-controllers #:release-elephant-controllers #:elephant-director #:initialize-btree #:initialize #:register-many-random #:elephant-dir-test #:hash-ele-director #:hash-ele-dir-test #:*DIR-STRATEGIES* #:directory-factory #:init-director #:dir-test #:test-get-unused-key-value #:unused-key #:tm-register-then-lookup #:tm-get-all-objects #:tm-test-elephant #:run-all-dcm-tests #:test-ex-director #:get-director-by-class #:get-all-cur-objects #:get-all-objects-gen #:retire #:find-generation #:GenDir ) ) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm-tests.lisp 2006/04/27 02:00:02 1.1 ;;; -*- 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 ExObjectDirector (hash-ele-director) ((mtype :initform 'ExObject :accessor :mtype))) (defun test-ex-director () (let ((k1 nil) (k2 nil)) (let* ((o1 (make-instance 'ExObject)) (ed (init-director 'ExObjectDirector 'ExObjectDirector)) (o2 (make-instance 'ExObject))) (setf (slot-value o1 'username) "spud") (setf (slot-value o2 'username) "mud") (setf k1 (k (mid (register-obj ed o1)))) (setf k2 (k (mid (register-obj ed o2)))) ) (let* ( (ed (init-director 'ExObjectDirector 'ExObjectDirector))) (format t "K1 ~A~%" (slot-value (lookup-obj ed (make-instance 'key :id k1)) 'username)) (format t "K2 ~A~%" (slot-value (lookup-obj ed (make-instance 'key :id k2)) 'username)) (and (equal (slot-value (lookup-obj ed (make-instance 'key :id k1)) 'username) "spud") (equal (slot-value (lookup-obj ed (make-instance 'key :id k2)) 'username) "mud") )))) ;; Create 10 objects, retire them, and make sure that they can ;; still be found. (defclass TestGenDir (GenDir) ((mtype :initform 'ExObject)) ) (defun test-retirement () (let ((g (init-director 'TestGenDir 'TestGenDir)) (r (randomize-managed-object (make-instance 'ExObject)))) (setf (slot-value r 'number) 0) (setf (slot-value r 'username) "username") (setf (slot-value r 'password) "password") (register-obj g r) (assert (= 0 (find-generation g (mid r)))) (retire g (mid r)) (assert (= 1 (find-generation g (mid r)))) ) ) (defun test-deletion-from-gen () (let ((g (init-director 'TestGenDir 'TestGenDir)) (r (randomize-managed-object (make-instance 'ExObject)))) (setf (slot-value r 'number) 0) (setf (slot-value r 'username) "username") (setf (slot-value r 'password) "password") (register-obj g r) (retire g (mid r)) (let ((id (mid r))) (assert (= 1 (find-generation g (mid r)))) (delete-all-objects-from-director g 'ExObject) (lookup-obj-aux g id) (let ((gp (init-director 'TestGenDir 'TestGenDir))) (assert (null (get-all-objects gp))) ) ) )) (defun test-naming-uniqueness () (let ((g (init-director 'TestGenDir 'TestGenDir)) (r (randomize-managed-object (make-instance 'ExObject))) (s 0)) (setf (slot-value r 'number) 0) (setf (slot-value r 'username) "username") (setf (slot-value r 'password) "password") (register-obj g r) (do ((i 0 (1+ i)) (dirs (subdirs g) (rest dirs))) ((null dirs)) (setf s (+ s (length (get-all-objects (car dirs)))))) (assert (= s 1)))) ;; This command should test everything so far.... (defun run-all-dcm-tests () (let ((dt (make-instance 'dir-test))) (unused-key dt) (tm-register-then-lookup dt) (tm-get-all-objects dt) (tm-test-elephant dt) )) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.asd 2006/04/27 02:00:02 1.1 ;;; -*- Mode: Lisp; Syntax: ANSI-Common-Lisp; Base: 10 -*- ;;; ;;; 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> (defsystem dcm :name "dcm" :author "Robert L. Read <read(a)robertlread.net>" :version "0.1" :maintainer "Robert L. Read <read(a)robertlread.net" :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) :components ((:file "dcm-package") (:file "dcm-macros") (:file "dcm" :depends-on ("dcm-package" "dcm-macros")) (:file "gdcm" :depends-on ("dcm" "dcm-macros")) (:file "dcm-tests" :depends-on ("dcm" "gdcm" "dcm-macros")) ) :serial t ) --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/dcm.lisp 2006/04/27 02:00:02 1.1 ;;; -*- 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") (defparameter *SLEEPYCAT-HOME* "/home/read/testdb") (defparameter *POSTGRES-SPEC* '(:clsql (:postgresql "localhost.localdomain" "test" "postgres" ""))) (defparameter *DCM-DEFAULT* *POSTGRES-SPEC*) (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) (defclass key () ((id :type 'integer :initform -1 :initarg :id :accessor k))) (defmethod max-key-value ((a key) (b key)) (max (k a) (k b))) (defmethod max-key ((a key) (b key)) (if (< (k a) (k b)) b a)) ;; I think perhas we could use a better type specifier for this ;; than integer. (defclass managed-object () ((mid :type 'key :initform nil :initarg :mid :accessor mid) (owner :type 'key ;; This is basically saying that the key 0 had better specify a legitimate ;; owner --- but that is the responsibility of the clients of this package. :initform (make-instance 'key :id 0) :initarg :owner :accessor :ownr) (tstamp :type 'number ;; This is basically saying that the key 0 had better specify a legitimate ;; owner --- but that is the responsibility of the clients of this package. :initform (get-universal-time) :initarg :tstamp :accessor :dcm-tstmp) ) ) (defmethod mo-equal ((a managed-object) (b managed-object)) (equal (get-values a) (get-values b))) (defmethod key-equal ((a key) (b key)) (= (k a) (k b))) (defmethod dcm-equal (a b) (let ((ka (if (typep a 'managed-object) (k (mid a)) (if (typep a 'key) (k a) a))) (kb (if (typep b 'managed-object) (k (mid b)) (if (typep b 'key) (k b) b)))) (and ka kb (= ka kb)) ) ) (defmethod get-values ((a managed-object)) (mapcar #'(lambda (x) (let* ((name (sb-pcl:slot-definition-name x)) (value (if (slot-boundp a name) (slot-value a name) nil))) (cons name value))) (sb-mop:class-slots (class-of a)))) ;; This will make red tests for now... (defun randomize-slot-value (s mo) (let ((ltype (sb-pcl:slot-definition-type s)) (name (sb-pcl:slot-definition-name s))) (let ((crazy (cadr ltype))) (let ((v (cond [548 lines skipped] --- /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 NONE +++ /project/elephant/cvsroot/elephant/src/contrib/rread/dcm/gdcm.lisp 2006/04/27 02:00:02 1.1 [751 lines skipped]

1 0

[elephant-cvs] CVS elephant/src/contrib/rread/dcm
by rread 27 Apr '06

27 Apr '06

Update of /project/elephant/cvsroot/elephant/src/contrib/rread/dcm In directory clnet:/tmp/cvs-serv9618/rread/dcm Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/rread/dcm added to the repository

1 0

[elephant-cvs] CVS elephant/src/contrib/rread
by rread 27 Apr '06

27 Apr '06

Update of /project/elephant/cvsroot/elephant/src/contrib/rread In directory clnet:/tmp/cvs-serv9572/rread Log Message: Directory /project/elephant/cvsroot/elephant/src/contrib/rread added to the repository

1 0

[elephant-cvs] CVS elephant/src/db-clsql
by rread 27 Apr '06

27 Apr '06

Update of /project/elephant/cvsroot/elephant/src/db-clsql In directory clnet:/tmp/cvs-serv6814/src/db-clsql Modified Files: sql-controller.lisp Log Message: Just a bagatelle --- /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/03/27 20:36:27 1.10 +++ /project/elephant/cvsroot/elephant/src/db-clsql/sql-controller.lisp 2006/04/27 01:34:49 1.11 @@ -325,6 +325,10 @@ ) ) +(defmethod reconnect-controller ((sc sql-store-controller)) + (setf (controller-db sc) + (clsql:reconnect :database (controller-db sc))) +) (defmethod close-controller ((sc sql-store-controller)) (when (slot-value sc 'db) ;; close the connection

1 0

[elephant-cvs] CVS elephant/tests
by ieslick 26 Apr '06

26 Apr '06

Update of /project/elephant/cvsroot/elephant/tests In directory clnet:/tmp/cvs-serv9359/tests Modified Files: testindexing.lisp Log Message: Corrections for SBCL serialization and index testing. --- /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/04/26 17:53:45 1.16 +++ /project/elephant/cvsroot/elephant/tests/testindexing.lisp 2006/04/26 21:41:25 1.17 @@ -371,22 +371,23 @@ (defvar normal-index nil) -(defclass stress-normal () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) - (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil)) - (:metaclass persistent-metaclass)) +(defun make-stress-classes () + (defclass stress-normal () + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index nil) + (stress2 :accessor stress2 :initarg :stress2 :initform nil :index nil)) + (:metaclass persistent-metaclass)) + + (defclass stress-index () + ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t) + (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t) + (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) + (:metaclass persistent-metaclass))) (defun normal-stress-setup (count class-name &rest inst-args) (setf normal-index (make-btree)) (dotimes (i count) (setf (get-value i normal-index) (apply #'make-instance class-name :stress1 i inst-args)))) -(defclass stress-index () - ((stress1 :accessor stress1 :initarg :stress1 :initform nil :index t) - (stress2 :accessor stress2 :initarg :stress2 :initform 2 :index t) - (stress3 :accessor stress3 :initarg :stress3 :initform 3 :index nil)) - (:metaclass persistent-metaclass)) - (defun indexed-stress-setup (count class-name &rest inst-args) (dotimes (i count) (apply #'make-instance class-name :stress1 i inst-args))) @@ -421,43 +422,42 @@ (deftest indexing-timing (progn + (make-stress-classes) (let ((insts (get-instances-by-class 'stress-index)) (start nil) (end nil) (normal-time 0) (index-time 0)) (when insts - (drop-instances insts))) + (drop-instances insts :sc *store-controller*)) ;; (format t "~%Stress test normal setup time (~A):~%" *stress-count*) - (with-transaction () - (normal-stress-setup *stress-count* 'stress-normal :stress2 10) - ) + (with-transaction () + (normal-stress-setup *stress-count* 'stress-normal :stress2 10)) ;; (format t "~%Stress test indexed setup time (~A):~%" *stress-count*) - (with-transaction () - (indexed-stress-setup *stress-count* 'stress-index :stress2 10) - ) + (with-transaction () + (indexed-stress-setup *stress-count* 'stress-index :stress2 10)) ;; (format t "~%Stress test normal lookup time (~A):~%" *range-size*) - (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (normal-range-lookup *stress-count* *range-size*)) - (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)) + (normal-range-lookup *stress-count* *range-size*)) + (setf end (get-internal-run-time)) + (setf normal-time (/ (- end start 0.0) internal-time-units-per-second)) ;; (format t "~%Stress test indexed lookup time (~A):~%" *range-size*) - (setf start (get-internal-run-time)) - (dotimes (i *range-size*) - (declare (ignore i)) - (indexed-range-lookup 'stress-index *stress-count* *range-size*)) - (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~%" - *range-size* *stress-count* normal-time index-time) - (> normal-time index-time)) + (setf start (get-internal-run-time)) + (dotimes (i *range-size*) + (declare (ignore i)) + (indexed-range-lookup 'stress-index *stress-count* *range-size*)) + (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~%" + *range-size* *stress-count* normal-time index-time) + (> normal-time index-time))) t)

1 0