From root at common-lisp.net Thu May 18 13:53:29 2006 From: root at common-lisp.net (root) Date: Thu, 18 May 2006 09:53:29 -0400 (EDT) Subject: [rucksack-cvs] CVS CVSROOT Message-ID: <20060518135329.968987C039@common-lisp.net> Update of /project/rucksack/cvsroot/CVSROOT In directory clnet:/custom/tmp/add-proj-2006.03.06.20.04.44.0500/CVSROOT Modified Files: loginfo Log Message: fixing oddly broken commit messages --- /project/rucksack/cvsroot/CVSROOT/loginfo 2006/05/16 15:47:37 1.1 +++ /project/rucksack/cvsroot/CVSROOT/loginfo 2006/05/18 13:53:29 1.2 @@ -29,3 +29,4 @@ #DEFAULT (echo ""; id; echo %s; date; cat) >> $CVSROOT/CVSROOT/commitlog # or #DEFAULT (echo ""; id; echo %{sVv}; date; cat) >> $CVSROOT/CVSROOT/commitlog +DEFAULT cvs-mailcommit --mailto rucksack-cvs at common-lisp.net --diff --full --root %r --dir %p %{sVv} From alemmens at common-lisp.net Thu May 18 15:38:31 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 18 May 2006 11:38:31 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060518153831.98E8E10C6@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv8954/rucksack Modified Files: garbage-collector.lisp Log Message: Fix bug in garbage collector where max-heap-size sometimes isn't initialized (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/18 15:38:31 1.3 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.3 2006/05/18 15:38:31 alemmens Exp $ (in-package :rucksack) @@ -72,9 +72,10 @@ &key size &allow-other-keys) ;; Give max-heap-end its initial value (depending on the :size initarg). (let ((proposed-size (or size *initial-heap-size*))) - (when (> proposed-size (heap-size heap)) - (setf (max-heap-end heap) - (+ (heap-start heap) proposed-size)))) + (setf (max-heap-end heap) + (if (> proposed-size (heap-size heap)) + (+ (heap-start heap) proposed-size) + (heap-end heap)))) ;; GC should begin in the :ready state. It will switch to :starting ;; state when the heap is expanded. (setf (state heap) :ready)) From alemmens at common-lisp.net Thu May 18 22:09:40 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 18 May 2006 18:09:40 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060518220940.E21D45F001@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv30226/rucksack Modified Files: queue.lisp Log Message: Fix bug in QUEUE-PEEK (fix from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/queue.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/queue.lisp 2006/05/18 22:09:40 1.3 @@ -1,4 +1,4 @@ -;; $Id: queue.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: queue.lisp,v 1.3 2006/05/18 22:09:40 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Queues @@ -78,12 +78,11 @@ (if (null contents) (and errorp (error 'empty-queue-error :queue queue)) - (let ((result (first contents))) - (setf contents (rest contents)) + (prog1 + (pop contents) (when (null contents) - (setf end nil)) - (decf size) - result)))) + (setq end nil)) + (decf size))))) (defun queue-empty-p (queue) @@ -96,13 +95,17 @@ "Returns the first object in the queue that has the given type (and removes all objects from the queue before it). Returns NIL (and clears the entire queue) if there is no such object." - (with-slots (contents) + (with-slots (contents size end) queue (loop while (and contents (not (typep (first contents) type))) - do (setq contents (rest contents))) + do (decf size) + (pop contents)) + (when (null contents) + (setq end nil)) (first contents))) + (defun queue-clear (queue) "Removes all elements from the queue (and returns the empty queue)." (with-slots (end contents size) From alemmens at common-lisp.net Thu May 18 22:21:51 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 18 May 2006 18:21:51 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060518222151.825EB6D003@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv32021/rucksack Modified Files: garbage-collector.lisp Log Message: Adapt SWEEP-SOME-HEAP-BLOCKS to new object layout (fix from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/18 15:38:31 1.3 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/18 22:21:51 1.4 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.3 2006/05/18 15:38:31 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.4 2006/05/18 22:21:51 alemmens Exp $ (in-package :rucksack) @@ -332,7 +332,12 @@ (block-size (if free-p (- block-start) block-header))) ;; Reclaim dead blocks. (when (and (not free-p) ; only non-free blocks - (not (block-alive-p object-table block-start block))) + (not (block-alive-p object-table + ;; read object ID + (let ((heap-stream (heap-stream heap))) + (deserialize heap-stream) + (deserialize heap-stream)) + block))) ;; The block is dead (either because the object is dead ;; or because the block contains an old version): return ;; the block to its free list. @@ -360,7 +365,7 @@ ;; All blocks start the same way: 8 bytes for the block header ;; (containing the size or a pointer to the next free block), ;; followed by the previous version pointer (a serialized positive - ;; integer) or the block size (a serialized negative integer; for + ;; integer or nil) or the block size (a serialized negative integer; for ;; free blocks). (let ((stream (heap-stream heap))) (file-position stream position) From alemmens at common-lisp.net Sat May 20 10:33:50 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 06:33:50 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520103350.34F9A7E022@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv3280/rucksack Modified Files: garbage-collector.lisp test.lisp Log Message: Added a WITH-TRANSACTION to TEST-LOAD and TEST-UPDATE. Changed BLOCK-ALIVE-P: it's now too conservative instead of not conservative enough. This still needs fixing. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/18 22:21:51 1.4 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 10:33:49 1.5 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.4 2006/05/18 22:21:51 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.5 2006/05/20 10:33:49 alemmens Exp $ (in-package :rucksack) @@ -355,11 +355,10 @@ work-done)) (defmethod block-alive-p ((object-table object-table) object-id block) - "Returns true iff the object is alive and the most recent object version -is in the given block." - (and (eql (object-info object-table object-id) :live-object) - (= (object-heap-position object-table object-id) - block))) + "Returns true iff the object in the block is alive." + ;; DO: Some versions of this object may not be reachable anymore. + ;; Those should be considered dead. + (member (object-info object-table object-id) '(:reserved :live-object))) (defun read-block-start (heap position) ;; All blocks start the same way: 8 bytes for the block header --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/05/20 10:33:50 1.3 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: test.lisp,v 1.3 2006/05/20 10:33:50 alemmens Exp $ (in-package :test-rucksack) @@ -87,22 +87,24 @@ (defun test-update (&key (new-age 27) (directory *persons-directory*)) "Test updating all persons by changing their age." (with-rucksack (rucksack directory) - (map-rucksack-roots (lambda (person) - (setf (age person) new-age)) - rucksack))) + (with-transaction () + (map-rucksack-roots (lambda (person) + (setf (age person) new-age)) + rucksack)))) (defun test-load (&key (directory *persons-directory*)) "Test loading all persons by computing their average age." (with-rucksack (rucksack directory) - (let ((nr-persons 0) - (total-age 0)) - (map-rucksack-roots (lambda (person) - (incf nr-persons) - (incf total-age (age person))) - rucksack) - ;; Return the average age as a float. - ;; (An average age of 1200/75 doesn't seem right.) - (coerce (/ total-age nr-persons) 'float)))) + (with-transaction () + (let ((nr-persons 0) + (total-age 0)) + (map-rucksack-roots (lambda (person) + (incf nr-persons) + (incf total-age (age person))) + rucksack) + ;; Return the average age as a float. + ;; (An average age of 1200/75 doesn't seem right.) + (coerce (/ total-age nr-persons) 'float))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From alemmens at common-lisp.net Sat May 20 10:41:47 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 06:41:47 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520104147.BF1BA7E026@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv3493/rucksack Modified Files: transactions.lisp Log Message: More robust version of WITH-TRANSACTION (from Nikodemus Siivola). --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/05/20 10:41:47 1.3 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: transactions.lisp,v 1.3 2006/05/20 10:41:47 alemmens Exp $ (in-package :rucksack) @@ -320,14 +320,34 @@ &allow-other-keys) &body body) (remf args :rucksack) - `(let ((*transaction* (transaction-start :rucksack ,rucksack , at args))) - (or (with-simple-restart (abort "Abort ~S" *transaction*) - (loop - (with-simple-restart (retry "Retry ~S" *transaction*) - , at body - (transaction-commit *transaction*) - (return t)))) - (transaction-rollback *transaction*)))) + (let ((committed (gensym "COMMITTED")) + (transaction (gensym "TRANSACTION")) + (result (gensym "RESULT"))) + `(let ((,transaction nil)) + (loop named ,transaction do + (with-simple-restart (retry "Retry ~S" ,transaction) + (let ((,committed nil) + (,result nil)) + (unwind-protect + (progn + ;; Use a local variable for the transaction so that nothing + ;; can replace it from underneath us, and only then bind + ;; it to *TRANSACTION*. + (setf ,transaction (transaction-start :rucksack ,rucksack , at args)) + (let ((*transaction* ,transaction)) + (with-simple-restart (abort "Abort ~S" ,transaction) + (setf ,result , at body) + (transaction-commit ,transaction) + (setf ,committed t))) + ;; Normal exit from the WITH-SIMPLE-RESTART above -- either + ;; everything went well or we aborted -- the ,COMMITTED will tell + ;; us. In either case we jump out of the RETRY loop. + (return-from ,transaction (values ,committed ,result))) + (unless ,committed + (transaction-rollback ,transaction))))) + ;; Normal exit from the above block -- we selected the RETRY restart. + )))) + From alemmens at common-lisp.net Sat May 20 15:07:28 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 11:07:28 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520150728.EBE1C4038@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv7944/rucksack Modified Files: cache.lisp objects.lisp Log Message: Let CACHE-TOUCH-OBJECT have an object instead of an object-id as parameter. (From Nikodemus Siivola.) --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 15:07:28 1.3 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: cache.lisp,v 1.3 2006/05/20 15:07:28 alemmens Exp $ (in-package :rucksack) @@ -217,7 +217,8 @@ already dirty, nothing happens." ;; This function is called by (setf slot-value-using-class), ;; slot-makunbound-using-class and p-data-write. - (let ((transaction (current-transaction))) + (let ((object-id (object-id object)) + (transaction (current-transaction))) ;; Check for transaction conflict. (let ((old-transaction (find-conflicting-transaction object-id cache transaction))) @@ -228,16 +229,13 @@ :old-transaction old-transaction))) ;; (unless (transaction-changed-object transaction object-id) ; already dirty - (let ((object (gethash object-id (objects cache)))) - (unless object - (internal-rucksack-error "Can't find object with id ~D." object-id)) - ;; Remove object from the 'clean objects' hash table. - ;; It would be nice to remove the object from the 'clean' queue too, - ;; but that's too expensive. We'll let MAKE-ROOM-IN-CACHE take care - ;; of that. - (remhash object-id (objects cache)) - ;; Let the transaction keep track of the dirty object. - (transaction-touch-object transaction object object-id))))) + ;; Remove object from the 'clean objects' hash table. + ;; It would be nice to remove the object from the 'clean' queue too, + ;; but that's too expensive. We'll let MAKE-ROOM-IN-CACHE take care + ;; of that. + (remhash object-id (objects cache)) + ;; Let the transaction keep track of the dirty object. + (transaction-touch-object transaction object object-id)))) --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/05/20 15:07:28 1.3 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: objects.lisp,v 1.3 2006/05/20 15:07:28 alemmens Exp $ (in-package :rucksack) @@ -118,7 +118,7 @@ (defmethod persistent-data-write (function (data persistent-data) value &rest args) (apply function value (contents data) args) - (cache-touch-object (object-id data) (cache data))) + (cache-touch-object data (cache data))) (defun make-persistent-data (class contents &optional (rucksack (current-rucksack))) @@ -351,7 +351,7 @@ (and old-boundp (slot-value-using-class class object slot-name-or-def))) (result (call-next-method))) - (cache-touch-object (object-id object) (cache object)) + (cache-touch-object object (cache object)) ;; Update indexes. (rucksack-maybe-index-changed-slot (rucksack object) class object slot @@ -377,7 +377,7 @@ (and old-boundp (slot-value-using-class class object slot-name-or-def))) (result (call-next-method))) - (cache-touch-object (object-id object) (cache object)) + (cache-touch-object object (cache object)) (rucksack-maybe-index-changed-slot (rucksack object) class object slot old-value nil From alemmens at common-lisp.net Sat May 20 15:35:38 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 11:35:38 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520153538.0AECE1900F@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv11397/rucksack Modified Files: garbage-collector.lisp rucksack.lisp Log Message: Fix an obsolete comment. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 10:33:49 1.5 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 15:35:37 1.6 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.5 2006/05/20 10:33:49 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.6 2006/05/20 15:35:37 alemmens Exp $ (in-package :rucksack) @@ -90,8 +90,7 @@ ;; Write the block size (as a negative number) in the start of the ;; block (just behind the header) to indicate that this is a free ;; block. This is necessary for the sweep phase of a mark-and-sweep - ;; collector to distinguish it from a block that contains an object - ;; (and starts with a non-negative object id). + ;; collector to distinguish it from a block that contains an object. (file-position (heap-stream heap) (+ block (block-header-size heap))) (serialize (- block-size) (heap-stream heap))) @@ -109,7 +108,7 @@ ;; In the scanning phase, the object id must be added to the root set to ;; guarantee that it will be marked and scanned. (when (eql (state heap) :scanning) - (push object-id (roots heap)))) + (add-rucksack-root-id object-id (roots heap)))) ;; ;; Hooking into free list methods --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/18 12:46:57 1.3 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/20 15:35:37 1.4 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.4 2006/05/20 15:35:37 alemmens Exp $ (in-package :rucksack) @@ -273,7 +273,10 @@ (defmethod add-rucksack-root (object (rucksack standard-rucksack)) - (push (object-id object) (slot-value rucksack 'roots)) + (add-rucksack-root-id (object-id object) rucksack)) + +(defun add-rucksack-root-id (object-id rucksack) + (push object-id (slot-value rucksack 'roots)) (setf (roots-changed-p rucksack) t)) (defmethod map-rucksack-roots (function (rucksack standard-rucksack)) From alemmens at common-lisp.net Sat May 20 15:36:18 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 11:36:18 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520153618.1D63619010@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv11441/rucksack Added Files: internals.txt Log Message: Start of "Rucksack internals" document. --- /project/rucksack/cvsroot/rucksack/internals.txt 2006/05/20 15:36:18 NONE +++ /project/rucksack/cvsroot/rucksack/internals.txt 2006/05/20 15:36:18 1.1 RUCKSACK INTERNALS * Free list heaps A free-list-heap starts with an 8-byte address ('disk pointer') that points to the end of the heap. This is followed by as many 'disk-pointers' as the heap has free lists: each disk pointer points to the first free block on that free list. * Object table The object table is a free-list-heap with exactly one free list, so it contains one free list pointer. * The real heap The 'real' heap contains 32 free lists, with a smallest block size of 16 (i.e. 2^4) and a largest block size of 2^(4+31), i.e. 32 GB. * Blocks and objects The heap contains blocks of different sizes (currently the block sizes are powers of 2; starting with blocks of 16 bytes). Each block starts with an 8-byte header. If the block is unoccupied, the header contains a pointer to the next block in the free list; otherwise it contains the size of the block. The header is followed by a serialized value which is either NIL, a positive integer or a negative integer. If it's NIL, the block is occupied by an object of which there is exactly one version. If it's a positive integer, the block is occupied by an object and the integer is a pointer to (the heap position of) the previously saved version of the object. If it's negative, the block belongs to a free list and is not in use; the integer's absolute value is the size of the block (the sweep phase of the garbage collector needs this block size). [OCCUPIED BLOCK]: 0- 8: block size 8-15: pointer to previous version (nil or an integer) .. : transaction id .. : object id .. : nr of slots .. : schema id ...: serialized slots ...: maybe some free space [FREE BLOCK]: 0- 8: pointer to next free block .. : the negative of the block size ... : free space From alemmens at common-lisp.net Sat May 20 20:25:32 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 16:25:32 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520202532.634DC64120@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv13415/rucksack Modified Files: cache.lisp Log Message: Finish CACHE-TOUCH-OBJECT patch (hopefully for real this time). --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 15:07:28 1.3 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 20:25:32 1.4 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.3 2006/05/20 15:07:28 alemmens Exp $ +;; $Id: cache.lisp,v 1.4 2006/05/20 20:25:32 alemmens Exp $ (in-package :rucksack) @@ -211,7 +211,7 @@ id)) -(defmethod cache-touch-object (object-id (cache standard-cache)) +(defmethod cache-touch-object (object (cache standard-cache)) "Checks for transaction conflicts and signals a transaction conflict if necessary. Change the object's status to dirty. If the object is already dirty, nothing happens." From alemmens at common-lisp.net Sat May 20 21:16:59 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 17:16:59 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520211659.29A492017@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv20477/rucksack Modified Files: cache.lisp garbage-collector.lisp heap.lisp rucksack.lisp Log Message: Some more work towards getting a working GC. Also removed some dead code. --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 20:25:32 1.4 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 21:16:58 1.5 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.4 2006/05/20 20:25:32 alemmens Exp $ +;; $Id: cache.lisp,v 1.5 2006/05/20 21:16:58 alemmens Exp $ (in-package :rucksack) @@ -74,6 +74,8 @@ ;; keep track of different class versions for objects in the heap. ((heap :initarg :heap :reader heap) (schema-table :initarg :schema-table :reader schema-table) + (rucksack :initarg :rucksack :reader rucksack + :documentation "Back pointer to the rucksack.") ;; Clean objects (objects :initarg :objects :reader objects @@ -103,12 +105,7 @@ :documentation "A number between 0 and 1. When the cache is full, i.e. when there are at least SIZE (non-dirty) objects in the queue, it will be shrunk by removing (1 - SHRINK-RATIO) * SIZE -objects.") - ;; - (currently-saved-object :initform nil - :accessor currently-saved-object - :documentation "The object that's currently -being saved. This is used by slot-value-using-class & friends."))) +objects."))) (defmethod print-object ((cache standard-cache) stream) @@ -164,6 +161,7 @@ :class heap-class :if-exists if-exists :if-does-not-exist if-does-not-exist + :rucksack (rucksack cache) :options (list* :object-table object-table heap-options)) schema-table (open-schema-table (merge-pathnames "schemas" directory) @@ -438,14 +436,6 @@ (setq younger block block older))))))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmacro saving-object ((cache object) &body body) - ;; This is used by slot-value-using-class & friends to determine - ;; if it should try to dereference proxies. - (let ((cache-var (gensym "CACHE"))) - `(let ((,cache-var ,cache)) - (setf (currently-saved-object ,cache-var) ,object) - (unwind-protect (progn , at body) - (setf (currently-saved-object ,cache-var) nil))))) + --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 15:35:37 1.6 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 21:16:58 1.7 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.6 2006/05/20 15:35:37 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.7 2006/05/20 21:16:58 alemmens Exp $ (in-package :rucksack) @@ -32,6 +32,7 @@ ((object-table :initarg :object-table :reader object-table) (buffer :initform (make-instance 'serialization-buffer) :reader serialization-buffer) + (rucksack :initarg :rucksack :reader rucksack) ;; Some state used for incremental garbage collection. (roots :initarg :roots :initform '() :accessor roots :documentation "A list of object-ids of roots that must be marked.") @@ -107,8 +108,10 @@ :live-object))) ;; In the scanning phase, the object id must be added to the root set to ;; guarantee that it will be marked and scanned. + ;; DO: This is too simple, because now the object will stay in the root + ;; set forever. We need a separate (when (eql (state heap) :scanning) - (add-rucksack-root-id object-id (roots heap)))) + (push object-id (roots heap)))) ;; ;; Hooking into free list methods @@ -212,7 +215,8 @@ (setf (nr-object-bytes-marked heap) 0 (nr-heap-bytes-scanned heap) 0 (nr-heap-bytes-sweeped heap) 0 - (nr-object-bytes-sweeped heap) 0) + (nr-object-bytes-sweeped heap) 0 + (roots heap) (copy-list (slot-value (rucksack heap) 'roots))) (setf (state heap) :marking-object-table)) (:marking-object-table (decf amount (mark-some-objects-in-table heap amount))) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/18 12:46:57 1.3 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/20 21:16:58 1.4 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $ +;; $Id: heap.lisp,v 1.4 2006/05/20 21:16:58 alemmens Exp $ (in-package :rucksack) @@ -63,7 +63,7 @@ (defun open-heap (pathname - &key (class 'heap) (options '()) + &key (class 'heap) rucksack (options '()) (if-exists :overwrite) (if-does-not-exist :create)) (let ((stream (open pathname :element-type '(unsigned-byte 8) @@ -73,6 +73,7 @@ (apply #'make-instance class :stream stream + :rucksack rucksack options))) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/20 15:35:37 1.4 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/20 21:16:58 1.5 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.4 2006/05/20 15:35:37 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.5 2006/05/20 21:16:58 alemmens Exp $ (in-package :rucksack) @@ -255,6 +255,7 @@ (setf (slot-value rucksack 'cache) (apply #'open-cache (rucksack-directory rucksack) :class cache-class + :rucksack rucksack cache-args)) (load-roots rucksack)) From alemmens at common-lisp.net Sat May 20 21:19:56 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 May 2006 17:19:56 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060520211956.EBFD12017@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv20567/rucksack Modified Files: garbage-collector.lisp Log Message: Remove wrong comment. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 21:16:58 1.7 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 21:19:56 1.8 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.7 2006/05/20 21:16:58 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.8 2006/05/20 21:19:56 alemmens Exp $ (in-package :rucksack) @@ -108,8 +108,6 @@ :live-object))) ;; In the scanning phase, the object id must be added to the root set to ;; guarantee that it will be marked and scanned. - ;; DO: This is too simple, because now the object will stay in the root - ;; set forever. We need a separate (when (eql (state heap) :scanning) (push object-id (roots heap)))) From alemmens at common-lisp.net Sun May 21 21:00:04 2006 From: alemmens at common-lisp.net (alemmens) Date: Sun, 21 May 2006 17:00:04 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060521210004.1FFAB2F00A@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv3026/rucksack Modified Files: garbage-collector.lisp heap.lisp rucksack.lisp Log Message: Some more garbage collector fixes. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/20 21:19:56 1.8 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/21 21:00:03 1.9 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.8 2006/05/20 21:19:56 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.9 2006/05/21 21:00:03 alemmens Exp $ (in-package :rucksack) @@ -194,10 +194,9 @@ ;; Collect some garbage ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod collect-garbage ((heap mark-and-sweep-heap) roots) +(defmethod collect-garbage ((heap mark-and-sweep-heap)) ;; A simple test of COLLECT-SOME-GARBAGE: keep collecting 1024 bytes of ;; garbage until the garbage collector is ready. - (setf (roots heap) (mapcar #'object-id roots)) (setf (state heap) :starting) (loop until (eql (state heap) :ready) do (collect-some-garbage heap 1024))) @@ -214,7 +213,9 @@ (nr-heap-bytes-scanned heap) 0 (nr-heap-bytes-sweeped heap) 0 (nr-object-bytes-sweeped heap) 0 - (roots heap) (copy-list (slot-value (rucksack heap) 'roots))) + ;; We don't need to copy the roots, because we're not + ;; going to modify the list (just push and pop). + (roots heap) (slot-value (rucksack heap) 'roots)) (setf (state heap) :marking-object-table)) (:marking-object-table (decf amount (mark-some-objects-in-table heap amount))) @@ -281,16 +282,21 @@ (defmethod mark-root ((heap mark-and-sweep-heap) (object-id integer)) ;; Returns the number of octets scanned. - (let* ((object-table (object-table heap)) - (block (object-heap-position object-table object-id)) - (buffer (load-block heap block :skip-header t))) - (setf (object-info object-table object-id) :live-object) - (scan-object object-id buffer heap) - ;; Keep track of statistics. - (let ((block-size (block-size block heap))) - (incf (nr-heap-bytes-scanned heap) block-size) - ;; Return the amount of work done. - block-size))) + (let ((object-table (object-table heap))) + (if (eql (object-info object-table object-id) :reserved) + ;; Reserved objects aren't written to the heap yet (they just + ;; have an object table entry), so we don't need to scan them + ;; for child objects + 0 + (let* ((block (object-heap-position object-table object-id)) + (buffer (load-block heap block :skip-header t))) + (setf (object-info object-table object-id) :live-object) + (scan-object object-id buffer heap) + ;; Keep track of statistics. + (let ((block-size (block-size block heap))) + (incf (nr-heap-bytes-scanned heap) block-size) + ;; Return the amount of work done. + block-size))))) (defmethod load-block ((heap mark-and-sweep-heap) block @@ -302,6 +308,7 @@ (load-buffer buffer (heap-stream heap) (block-size block heap) + :eof-error-p nil :file-position (if skip-header (+ block (block-header-size heap)) block))) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/20 21:16:58 1.4 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/21 21:00:03 1.5 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.4 2006/05/20 21:16:58 alemmens Exp $ +;; $Id: heap.lisp,v 1.5 2006/05/21 21:00:03 alemmens Exp $ (in-package :rucksack) @@ -503,7 +503,8 @@ (file-position stream file-position)) (write-sequence contents stream :end (buffer-count buffer)))) -(defmethod load-buffer ((buffer buffer) stream nr-octets &key file-position) +(defmethod load-buffer ((buffer buffer) stream nr-octets + &key file-position eof-error-p) (with-slots (contents) buffer ;; If the buffer isn't big enough, make a bigger buffer. @@ -517,7 +518,8 @@ (when file-position (file-position stream file-position)) (setf (fill-pointer contents) nr-octets) - (when (< (read-sequence contents stream :end nr-octets) nr-octets) + (when (and (< (read-sequence contents stream :end nr-octets) nr-octets) + eof-error-p) (error "Unexpected end of file while loading a buffer of ~D octets." nr-octets))) buffer) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/20 21:16:58 1.5 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/21 21:00:03 1.6 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.5 2006/05/20 21:16:58 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.6 2006/05/21 21:00:03 alemmens Exp $ (in-package :rucksack) @@ -280,6 +280,12 @@ (push object-id (slot-value rucksack 'roots)) (setf (roots-changed-p rucksack) t)) +(defmethod delete-rucksack-root (object (rucksack standard-rucksack)) + (with-slots (roots) + rucksack + (setf roots (delete (object-id object) roots) + (roots-changed-p rucksack) t))) + (defmethod map-rucksack-roots (function (rucksack standard-rucksack)) (loop for root-id in (slot-value rucksack 'roots) do (funcall function @@ -396,8 +402,7 @@ (defun test-garbage-collector (rucksack) - (collect-garbage (heap (rucksack-cache rucksack)) - (rucksack-roots rucksack))) + (collect-garbage (heap (rucksack-cache rucksack)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From alemmens at common-lisp.net Wed May 24 20:45:09 2006 From: alemmens at common-lisp.net (alemmens) Date: Wed, 24 May 2006 16:45:09 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060524204509.6C8FF550D3@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv20084/rucksack Modified Files: garbage-collector.lisp heap.lisp internals.txt objects.lisp Log Message: Fixed enough garbage collector bugs to get the TEST-CREATE, TEST-LOAD and TEST-UPDATE functions running. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/21 21:00:03 1.9 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/24 20:45:09 1.10 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.9 2006/05/21 21:00:03 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.10 2006/05/24 20:45:09 alemmens Exp $ (in-package :rucksack) @@ -87,7 +87,7 @@ (defmethod initialize-block (block block-size (heap mark-and-sweep-heap)) - ;; This is called by a free list heap while allocating a block. + ;; This is called by a free list heap while creating free blocks. ;; Write the block size (as a negative number) in the start of the ;; block (just behind the header) to indicate that this is a free ;; block. This is necessary for the sweep phase of a mark-and-sweep @@ -115,25 +115,20 @@ ;; Hooking into free list methods ;; -(defmethod allocate-block :after ((heap mark-and-sweep-heap) - &key size &allow-other-keys) +(defmethod gc-work-for-size ((heap mark-and-sweep-heap) size) ;; The garbage collector needs to be ready when there's no more free space ;; left in the heap. So when SIZE octets are allocated, the garbage collector - ;; needs to collect a proportional amount of octets: + ;; needs to collect a proportional amount of bytes: ;; ;; Size / Free = Work / WorkLeft ;; ;; or: Work = (Size / Free) * WorkLeft ;; (let* ((free (free-space heap)) - (work-left (work-left heap)) - (work (if (>= size free) - work-left - ;; Use FLOOR, not CEILING so we don't do any work - ;; when there's ridiculously little to do anyway. - (* (floor size free) work-left)))) - (when (> work 0) - (collect-some-garbage heap work)))) + (work-left (work-left heap))) + (if (>= size free) + work-left + (floor (* size work-left) free)))) (defmethod free-space ((heap mark-and-sweep-heap)) @@ -201,6 +196,11 @@ (loop until (eql (state heap) :ready) do (collect-some-garbage heap 1024))) +(defmethod finish-garbage-collection ((heap mark-and-sweep-heap)) + ;; Make sure that the garbage collector is in the :ready state. + (loop until (eql (state heap) :ready) + do (collect-some-garbage heap (* 512 1024)))) + (defmethod collect-some-garbage ((heap mark-and-sweep-heap) amount) ;; Collect at least the specified amount of garbage ;; (i.e. mark or sweep at least the specified amount of octets). @@ -251,7 +251,7 @@ (< work-done amount)) do (progn (when (eql (object-info object-table object-id) :live-object) - ;; Don't touch free blocks. + ;; Don't touch free or reserved blocks. (setf (object-info object-table object-id) :dead-object)) (incf (nr-object-bytes-marked heap) object-block-size) (incf work-done object-block-size))) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/21 21:00:03 1.5 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/24 20:45:09 1.6 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.5 2006/05/21 21:00:03 alemmens Exp $ +;; $Id: heap.lisp,v 1.6 2006/05/24 20:45:09 alemmens Exp $ (in-package :rucksack) @@ -114,9 +114,10 @@ ;; (defmethod expand-heap ((heap heap) block-size) - ;; Expands the heap and returns an uninitialized block of the - ;; specified size. Signals a continuable error if this makes - ;; the heap exceed its maximum size. + ;; Creates (and initializes) a block of the specified size by expanding + ;; the heap. The block is not hooked into the free list yet. Returns + ;; the new block (but signals a continuable error if expanding the heap + ;; would make it exceed its maximum size. (let ((new-block (heap-end heap)) (max-size (max-heap-size heap))) (when (and max-size (> (+ new-block block-size) max-size)) @@ -128,7 +129,8 @@ max-size))) ;; (incf (heap-end heap) block-size) - ;; Return the new block. + ;; Initialize and return the new block. + (initialize-block new-block block-size heap) new-block)) --- /project/rucksack/cvsroot/rucksack/internals.txt 2006/05/20 15:36:18 1.1 +++ /project/rucksack/cvsroot/rucksack/internals.txt 2006/05/24 20:45:09 1.2 @@ -52,7 +52,11 @@ .. : the negative of the block size ... : free space +[ALLOCATED BUT NOT YET OCCUPIED BLOCK] + 0- 8: block size + .. : ??? + --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/05/20 15:07:28 1.3 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/05/24 20:45:09 1.4 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.3 2006/05/20 15:07:28 alemmens Exp $ +;; $Id: objects.lisp,v 1.4 2006/05/24 20:45:09 alemmens Exp $ (in-package :rucksack) @@ -490,14 +490,17 @@ (serialize (slot-value object slot-name) buffer) (serialize-marker +unbound-slot+ buffer)))) ;; Allocate a heap block of the right size. - (let ((block (allocate-block heap - :size (+ (buffer-count buffer) - (block-header-size heap))))) - ;; And save the serialized buffer in the block. + (let* ((size (+ (buffer-count buffer) + (block-header-size heap))) + (block (allocate-block heap :size size))) + ;; Save the serialized buffer in the block. (save-buffer buffer (heap-stream heap) :file-position (+ block (block-header-size heap))) ;; Let the garbage collector do its thing after an object is - ;; written to the heap. + ;; written to the heap. (Not earlier, otherwise the GC may + ;; see objects that are neither free nor completely saved and + ;; it doesn't know how to deal with those.) + (collect-some-garbage heap (gc-work-for-size heap size)) (handle-written-object object-id block heap) ;; Return the block. block))) From alemmens at common-lisp.net Thu May 25 13:01:38 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 25 May 2006 09:01:38 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060525130138.7D93722008@common-lisp.net> 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)))))))) From alemmens at common-lisp.net Thu May 25 13:03:29 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 25 May 2006 09:03:29 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060525130329.8497522008@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv7848/rucksack Removed Files: test-cache.lisp test-cached-btrees.lisp Log Message: Removed obsolete test files. From alemmens at common-lisp.net Sun May 28 11:18:48 2006 From: alemmens at common-lisp.net (alemmens) Date: Sun, 28 May 2006 07:18:48 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060528111848.1D6F44B006@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv17194/rucksack Modified Files: rucksack.asd Log Message: Keep ASDF file in sync with make file. --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2006/05/18 09:08:13 1.1 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2006/05/28 11:18:47 1.2 @@ -1,4 +1,4 @@ -;;; $Id: rucksack.asd,v 1.1 2006/05/18 09:08:13 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.2 2006/05/28 11:18:47 alemmens Exp $ (in-package :cl-user) @@ -20,7 +20,5 @@ (:file "index") (:file "rucksack") (:file "transactions") - #+old (:file "test-cache") - #+old (:file "test-cached-btrees") (:file "test"))) - \ No newline at end of file + From alemmens at common-lisp.net Sun May 28 11:22:54 2006 From: alemmens at common-lisp.net (alemmens) Date: Sun, 28 May 2006 07:22:54 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060528112254.87AF350006@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv17367/rucksack Modified Files: rucksack.lisp Log Message: Fix a few obsolete occurrences of CLASS instead of RUCKSACK-CLASS (from Aycan iRiCAN). --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/21 21:00:03 1.6 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/28 11:22:54 1.7 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.6 2006/05/21 21:00:03 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.7 2006/05/28 11:22:54 alemmens Exp $ (in-package :rucksack) @@ -549,7 +549,7 @@ (defmethod rucksack-map-class ((rucksack standard-rucksack) class function &key (id-only nil) (include-subclasses t)) (let ((visited-p (make-hash-table)) - (cache (cache rucksack))) + (cache (rucksack-cache rucksack))) (labels ((map-instances (class) (let ((index (rucksack-class-index rucksack class :errorp nil))) (when index @@ -684,7 +684,7 @@ &key equal min max include-min include-max (order :ascending) (id-only nil) (include-subclasses t)) - (let ((cache (cache rucksack)) + (let ((cache (rucksack-cache rucksack)) (visited-p (make-hash-table))) (labels ((map-slot (class) (let ((index (rucksack-slot-index rucksack class slot From alemmens at common-lisp.net Sun May 28 12:07:55 2006 From: alemmens at common-lisp.net (alemmens) Date: Sun, 28 May 2006 08:07:55 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060528120755.B9A5013001@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv26224 Modified Files: mop.lisp Log Message: More subtle merging of persistent slot options (from Nikodemus Siivola). --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/05/28 12:07:55 1.3 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: mop.lisp,v 1.3 2006/05/28 12:07:55 alemmens Exp $ (in-package :rucksack) @@ -169,31 +169,28 @@ (defmethod compute-effective-slot-definition ((class persistent-class) slot-name direct-slot-definitions) - - ;; Compute the effective slot definition for slots in a - ;; persistent-class. We use a simple strategy at the moment: - ;; just use the most specific direct slot definition and ignore - ;; all others (usually there aren't any others anyway). - - (declare (ignore slot-name)) - (let ((effective-slot-def (call-next-method)) - (direct-slot-def (first direct-slot-definitions))) - - ;; NOTE: A persistent-class may also contain slots of another type - ;; than persistent-direct-slot-definition. (For instance, when - ;; we combine the persistent-class metaclass with another one.) - ;; Those other slot definitions should not be touched here. - - (when (typep direct-slot-def 'persistent-direct-slot-definition) - - ;; Just copy the values of 'our' slot options from the - ;; direct-slot-definition to the effective-slot-definition. - (dolist (option '(persistence index)) - (when (slot-boundp direct-slot-def option) - (setf (slot-value effective-slot-def option) - (slot-value direct-slot-def option))))) - + (let ((effective-slotd (call-next-method)) + (persistent-slotds + (remove-if-not (lambda (slotd) + (typep slotd 'persistent-direct-slot-definition)) + direct-slot-definitions))) + + ;; If any direct slot is persistent, then the effective one is too. + (setf (slot-value effective-slotd 'persistence) + (some #'slot-persistence persistent-slotds)) + + ;; If exactly one direct slot is indexed, then the effecive one is + ;; too. If more then one is indexed, signal an error. + (let ((index-slotds (remove-if-not #'slot-index persistent-slotds))) + (cond ((cdr index-slotds) + (error "Multiple indexes for slot ~S in ~S:~% ~{~S~^, ~}." + slot-name class + (mapcar #'slot-index index-slotds))) + (index-slotds + (setf (slot-value effective-slotd 'index) + (slot-index (car index-slotds)))))) + ;; Return the effective slot definition. - effective-slot-def)) + effective-slotd))