[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Thu May 25 13:01:38 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv5833/rucksack
Modified Files:
make.lisp p-btrees.lisp test.lisp
Log Message:
Move tests from obsolete test files to test.lisp and adapt them to the
current Rucksack version. Start testing btrees: the basics work, but
with large btrees (20,000 nodes or more?) I get GC errors again. It
seems that blocks are deallocated that shouldn be, so my guess is that
these are due to a mismatch between the liveness of objects that are
on disk and their corresponding in-memory versions.
--- /project/rucksack/cvsroot/rucksack/make.lisp 2006/05/16 22:01:27 1.2
+++ /project/rucksack/cvsroot/rucksack/make.lisp 2006/05/25 13:01:38 1.3
@@ -1,4 +1,4 @@
-;; $Id: make.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $
+;; $Id: make.lisp,v 1.3 2006/05/25 13:01:38 alemmens Exp $
(in-package :cl-user)
@@ -23,9 +23,6 @@
"index"
"rucksack"
"transactions"
- ;; Tests
- #+old "test-cache"
- #+old "test-cached-btrees"
"test")
do (tagbody
:retry
--- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/05/18 12:46:57 1.3
+++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/05/25 13:01:38 1.4
@@ -1,4 +1,4 @@
-;; $Id: p-btrees.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $
+;; $Id: p-btrees.lisp,v 1.4 2006/05/25 13:01:38 alemmens Exp $
(in-package :rucksack)
@@ -73,7 +73,7 @@
;;; Classes
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-(defclass btree (persistent-object)
+(defclass btree ()
((key< :initarg :key< :reader btree-key< :initform '<)
(key= :initarg :key= :reader btree-key= :initform 'eql)
(value= :initarg :value= :reader btree-value= :initform 'p-eql
@@ -100,9 +100,7 @@
:initform t
:documentation "The type of all values.")
(root :accessor btree-root))
- #+lispworks
- ;; We need to specify this for each subclass of persistent-object.
- (:optimize-slot-access nil))
+ (:metaclass persistent-class))
(defmethod initialize-instance :around ((btree btree)
@@ -127,7 +125,7 @@
;; with fancy long names.
;;
-(defclass btree-node (persistent-object)
+(defclass btree-node ()
((index :initarg :index
:initform '()
:accessor btree-node-index
@@ -140,8 +138,7 @@
:accessor btree-node-index-count
:documentation "The number of key/value pairs in the index vector.")
(leaf-p :initarg :leaf-p :initform nil :reader btree-node-leaf-p))
- #+lispworks
- (:optimize-slot-access nil))
+ (:metaclass persistent-class))
;;
;; Bindings
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/05/20 10:33:50 1.3
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/05/25 13:01:38 1.4
@@ -1,32 +1,53 @@
-;; $Id: test.lisp,v 1.3 2006/05/20 10:33:50 alemmens Exp $
+;; $Id: test.lisp,v 1.4 2006/05/25 13:01:38 alemmens Exp $
(in-package :test-rucksack)
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; A few quick tests to make sure the basics work.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
(defparameter *test-suite* #p"/tmp/rucksack-test-suite/")
-;;;; A few quick tests to make sure basics work
-(macrolet ((p-test (form test)
- `(let (item)
- (with-rucksack (in *test-suite* :if-exists :supersede)
- (with-transaction ()
- (add-rucksack-root (setq item ,form) in)))
- (with-rucksack (out *test-suite* :if-exists :overwrite)
- (with-transaction ()
- (let ((all (rucksack-roots out)))
- (assert (= 1 (length all)))
- (let ((it (car all)))
- (assert ,test)))))))
- (test (form)
- `(assert ,form)))
+(defmacro p-test (form test)
+ `(progn
+ (with-rucksack (in *test-suite* :if-exists :supersede)
+ (with-transaction ()
+ (add-rucksack-root ,form in)))
+ (with-rucksack (out *test-suite* :if-exists :overwrite)
+ (with-transaction ()
+ (let ((all (rucksack-roots out)))
+ (assert (= 1 (length all)))
+ (let ((it (car all)))
+ (assert ,test)))))))
+
+(defmacro test (form)
+ `(assert ,form))
+
+(defclass p-thing-1 ()
+ ()
+ (:metaclass persistent-class))
+
+(defclass p-thing-2 ()
+ ((x :initarg :x :reader x-of :persistence t))
+ (:metaclass persistent-class))
+(defun test-basics ()
+ ;;
+ ;; Serializing/deserializing pathnames.
+ ;;
+
(let ((store (merge-pathnames *test-suite* "store")))
(rucksack::save-objects (list store) store)
(test (equal (list store) (rucksack::load-objects store))))
(test (not (current-rucksack)))
+ ;;
+ ;; P-CONS, P-CAR, P-CDR, P-LIST, P-MAKE-ARRAY, P-AREF
+ ;;
+
(p-test (p-cons 1 2)
- (and (= 1 (p-car it)) (= 2 (p-cdr it))))
+ (and (= 1 (p-car it)) (= 2 (p-cdr it))))
(test (not (current-rucksack))) ; WITH-RUCKSACK should not leave one around
@@ -38,22 +59,42 @@
(equal '(a b)
(list (p-aref it 0) (p-aref it 1))))
- (defclass p-thing-1 () ()
- (:metaclass persistent-class))
+ ;;
+ ;; Persistent-objects
+ ;;
(p-test (make-instance 'p-thing-1)
(eq (find-class 'p-thing-1) (class-of it)))
- (defclass p-thing-2 ()
- ((x :initarg :x :reader x-of :persistence t))
- (:metaclass persistent-class))
-
(p-test (make-instance 'p-thing-2 :x "-x-")
- (equal (x-of it) "-x-"))'
+ (equal (x-of it) "-x-"))
+
+ ;;
+ ;; Btree basics
+ ;;
+
+ (p-test (let ((btree (make-instance 'btree)))
+ (btree-insert btree 0 'zero)
+ (btree-insert btree 15 'fifteen)
+ (btree-insert btree 10 'ten)
+ btree)
+ (equal (list (btree-search it 0)
+ (btree-search it 10)
+ (btree-search it 15)
+ (btree-search it 42 :errorp nil))
+ '(zero ten fifteen nil)))
(test (not (current-rucksack)))
(write-line "basic tests ok"))
+(eval-when (:load-toplevel)
+ (test-basics))
+
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Test basic create, load and update functionality with many objects, so
+;;; the incremental garbage collector needs to do some work too.
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defparameter *names* '("David" "Jim" "Peter" "Thomas"
"Arthur" "Jans" "Klaus" "James" "Martin"))
@@ -70,12 +111,9 @@
(name person)
(age person))))
-
-(defparameter *persons-directory* #P"/tmp/persons/")
-
-(defun test-create (&key (nr-objects 100000) (directory *persons-directory*))
+(defun test-create (&key (nr-objects 100000))
"Test creating a rucksack with many persons."
- (with-rucksack (rucksack directory)
+ (with-rucksack (rucksack *test-suite* :if-exists :supersede)
(with-transaction ()
(loop for i below nr-objects
do (let ((person (make-instance 'person)))
@@ -84,17 +122,17 @@
(add-rucksack-root person rucksack))))))
-(defun test-update (&key (new-age 27) (directory *persons-directory*))
+(defun test-update (&key (new-age 27))
"Test updating all persons by changing their age."
- (with-rucksack (rucksack directory)
+ (with-rucksack (rucksack *test-suite*)
(with-transaction ()
(map-rucksack-roots (lambda (person)
(setf (age person) new-age))
rucksack))))
-(defun test-load (&key (directory *persons-directory*))
+(defun test-load ()
"Test loading all persons by computing their average age."
- (with-rucksack (rucksack directory)
+ (with-rucksack (rucksack *test-suite*)
(with-transaction ()
(let ((nr-persons 0)
(total-age 0))
@@ -108,10 +146,44 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;;; timings
+;;; Btrees
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-#|
-TEST-RS 25 > (time (test-create :nr-objects 100000))
-
-|#
+;;
+;; Test btrees as just another persistent data structure.
+;;
+
+(defun test-btree-insert (&key (n 20000) (node-size 100))
+ ;; Create a rucksack with btree that maps random integers to the
+ ;; equivalent strings in Roman notation.
+ (with-rucksack (rucksack *test-suite* :if-exists :supersede)
+ (with-transaction ()
+ (let ((btree (make-instance 'btree :value= 'string-equal
+ :max-node-size node-size)))
+ (loop for i from 1 to n
+ for key = (random n) do
+ (when (zerop (mod i 1000))
+ (format t "~D " i))
+ (btree-insert btree key (format nil "~R" key)))
+ (add-rucksack-root btree rucksack)))))
+
+(defun test-btree-dummy-insert (&key (n 20000))
+ ;; This function can be used for timing: subtract the time taken
+ ;; by this function from the time taken by TEST-BTREE-INSERT to
+ ;; get an estimate of the time needed to manipulate the btrees.
+ (loop for i from 1 to n
+ for key = (random n)
+ when (zerop (mod i 1000)) do (format t "~D " i)
+ collect (cons key (format nil "~R" key)))
+ t)
+
+
+(defun test-btree-map (&key (display t))
+ ;; Print out the contents of the btree.
+ (with-rucksack (rucksack *test-suite*)
+ (with-transaction ()
+ (let ((btree (first (rucksack-roots rucksack))))
+ (map-btree btree
+ (lambda (key value)
+ (when display
+ (format t "~&~D -> ~A~%" key value))))))))
More information about the rucksack-cvs
mailing list