From alemmens at common-lisp.net Thu Aug 3 10:59:52 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 06:59:52 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803105952.A2F7F49005@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv11379 Modified Files: cache.lisp garbage-collector.lisp heap.lisp serialize.lisp Log Message: Replace free-list-full by free-list-empty. Fix bug in find-block. (From Edi Weitz) --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/05/20 21:16:58 1.5 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/03 10:59:52 1.6 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.5 2006/05/20 21:16:58 alemmens Exp $ +;; $Id: cache.lisp,v 1.6 2006/08/03 10:59:52 alemmens Exp $ (in-package :rucksack) @@ -202,7 +202,8 @@ ;; (defmethod cache-create-object (object (cache standard-cache)) - ;; This is called by an after method on initialize-instance. + ;; This is called by a before method on SHARED-INITIALIZE and + ;; by MAKE-PERSISTENT-DATA. (let ((id (new-object-id (object-table (heap cache))))) ;; Add to dirty objects. (transaction-touch-object (current-transaction) object id) --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/05/24 20:45:09 1.10 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 10:59:52 1.11 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.10 2006/05/24 20:45:09 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.11 2006/08/03 10:59:52 alemmens Exp $ (in-package :rucksack) @@ -283,10 +283,11 @@ (defmethod mark-root ((heap mark-and-sweep-heap) (object-id integer)) ;; Returns the number of octets scanned. (let ((object-table (object-table heap))) - (if (eql (object-info object-table object-id) :reserved) + (if (member (object-info object-table object-id) '(:reserved :live-object)) ;; 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 + ;; for child objects. And live objects were already marked earlier, + ;; so don't need to be scanned again now. 0 (let* ((block (object-heap-position object-table object-id)) (buffer (load-block heap block :skip-header t))) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/05/24 20:45:09 1.6 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/03 10:59:52 1.7 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.6 2006/05/24 20:45:09 alemmens Exp $ +;; $Id: heap.lisp,v 1.7 2006/08/03 10:59:52 alemmens Exp $ (in-package :rucksack) @@ -220,8 +220,8 @@ ;; Keep copy in memory (aref (slot-value heap 'starts) size-class) pointer)) -(defmethod free-list-full-p (size-class (heap free-list-heap)) - ;; A free list is full when the start points to itself. +(defmethod free-list-empty-p (size-class (heap free-list-heap)) + ;; A free list is empty when the start points to itself. (let ((start (free-list-start heap size-class))) (= start (free-list-pointer size-class)))) @@ -283,8 +283,8 @@ ;; I'm not sure that is worth the extra complexity (or the extra time). (let* ((size-class (size-class size heap)) (block (free-list-start heap size-class))) - ;; Expand free list when it's full. - (when (free-list-full-p size-class heap) + ;; Expand free list when it's empty. + (when (free-list-empty-p size-class heap) (if expand (setq block (expand-free-list size-class heap)) (return-from allocate-block nil))) @@ -304,7 +304,7 @@ ;; Push the block on the front of its free list. (let* ((size (block-size block heap)) (size-class (size-class size heap))) - (if (free-list-full-p size-class heap) + (if (free-list-empty-p size-class heap) ;; Let free list start point to the block and vice versa. (setf (block-header block heap) (free-list-pointer size-class) (free-list-start heap size-class) block) @@ -351,9 +351,7 @@ do (let ((block (allocate-block heap :size min-size :expand nil))) (when block (return (values block - (size-class-block-size size-class heap)))))) - ;; Return nil if we can't find anything. - nil)) + (size-class-block-size size-class heap)))))))) (defmethod carve-up-block-for-free-list (size-class block size @@ -393,9 +391,9 @@ (defmethod heap-info ((heap free-list-heap)) ;; Returns the total number of free octets in the heap. ;; As a second value it returns a list with, for each free list - ;; that is not full, a plist with info about that free list. + ;; that is not empty, a plist with info about that free list. (let* ((info (loop for size-class below (nr-free-lists heap) - unless (free-list-full-p size-class heap) + unless (free-list-empty-p size-class heap) collect (free-list-info size-class heap))) (total (loop for plist in info sum (getf plist :nr-free-octets)))) --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/05/18 12:46:57 1.3 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/03 10:59:52 1.4 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $ +;; $Id: serialize.lisp,v 1.4 2006/08/03 10:59:52 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -954,8 +954,7 @@ array))) (defmethod scan-contents ((marker (eql +array+)) stream gc) - ;; Scan type - (scan stream gc) + (scan stream gc) ; scan type (let ((dimensions (deserialize-list stream))) (when (= 1 (length dimensions)) (let ((has-fill-pointer-p (deserialize stream))) From alemmens at common-lisp.net Thu Aug 3 11:05:45 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 07:05:45 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803110545.937152F024@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv13643 Modified Files: garbage-collector.lisp Log Message: Make sure that MAX-HEAP-END is always an integer (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 10:59:52 1.11 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:05:45 1.12 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.11 2006/08/03 10:59:52 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.12 2006/08/03 11:05:45 alemmens Exp $ (in-package :rucksack) @@ -230,7 +230,7 @@ (if (integerp (grow-size heap)) (incf (max-heap-end heap) (grow-size heap)) (setf (max-heap-end heap) - (* (grow-size heap) (max-heap-end heap)))) + (round (* (grow-size heap) (max-heap-end heap))))) ;; (setf (state heap) :ready))))) From alemmens at common-lisp.net Thu Aug 3 11:31:18 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 07:31:18 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803113118.135AE17038@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv17613 Modified Files: garbage-collector.lisp Log Message: Let heap grow more slowly after a garbage collection (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:05:45 1.12 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:31:17 1.13 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.12 2006/08/03 11:05:45 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.13 2006/08/03 11:31:17 alemmens Exp $ (in-package :rucksack) @@ -56,7 +56,7 @@ :documentation "The maximum acceptable value for heap-end during the current garbage collection.") (grow-size :initarg :grow-size - :initform 2.0 + :initform nil :accessor grow-size :documentation "Specifies a minimum amount to grow the heap when it needs to grow. If 'grow size' is an integer, the expected @@ -73,10 +73,11 @@ &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*))) - (setf (max-heap-end heap) - (if (> proposed-size (heap-size heap)) - (+ (heap-start heap) proposed-size) - (heap-end heap)))) + (setf (max-heap-end heap) (if (> proposed-size (heap-size heap)) + (+ (heap-start heap) proposed-size) + (heap-end heap)) + (grow-size heap) (or (grow-size heap) + (max-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 Aug 3 11:39:39 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 07:39:39 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803113939.343B928068@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv18160 Modified Files: garbage-collector.lisp heap.lisp object-table.lisp transactions.lisp Log Message: Let SETF functions give correct return values. (From Edi Weitz.) --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:31:17 1.13 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:39:39 1.14 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.13 2006/08/03 11:31:17 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.14 2006/08/03 11:39:39 alemmens Exp $ (in-package :rucksack) @@ -385,7 +385,8 @@ (defun (setf object-alive-p) (value object-table object-id) (setf (object-info object-table object-id) - (if value :live-object :dead-object))) + (if value :live-object :dead-object)) + value) (defun object-alive-p (object-table object-id) (eql (object-info object-table object-id) :live-object)) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/03 10:59:52 1.7 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/03 11:39:39 1.8 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.7 2006/08/03 10:59:52 alemmens Exp $ +;; $Id: heap.lisp,v 1.8 2006/08/03 11:39:39 alemmens Exp $ (in-package :rucksack) @@ -107,7 +107,8 @@ (defun (setf pointer-value) (value pointer heap) (file-position (heap-stream heap) pointer) (write-unsigned-bytes value (cell-buffer heap) (heap-stream heap) - +pointer-size+)) + +pointer-size+) + value) ;; ;; Expanding the heap --- /project/rucksack/cvsroot/rucksack/object-table.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/object-table.lisp 2006/08/03 11:39:39 1.3 @@ -1,4 +1,4 @@ -;; $Id: object-table.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: object-table.lisp,v 1.3 2006/08/03 11:39:39 alemmens Exp $ (in-package :rucksack) @@ -86,7 +86,8 @@ (+ (block-header-size object-table) +nr-object-info-octets+ (object-id-to-block id object-table))) - (serialize position stream))) + (serialize position stream)) + position) (defun object-heap-position (object-table id) (let ((stream (heap-stream object-table))) @@ -116,7 +117,8 @@ (:dead-object +dead-object+) (:live-object +live-object+) (:reserved +reserved-object+)))) - (serialize-marker marker stream)))) + (serialize-marker marker stream))) + info) ;; --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/05/20 10:41:47 1.3 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 11:39:39 1.4 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.3 2006/05/20 10:41:47 alemmens Exp $ +;; $Id: transactions.lisp,v 1.4 2006/08/03 11:39:39 alemmens Exp $ (in-package :rucksack) @@ -292,7 +292,8 @@ OLD-BLOCK." (let ((stream (heap-stream heap))) (file-position stream (+ young-block (block-header-size heap))) - (serialize-previous-version-pointer old-block stream))) + (serialize-previous-version-pointer old-block stream)) + old-block) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Rolling back From alemmens at common-lisp.net Thu Aug 3 11:52:46 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 07:52:46 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803115246.575812B02A@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv21536 Modified Files: transactions.lisp Log Message: WITH-TRANSACTION now returns the result of the body as first value. (From Edi Weitz.) --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 11:39:39 1.4 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 11:52:46 1.5 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.4 2006/08/03 11:39:39 alemmens Exp $ +;; $Id: transactions.lisp,v 1.5 2006/08/03 11:52:46 alemmens Exp $ (in-package :rucksack) @@ -337,13 +337,13 @@ (setf ,transaction (transaction-start :rucksack ,rucksack , at args)) (let ((*transaction* ,transaction)) (with-simple-restart (abort "Abort ~S" ,transaction) - (setf ,result , at body) + (setf ,result (progn , 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))) + (return-from ,transaction (values ,result ,committed))) (unless ,committed (transaction-rollback ,transaction))))) ;; Normal exit from the above block -- we selected the RETRY restart. From alemmens at common-lisp.net Thu Aug 3 18:37:51 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 3 Aug 2006 14:37:51 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060803183751.0D8CF111C9@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv2990 Modified Files: cache.lisp transactions.lisp Log Message: Ensure unique transaction IDs (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/03 10:59:52 1.6 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/03 18:37:50 1.7 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.6 2006/08/03 10:59:52 alemmens Exp $ +;; $Id: cache.lisp,v 1.7 2006/08/03 18:37:50 alemmens Exp $ (in-package :rucksack) @@ -62,6 +62,11 @@ cache.")) +(defgeneric make-transaction-id (cache) + (:documentation "Returns a new transaction ID. The result is an +integer greater than all previous IDs.")) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; The cache ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -87,9 +92,10 @@ :documentation "A queue of the ids of all non-dirty objects that are currently in the cache memory. Whenever an object is retrieved (i.e. read), it's added to the queue.") - (highest-transaction-id :initarg :highest-transaction-id - :initform 0 - :accessor highest-transaction-id) + (last-timestamp :initform (get-universal-time) + :accessor last-timestamp) + (transaction-id-helper :initform -1 + :accessor transaction-id-helper) (transactions :initform (make-hash-table) :reader transactions :documentation "A mapping from transaction ids to @@ -115,6 +121,18 @@ (pathname (heap-stream (heap cache))) (cache-count cache)))) + +(defmethod make-transaction-id ((cache standard-cache)) + ;; This would allow for up to 100 transactions per millisecond + ;; The result is a bignum but it at least fits in 8 octets and + ;; can thus be serialized with SERIALIZE-BYTE-64. + (let ((timestamp (get-universal-time))) + (when (> timestamp (last-timestamp cache)) + (setf (last-timestamp cache) timestamp + (transaction-id-helper cache) -1)) + (+ (* timestamp 100000) + (mod (incf (transaction-id-helper cache)) 1000000)))) + ;; ;; Open/close/initialize ;; --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 11:52:46 1.5 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 18:37:50 1.6 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.5 2006/08/03 11:52:46 alemmens Exp $ +;; $Id: transactions.lisp,v 1.6 2006/08/03 18:37:50 alemmens Exp $ (in-package :rucksack) @@ -133,7 +133,7 @@ (rucksack standard-rucksack) &key &allow-other-keys) ;; Create new transaction. - (let* ((id (incf (highest-transaction-id cache))) + (let* ((id (make-transaction-id cache)) (transaction (make-instance 'standard-transaction :id id))) ;; Add to open transactions. (open-transaction cache transaction) From alemmens at common-lisp.net Fri Aug 4 10:26:24 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 4 Aug 2006 06:26:24 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060804102624.447EA52000@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv23361 Modified Files: heap.lisp serialize.lisp Log Message: Add missing SCAN-CONTENTS methods for efficiency (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/03 11:39:39 1.8 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/04 10:26:23 1.9 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.8 2006/08/03 11:39:39 alemmens Exp $ +;; $Id: heap.lisp,v 1.9 2006/08/04 10:26:23 alemmens Exp $ (in-package :rucksack) @@ -493,6 +493,9 @@ (error "Unexpected end of serialization buffer at ~D." scan-pointer))))) +(defmethod scan-byte ((stream serialization-buffer) &optional gc) + (declare (ignore gc)) + (deserialize-byte stream t)) ;; ;; Loading/saving buffers --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/03 10:59:52 1.4 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/04 10:26:23 1.5 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.4 2006/08/03 10:59:52 alemmens Exp $ +;; $Id: serialize.lisp,v 1.5 2006/08/04 10:26:23 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -210,6 +210,14 @@ (:method ((stream stream) &optional (eof-error-p t)) (read-byte stream eof-error-p nil))) +(defgeneric scan-byte (serializer &optional gc) + (:documentation "Skips an unsigned byte from the serializer.") + (:method ((serializer serializer) &optional gc) + (declare (ignore gc)) + (read-byte (serializer-stream serializer) t nil)) + (:method ((stream stream) &optional gc) + (declare (ignore gc)) + (read-byte stream t nil))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; SERIALIZE/DESERIALIZE/SCAN @@ -223,9 +231,6 @@ (defmethod scan-contents (marker serializer gc) ;; Default: just deserialize the contents but don't evacuate anything. - ;; EFFICIENCY: This is rather inefficient because it will reconstruct objects - ;; that don't really need to be reconstructed. Improve this by writing - ;; special methods for those objects (numbers, strings, etc.) (declare (ignore gc)) (deserialize-contents marker serializer)) @@ -321,6 +326,10 @@ ;;; Integers ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Serializing multiple bytes +;; + (defun serialize-byte-16 (integer stream) (serialize-byte (ldb (byte 8 0) integer) stream) (serialize-byte (ldb (byte 8 8) integer) stream)) @@ -349,6 +358,10 @@ (serialize-byte-32 most-significant stream))) +;; +;; Deserializing multiple bytes +;; + (defun deserialize-byte-16 (stream) (+ (deserialize-byte stream) (* (deserialize-byte stream) 256))) @@ -372,6 +385,39 @@ (+ (deserialize-byte-32 stream) (* (deserialize-byte-32 stream) #x100000000))) +;; +;; Scanning multiple bytes +;; + +(defun scan-byte-16 (stream &optional gc) + (declare (ignore gc)) + (scan-byte stream) + (scan-byte stream)) + +(defun scan-byte-24 (stream &optional gc) + (declare (ignore gc)) + (dotimes (i 3) + (scan-byte stream))) + +(defun scan-byte-32 (stream &optional gc) + (declare (ignore gc)) + (scan-byte-16 stream) + (scan-byte-16 stream)) + +(defun scan-byte-48 (stream &optional gc) + (declare (ignore gc)) + (scan-byte-24 stream) + (scan-byte-24 stream)) + +(defun scan-byte-64 (stream &optional gc) + (declare (ignore gc)) + (scan-byte-32 stream) + (scan-byte-32 stream)) + + +;; +;; Serializing integers +;; (defmethod serialize ((obj integer) stream) ;; Serialize integers with least-significant bytes first. @@ -414,6 +460,74 @@ (loop for position from (- nr-bits 8) downto 0 by 8 do (serialize-byte (ldb (byte 8 position) unsigned) stream)))))) + +;; +;; Scanning integers +;; + +(defmethod scan-contents ((marker (eql +positive-byte-8+)) stream gc) + (declare (ignore gc)) + (scan-byte stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-8+)) stream gc) + (declare (ignore gc)) + (scan-byte stream)) + +(defmethod scan-contents ((marker (eql +positive-byte-16+)) stream gc) + (declare (ignore gc)) + (scan-byte-16 stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-16+)) stream gc) + (declare (ignore gc)) + (scan-byte-16 stream)) + +(defmethod scan-contents ((marker (eql +positive-byte-24+)) stream gc) + (declare (ignore gc)) + (scan-byte-24 stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-24+)) stream gc) + (declare (ignore gc)) + (scan-byte-24 stream)) + +(defmethod scan-contents ((marker (eql +positive-byte-32+)) stream gc) + (declare (ignore gc)) + (scan-byte-32 stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-32+)) stream gc) + (declare (ignore gc)) + (scan-byte-32 stream)) + +(defmethod scan-contents ((marker (eql +positive-byte-48+)) stream gc) + (declare (ignore gc)) + (scan-byte-48 stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-48+)) stream gc) + (declare (ignore gc)) + (scan-byte-48 stream)) + +(defmethod scan-contents ((marker (eql +positive-byte-64+)) stream gc) + (declare (ignore gc)) + (scan-byte-64 stream)) + +(defmethod scan-contents ((marker (eql +negative-byte-64+)) stream gc) + (declare (ignore gc)) + (scan-byte-64 stream)) + +(defmethod scan-contents ((marker (eql +positive-integer+)) stream gc) + (declare (ignore gc)) + (let ((nr-bytes (deserialize stream))) + (assert (integerp nr-bytes)) + (dotimes (i nr-bytes) + (scan-byte stream)))) + +(defmethod scan-contents ((marker (eql +negative-integer+)) stream gc) + (scan-contents +positive-integer+ stream gc)) + + +;; +;; Deserializing integers +;; + (defun nr-octets (n) (ceiling (integer-length n) 8)) @@ -493,6 +607,10 @@ (defmethod deserialize-contents ((marker (eql +rational+)) stream) (/ (deserialize stream) (deserialize stream))) +(defmethod scan-contents ((marker (eql +rational+)) stream gc) + (scan stream gc) + (scan stream gc)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Floats ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -516,6 +634,11 @@ (sign (deserialize stream))) (* sign (scale-float (float significand 1.0L0) exponent)))) +(defmethod scan-contents ((marker (eql +float+)) stream gc) + ;; significand, exponent, sign + (dotimes (i 3) + (scan stream gc))) + #| For more efficient ways of serializing floats, we may want to use @@ -565,6 +688,10 @@ (defmethod deserialize-contents ((marker (eql +complex+)) stream) (complex (deserialize stream) (deserialize stream))) +(defmethod scan-contents ((marker (eql +complex+)) stream gc) + (scan stream gc) + (scan stream gc)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Conses ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -658,6 +785,10 @@ ;;; Strings and characters ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; Serializing characters +;; + (defmethod serialize ((char character) stream) (unless (= (char-code char) (char-int char)) (cerror "Serialize it anyway (without the attributes)." @@ -680,6 +811,10 @@ (t (serialize-marker +character+ stream) (serialize (char-code char) stream))))) +;; +;; Deserializing characters +;; + (defmethod deserialize-contents ((marker (eql +character+)) stream) (code-char (deserialize stream))) @@ -695,6 +830,33 @@ (defmethod deserialize-contents ((marker (eql +character-32+)) stream) (code-char (deserialize-byte-32 stream))) +;; +;; Scanning characters +;; + +(defmethod scan-contents ((marker (eql +character+)) stream gc) + (scan stream gc)) + +(defmethod scan-contents ((marker (eql +character-8+)) stream gc) + (declare (ignore gc)) + (scan-byte stream)) + +(defmethod scan-contents ((marker (eql +character-16+)) stream gc) + (declare (ignore gc)) + (scan-byte-16 stream)) + +(defmethod scan-contents ((marker (eql +character-24+)) stream gc) + (declare (ignore gc)) + (scan-byte-24 stream)) + +(defmethod scan-contents ((marker (eql +character-32+)) stream gc) + (declare (ignore gc)) + (scan-byte-32 stream)) + + +;; +;; Serializing strings +;; (defun max-character-code (string) "Returns the highest character code in string." @@ -750,6 +912,54 @@ do (funcall writer code stream))))) +;; +;; Scanning strings +;; + +(defmethod scan-contents ((marker (eql +simple-string+)) stream gc) + (scan-string t #'scan stream gc)) + +(defmethod scan-contents ((marker (eql +simple-string-8+)) stream gc) + (scan-string t #'scan-byte stream gc)) + +(defmethod scan-contents ((marker (eql +simple-string-16+)) stream gc) + (scan-string t #'scan-byte-16 stream gc)) + +(defmethod scan-contents ((marker (eql +simple-string-24+)) stream gc) + (scan-string t #'scan-byte-24 stream gc)) + +(defmethod scan-contents ((marker (eql +simple-string-32+)) stream gc) + (scan-string t #'scan-byte-32 stream gc)) + +(defmethod scan-contents ((marker (eql +string+)) stream gc) + (scan-string nil #'scan stream gc)) + +(defmethod scan-contents ((marker (eql +string-8+)) stream gc) + (scan-string nil #'scan-byte stream gc)) + +(defmethod scan-contents ((marker (eql +string-16+)) stream gc) + (scan-string nil #'scan-byte-16 stream gc)) + +(defmethod scan-contents ((marker (eql +string-24+)) stream gc) + (scan-string nil #'scan-byte-24 stream gc)) + +(defmethod scan-contents ((marker (eql +string-32+)) stream gc) + (scan-string nil #'scan-byte-32 stream gc)) + +(defun scan-string (simple-p character-code-scanner stream gc) + (scan-byte stream) ; skip type marker + (unless simple-p + ;; fill pointer and adjustable-p + (scan stream gc) + (scan stream gc)) + (loop repeat (deserialize stream) ; length + do (funcall character-code-scanner stream gc))) + + +;; +;; Deserializing strings +;; + (defmethod deserialize-contents ((marker (eql +simple-string+)) stream) (deserialize-string t #'deserialize stream)) @@ -831,9 +1041,19 @@ (defmethod deserialize-contents ((marker (eql +keyword+)) stream) (intern (deserialize stream) (find-package :keyword))) +(defmethod scan-contents ((marker (eql +keyword+)) stream gc) + ;; just the symbol name + (scan stream gc)) + + (defmethod deserialize-contents ((marker (eql +uninterned-symbol+)) stream) (make-symbol (deserialize stream))) +(defmethod scan-contents ((marker (eql +uninterned-symbol+)) stream gc) + ;; just the symbol name + (scan stream gc)) + + (defmethod deserialize-contents ((marker (eql +symbol+)) stream) ;; Q: Maybe we should always create the package if it doesn't exist ;; (without even asking?) @@ -847,6 +1067,11 @@ (make-package package-name)))) (intern symbol-name package)))) +(defmethod scan-contents ((marker (eql +symbol+)) stream gc) + ;; package name, then symbol name + (scan stream gc) + (scan stream gc)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Objects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -999,6 +1224,10 @@ :type type :version version))) +(defmethod scan-contents ((marker (eql +pathname+)) stream gc) + ;; skip host, device, directory, name, type, version + (dotimes (i 6) + (scan stream gc))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Hash tables From alemmens at common-lisp.net Fri Aug 4 10:38:00 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 4 Aug 2006 06:38:00 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060804103800.1E2715E0C7@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv25442 Modified Files: cache.lisp transactions.lisp Log Message: Use Erik Naggum's SANS function instead of REMF. (From Edi Weitz.) --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/03 18:37:50 1.7 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/04 10:37:59 1.8 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.7 2006/08/03 18:37:50 alemmens Exp $ +;; $Id: cache.lisp,v 1.8 2006/08/04 10:37:59 alemmens Exp $ (in-package :rucksack) @@ -139,12 +139,29 @@ (defvar *cache* nil) +(defun sans (plist &rest keys) + "Returns PLIST with keyword arguments from KEYS removed." + ;; stolen from Usenet posting <3247672165664225 at naggum.no> by Erik + ;; Naggum + (let ((sans ())) + (loop + (let ((tail (nth-value 2 (get-properties plist keys)))) + ;; this is how it ends + (unless tail + (return (nreconc sans plist))) + ;; copy all the unmatched keys + (loop until (eq plist tail) do + (push (pop plist) sans) + (push (pop plist) sans)) + ;; skip the matched key + (setq plist (cddr plist)))))) + (defun open-cache (directory &rest args &key (class 'standard-cache) &allow-other-keys) - (remf args ':class) (setq *cache* - (apply #'make-instance class :directory directory args))) + (apply #'make-instance class :directory directory + (sans args :class)))) (defmethod close-cache ((cache standard-cache) &key (commit t)) --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/03 18:37:50 1.6 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/04 10:37:59 1.7 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.6 2006/08/03 18:37:50 alemmens Exp $ +;; $Id: transactions.lisp,v 1.7 2006/08/04 10:37:59 alemmens Exp $ (in-package :rucksack) @@ -315,12 +315,11 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; WITH-TRANSACTION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - + (defmacro with-transaction ((&rest args &key (rucksack '(current-rucksack)) &allow-other-keys) &body body) - (remf args :rucksack) (let ((committed (gensym "COMMITTED")) (transaction (gensym "TRANSACTION")) (result (gensym "RESULT"))) @@ -334,7 +333,8 @@ ;; 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)) + (setf ,transaction (transaction-start :rucksack ,rucksack + ,@(sans args :rucksack))) (let ((*transaction* ,transaction)) (with-simple-restart (abort "Abort ~S" ,transaction) (setf ,result (progn , at body)) From alemmens at common-lisp.net Fri Aug 4 10:59:10 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 4 Aug 2006 06:59:10 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060804105910.4D7686200F@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv27617 Modified Files: p-btrees.lisp Log Message: Provide restarts for BTREE-SEARCH (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/05/25 13:01:38 1.4 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 10:59:10 1.5 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.4 2006/05/25 13:01:38 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.5 2006/08/04 10:59:10 alemmens Exp $ (in-package :rucksack) @@ -200,17 +200,31 @@ ERRORP option: if ERRORP is true, a btree-search-error is signalled; otherwise, DEFAULT-VALUE is returned.")) - + (defmethod btree-search (btree key &key (errorp t) (default-value nil)) - (if (slot-boundp btree 'root) - (node-search btree (slot-value btree 'root) key errorp default-value) - (not-found btree key errorp default-value))) + (restart-case + (if (slot-boundp btree 'root) + (node-search btree (slot-value btree 'root) key errorp default-value) + (not-found btree key errorp default-value)) + (use-value (value) + :report (lambda (stream) + (format stream "Specifiy a value to use this time for key ~S." key)) + :interactive (lambda () + (format t "Enter a value for key ~S: " key) + (multiple-value-list (eval (read)))) + value) + (store-value (value) + :report (lambda (stream) + (format stream "Specify a value to set key ~S to." key)) + :interactive (lambda () + (format t "Enter a value for key ~S: " key) + (multiple-value-list (eval (read)))) + (btree-insert btree key value)))) (defun not-found (btree key errorp default-value) (if (btree-unique-keys-p btree) (if errorp - ;; DO: Provide restarts here (USE-VALUE, STORE-VALUE, ...). (error 'btree-search-error :btree btree :key key) default-value) '())) From alemmens at common-lisp.net Fri Aug 4 11:06:04 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 4 Aug 2006 07:06:04 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060804110604.99FBE6200F@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv29619 Modified Files: p-btrees.lisp Log Message: Improve error reporting for btree errors (from Edi Weitz). --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 10:59:10 1.5 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 11:06:04 1.6 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.5 2006/08/04 10:59:10 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.6 2006/08/04 11:06:04 alemmens Exp $ (in-package :rucksack) @@ -57,14 +57,21 @@ ((btree :initarg :btree :reader btree-error-btree))) (define-condition btree-search-error (btree-error) - ((key :initarg :key :reader btree-error-key))) + ((key :initarg :key :reader btree-error-key)) + (:report (lambda (condition stream) + (format stream "An entry for the key ~S could not be found." + (btree-error-key condition))))) + (define-condition btree-insertion-error (btree-error) ((key :initarg :key :reader btree-error-key) (value :initarg :value :reader btree-error-value))) (define-condition btree-key-already-present-error (btree-insertion-error) - ()) + () + (:report (lambda (condition stream) + (format stream "There's already another value for the key ~S." + (btree-error-key condition))))) (define-condition btree-type-error (btree-error type-error) ()) From alemmens at common-lisp.net Fri Aug 4 22:04:43 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 4 Aug 2006 18:04:43 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060804220443.8E5BE6200F@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv27309 Modified Files: objects.lisp p-btrees.lisp package.lisp test.lisp Log Message: Clean up btree code. Add BTREE-DELETE. (From Edi Weitz.) --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/05/24 20:45:09 1.4 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/04 22:04:43 1.5 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.4 2006/05/24 20:45:09 alemmens Exp $ +;; $Id: objects.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $ (in-package :rucksack) @@ -265,10 +265,10 @@ :end1 end1 :start2 start2 :end2 end2) - ;; DO: WE MUST TOUCH THE OBJECT HERE!! + ;; Touch the vector because it has changed. + (cache-touch-object vector-1 (cache vector-1)) vector-1) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Full fledged persistent objects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 11:06:04 1.6 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 22:04:43 1.7 @@ -1,15 +1,16 @@ -;; $Id: p-btrees.lisp,v 1.6 2006/08/04 11:06:04 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.7 2006/08/04 22:04:43 alemmens Exp $ (in-package :rucksack) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; b-trees: API +;;; Btrees: API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| ;; Btrees #:btree - #:btree-key< #:btree-key= #:btree-value= + #:btree-key< #:btree-key<= #:btree-key= #:btree-key>= #:btree-key> + #:btree-value= #:btree-max-node-size #:btree-unique-keys-p #:btree-key-type #:btree-value-type #:btree-node-class @@ -18,7 +19,7 @@ #:btree-node ;; Functions - #:btree-search #:btree-insert #:map-btree + #:btree-search #:btree-insert #:btree-delete #:map-btree ;; Conditions #:btree-error #:btree-search-error #:btree-insertion-error @@ -82,7 +83,6 @@ (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 :documentation "This is only used for btrees with non-unique keys.") ;; @@ -109,10 +109,10 @@ (root :accessor btree-root)) (:metaclass persistent-class)) - + (defmethod initialize-instance :around ((btree btree) &rest initargs - &key key< key= value= + &key key< value= &allow-other-keys) ;; It must be possible to save these btrees in the cache, but ;; that will not work for function objects because they can't be @@ -120,12 +120,39 @@ ;; name a function. For program-independent databases you should ;; only use symbols from the COMMON-LISP package. (declare (ignore initargs)) - (if (and (symbolp key<) (symbolp key=) (symbolp value=)) + (if (and (symbolp key<) (symbolp value=)) (call-next-method) - (error "The :key<, :key= and :value= initargs for persistent btrees + (error "The :key< and :value= initargs for persistent btrees must be symbols naming a function, otherwise they can't be saved on disk."))) +;; +;; Comparison functions that can be deduced from KEY< (because the +;; btree keys have a total order). +;; + +(defmethod btree-key= ((btree btree)) + (let ((key< (btree-key< btree))) + (lambda (key1 key2) + (and (not (funcall key< key1 key2)) + (not (funcall key< key2 key1)))))) + +(defmethod btree-key>= ((btree btree)) + (lambda (key1 key2) + (funcall (btree-key< btree) key2 key1))) + +(defmethod btree-key<= ((btree btree)) + (let ((key< (btree-key< btree))) + (lambda (key1 key2) + (or (funcall key< key1 key2) + (not (funcall key< key2 key1)))))) + +(defmethod btree-key> ((btree btree)) + (let ((key< (btree-key< btree))) + (lambda (key1 key2) + (and (not (funcall key< key1 key2)) + (funcall key< key2 key1))))) + ;; ;; The next two classes are for internal use only, so we don't bother @@ -140,7 +167,7 @@ sorted by KEY<. No two keys can be the same. For leaf nodes of btrees with non-unique-keys, the value part is actually a list of values. For intermediate nodes, the value is a child node. All keys in the -child node will be KEY< the child node's key in the parent node.") +child node will be KEY<= the child node's key in the parent node.") (index-count :initform 0 :accessor btree-node-index-count :documentation "The number of key/value pairs in the index vector.") @@ -187,7 +214,7 @@ (defmethod initialize-instance :after ((node btree-node) &key btree &allow-other-keys) (setf (btree-node-index node) (p-make-array (btree-max-node-size btree) - :initial-element nil) + :initial-element nil) (btree-node-index-count node) 0)) @@ -195,6 +222,24 @@ (print-unreadable-object (node stream :type t :identity t) (format stream "with ~D pairs" (btree-node-index-count node)))) +;; +;; Debugging +;; + +(defun display-node (node) + (pprint (node-as-cons node))) + +(defun node-as-cons (node) + (loop with index = (btree-node-index node) + with leaf-p = (btree-node-leaf-p node) + for i below (btree-node-index-count node) + for binding = (p-aref index i) + collect (list (binding-key binding) + (if leaf-p + (binding-value binding) + (node-as-cons (binding-value binding)))))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -211,7 +256,7 @@ (defmethod btree-search (btree key &key (errorp t) (default-value nil)) (restart-case (if (slot-boundp btree 'root) - (node-search btree (slot-value btree 'root) key errorp default-value) + (node-search btree (btree-root btree) key errorp default-value) (not-found btree key errorp default-value)) (use-value (value) :report (lambda (stream) @@ -239,14 +284,23 @@ ;; ;; Node-search ;; + +(defun find-binding-in-node (key node btree) + (let ((index-count (btree-node-index-count node))) + (and (plusp index-count) + (loop with array = (btree-node-index node) + with btree-key< = (btree-key< btree) + for i from 0 below index-count + for candidate = (p-aref array i) + for candidate-key = (binding-key candidate) + while (funcall btree-key< candidate-key key) + finally (when (funcall (btree-key= btree) key candidate-key) + (return candidate)))))) (defgeneric node-search (btree node key errorp default-value) (:method ((btree btree) (node btree-node) key errorp default-value) (if (btree-node-leaf-p node) - (let ((binding (p-find key (btree-node-index node) - :key #'binding-key - :test (btree-key= btree) - :end (btree-node-index-count node)))) + (let ((binding (find-binding-in-node key node btree))) (if binding (binding-value binding) (not-found btree key errorp default-value))) @@ -258,17 +312,15 @@ "Returns the subnode that contains more information for the given key." ;; Find the first binding with a key >= the given key and return ;; the corresponding subnode. - ;; DO: We should probably use binary search for this. - (loop for i below (btree-node-index-count node) - do (let ((binding (node-binding node i))) - (cond ((= i (1- (btree-node-index-count node))) - ;; We're at the last binding. - (return-from find-subnode (binding-value binding))) - ((funcall (btree-key< btree) key (binding-key binding)) - (let ((next-binding (node-binding node (1+ i)))) - (if (funcall (btree-key= btree) key (binding-key next-binding)) - (return-from find-subnode (binding-value next-binding)) - (return-from find-subnode (binding-value binding)))))))) + ;; EFFICIENCY: We should probably use binary search for this. + (loop with btree-key< = (btree-key< btree) + with last-index = (1- (btree-node-index-count node)) + for i to last-index + for binding = (node-binding node i) + when (or (= i last-index) + (funcall btree-key< key (binding-key binding)) + (not (funcall btree-key< (binding-key binding) key))) + do (return-from find-subnode (binding-value binding))) (error "This shouldn't happen.")) @@ -292,7 +344,7 @@ :expected-type (btree-value-type btree))) ;; Do the real work. (if (slot-boundp btree 'root) - (btree-node-insert btree (slot-value btree 'root) nil key value if-exists) + (btree-node-insert btree (btree-root btree) (list nil) key value if-exists) ;; Create a root. (let ((leaf (make-instance (btree-node-class btree) :btree btree @@ -301,7 +353,7 @@ (let* ((empty-leaf (make-instance (btree-node-class btree) :btree btree :leaf-p t)) - (root (make-root btree key empty-leaf 'key-irrelevant leaf))) + (root (make-root btree key leaf 'key-irrelevant empty-leaf))) (setf (btree-root btree) root)))) ;; Return the inserted value. value) @@ -314,6 +366,7 @@ (declare (ignore value)) (when prev-key (unless (funcall (btree-key< btree) prev-key key) + (display-node (btree-root btree)) (error "Btree inconsistency between ~D and ~D" prev-key key))) (setq prev-key key))))) @@ -330,17 +383,13 @@ ;; Node insert ;; -(defgeneric btree-node-insert (btree node parent key value if-exists)) +(defgeneric btree-node-insert (btree node parent-stack key value if-exists)) -(defmethod btree-node-insert ((btree btree) (node btree-node) parent key value if-exists) - (cond ((node-almost-full-p btree node) - (split-btree-node btree node parent) - (btree-insert btree key value :if-exists if-exists)) - ((btree-node-leaf-p node) - (leaf-insert btree node key value if-exists)) +(defmethod btree-node-insert ((btree btree) (node btree-node) parent-stack key value if-exists) + (cond ((btree-node-leaf-p node) + (leaf-insert btree node parent-stack key value if-exists)) (t (let ((subnode (find-subnode btree node key))) - (btree-node-insert btree subnode node key value if-exists))))) - + (btree-node-insert btree subnode (cons node parent-stack) key value if-exists))))) (defun smallest-key (node) (if (btree-node-leaf-p node) @@ -353,50 +402,52 @@ (biggest-key (binding-value (node-binding node (1- (btree-node-index-count node))))))) -(defun split-btree-node (btree node parent) +(defun split-btree-node (btree node parent-stack key) ;; The node is (almost) full. ;; Create two new nodes and divide the current node-index over ;; these two new nodes. (let* ((split-pos (floor (btree-node-index-count node) 2)) (left (make-instance (btree-node-class btree) - :parent parent :btree btree :leaf-p (btree-node-leaf-p node))) (right (make-instance (btree-node-class btree) - :parent parent :btree btree :leaf-p (btree-node-leaf-p node)))) ;; Divide the node over the two new nodes. (p-replace (btree-node-index left) (btree-node-index node) - :end2 split-pos) + :end2 split-pos) (p-replace (btree-node-index right) (btree-node-index node) - :start2 split-pos) + :start2 split-pos) (setf (btree-node-index-count left) split-pos (btree-node-index-count right) (- (btree-node-index-count node) split-pos)) ;; - (let* ((node-pos (and parent (node-position node parent))) - (parent-binding (and parent (node-binding parent node-pos))) - (left-key - ;; The key that splits the two new nodes. - (smallest-key right)) - (right-key - (if (null parent) - 'key-irrelevant - (binding-key parent-binding)))) - (if (p-eql node (btree-root btree)) - ;; Make a new root. - (setf (btree-root btree) (make-root btree left-key left right-key right)) - ;; Replace the original subnode by the left-child and - ;; add a new-binding with new-key & right-child. - (progn - (setf (binding-key parent-binding) left-key - (binding-value parent-binding) left) - ;; Insert a new binding for the right node. - (insert-new-binding parent (1+ node-pos) right-key right)))))) - + (let ((left-key + ;; The key that splits the two new nodes. + (biggest-key left))) + (cond ((p-eql node (btree-root btree)) + ;; Make a new root. + (setf (btree-root btree) + (make-root btree left-key left 'key-irrelevant right))) + (t + (let* ((parent (first parent-stack)) + (node-pos (node-position node parent)) + (parent-binding (node-binding parent node-pos)) + (old-key (binding-key parent-binding))) + (when (node-full-p btree parent) + (setq parent (split-btree-node btree parent (rest parent-stack) old-key) + node-pos (node-position node parent))) + ;; Replace the original subnode by the left-child and + ;; add a new-binding with new-key & right-child. + (setf (binding-key parent-binding) left-key + (binding-value parent-binding) left) + ;; Insert a new binding for the right node. + (insert-new-binding parent (1+ node-pos) old-key right)))) + ;; Return the node that's relevant for KEY + (if (or (eq key 'key-irrelevant) + (funcall (btree-key< btree) left-key key)) + right + left)))) -(defun parent-binding (node parent) - (node-binding parent (node-position node parent))) (defun node-position (node parent) (p-position node (btree-node-index parent) @@ -405,33 +456,40 @@ (defun insert-new-binding (node position key value) + ;; This function must only be called if we know that the index isn't + ;; full already (unless (>= position (btree-node-index-count node)) ;; Make room by moving bindings to the right. (let ((node-index (btree-node-index node)) (length (btree-node-index-count node))) (p-replace node-index node-index - :start1 (1+ position) :end1 (1+ length) - :start2 position :end2 length))) + :start1 (1+ position) :end1 (1+ length) + :start2 position :end2 length))) ;; Insert new binding. (setf (node-binding node position) (make-binding key value)) (incf (btree-node-index-count node))) +;; +;; Debugging +;; + (defun check-node (btree node) (loop for i below (1- (btree-node-index-count node)) for left-key = (binding-key (node-binding node i)) for right-key = (binding-key (node-binding node (1+ i))) do (unless (or (eql right-key 'key-irrelevant) (funcall (btree-key< btree) left-key right-key)) + (display-node node) (error "Inconsistent node ~S" node)))) +;; +;; Leaf insert +;; -(defun leaf-insert (btree leaf key value if-exists) - (let ((binding (p-find key (btree-node-index leaf) - :key #'binding-key - :test (btree-key= btree) - :end (btree-node-index-count leaf)))) +(defun leaf-insert (btree leaf parent-stack key value if-exists) + (let ((binding (find-binding-in-node key leaf btree))) (if binding ;; Key already exists. (if (btree-unique-keys-p btree) @@ -452,21 +510,169 @@ (unless (p-find value (binding-value binding) :test (btree-value= btree)) (setf (binding-value binding) (p-cons value (binding-value binding))))) - ;; The key doesn't exist yet. Create a new binding and add it to the - ;; leaf index in the right position. - (let ((new-position (p-position key (btree-node-index leaf) - :test (btree-key< btree) - :key #'binding-key - :end (btree-node-index-count leaf)))) - (insert-new-binding leaf - (or new-position (btree-node-index-count leaf)) - key - (make-leaf-value btree value)))))) - - -(defun node-almost-full-p (btree node) - (>= (btree-node-index-count node) (1- (btree-max-node-size btree)))) + ;; The key doesn't exist yet. Create a new binding and add it to the + ;; leaf index in the right position. + (progn + (when (node-full-p btree leaf) [162 lines skipped] --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/05/18 12:46:57 1.3 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/04 22:04:43 1.4 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $ +;; $Id: package.lisp,v 1.4 2006/08/04 22:04:43 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -78,12 +78,13 @@ ;; Btrees #:btree - #:btree-key< #:btree-key= #:btree-value= + #:btree-key< #:btree-key<= #:btree-key= #:btree-key>= #:btree-key> + #:btree-value= #:btree-max-node-size #:btree-unique-keys-p #:btree-key-type #:btree-value-type #:btree-node-class #:btree-node ;; Functions - #:btree-search #:btree-insert #:map-btree + #:btree-search #:btree-insert #:btree-delete #:map-btree ;; Conditions #:btree-error #:btree-search-error #:btree-insertion-error #:btree-key-already-present-error #:btree-type-error --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/05/25 13:01:38 1.4 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/04 22:04:43 1.5 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.4 2006/05/25 13:01:38 alemmens Exp $ +;; $Id: test.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $ (in-package :test-rucksack) @@ -153,29 +153,102 @@ ;; 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 shuffle (array) + (loop with n = (array-dimension array 0) + repeat n + for i = (random n) + for j = (random n) + when (/= i j) + do (rotatef (aref array i) (aref array j)))) + +(defun check-size (btree expected) + (format t "~&Counting~%") + (let ((count 0)) + (map-btree btree + (lambda (key value) + (declare (ignore key value)) + (incf count))) + (unless (= count expected) + (error "Wrong btree size - expected ~A, got ~A." + expected count)))) + +(defun check-order (btree) + (format t "~&Checking order~%") + (rs::check-btree btree)) + +(defun check-contents (btree) + (format t "~&Checking contents~%") + (map-btree btree + (lambda (key value) + (unless (string= value (format nil "~R" key)) + (error "Value mismatch: Expected ~S, got ~S." + (format nil "~R" key) value))))) + +(defmacro with-transaction* ((&rest args) &body body) + `(with-transaction ,args + (prog1 (progn , at body) + (format t "~&Committing...")))) + +(defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) check-contents) + ;; Create a rucksack with a btree of size N that maps random + ;; integers to the equivalent strings as a cardinal English number. + ;; Use node size NODE-SIZE for the btree. + ;; If DELETE is not NIL, delete and reinsert that number of elements + ;; as well. + (let ((array (make-array n :initial-contents (loop for i below n collect i)))) + (shuffle array) + (with-rucksack (rucksack *test-suite* :if-exists :supersede) + (with-transaction* () + (format t "~&Inserting~%") + (let ((btree (make-instance 'btree :value= 'string-equal + :max-node-size node-size))) + (loop for key across array + for i from 1 + when (zerop (mod i 1000)) + do (format t "~D " i) + do (btree-insert btree key (format nil "~R" key))) + (add-rucksack-root btree rucksack)))) + (with-rucksack (rucksack *test-suite*) + (with-transaction () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree n) + (when check-contents + (check-contents btree)))) + (when delete + (shuffle array) + (setq array (subseq array 0 delete)) + (shuffle array) + (with-transaction* () + (format t "~&Deleting~%") + (let ((btree (first (rucksack-roots rucksack)))) + (dotimes (i delete) + (when (zerop (mod (1+ i) 1000)) + (format t "~D " (1+ i))) + (btree-delete btree (aref array i))) + (check-order btree) + (check-contents btree))) + (with-transaction* () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree (- n delete)) + (when check-contents + (check-contents btree)) + (format t "~&Reinserting~%") + (shuffle array) + (dotimes (i delete) + (when (zerop (mod (1+ i) 1000)) + (format t "~D " (1+ i))) + (let ((key (aref array i))) + (btree-insert btree key (format nil "~R" key)))))) + (with-transaction () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree n) + (when check-contents + (check-contents btree))))))) + :ok) + (defun test-btree-map (&key (display t)) @@ -187,3 +260,34 @@ (lambda (key value) (when display (format t "~&~D -> ~A~%" key value)))))))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Garbage collector +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun check-gc (n) + (with-rucksack (rucksack *test-suite* :if-exists :supersede) + (with-transaction () + ;; after this, INNER can be reached directly from the root + (let* ((inner (p-cons "Waldorf" "Statler")) + (root (p-cons 42 inner))) + (add-rucksack-root root rucksack))) + (with-transaction () + (let* ((root (first (rucksack-roots rucksack))) + (inner (p-cdr root)) + (array (p-make-array n))) + ;; after this, INNER can't be reached from the root anymore + (setf (p-cdr root) 43) + ;; now let the GC do some work + (dotimes (i n) + (let ((string (format nil "~R" i))) + (setf (p-aref array i) (p-cons string string)))) + ;; hook INNER back to the root again before we finish the + ;; transaction + (setf (p-car root) array + (p-cdr root) (p-cons 'bar (p-cons 'foo inner))))) + (with-transaction () + (let* ((root (first (rucksack-roots rucksack))) + (inner (p-cdr (p-cdr (p-cdr root))))) + ;; we expect the list ("Waldorf" "Statler") here + (list (p-car inner) (p-cdr inner)))))) From alemmens at common-lisp.net Tue Aug 8 13:35:18 2006 From: alemmens at common-lisp.net (alemmens) Date: Tue, 8 Aug 2006 09:35:18 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060808133518.E7ADD4D009@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv23265 Modified Files: garbage-collector.lisp index.lisp objects.lisp p-btrees.lisp package.lisp test.lisp transactions.lisp Log Message: Fix bugs in BTREE-DELETE and SPLIT-BTREE-NODE. Rename BTREE-DELETE to BTREE-DELETE-KEY and implement BTREE-DELETE for btrees with non-unique keys. Add stress test for btrees. Implement the :MIN, :MAX, :INCLUDE-MIN, :INCLUDE-MAX and :ORDER arguments for BTREE-MAP. Add some more CL mirror functions like P-MAPCAR, P-MAPC, P-DELETE-IF, etcetera. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/03 11:39:39 1.14 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 13:35:18 1.15 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.14 2006/08/03 11:39:39 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.15 2006/08/08 13:35:18 alemmens Exp $ (in-package :rucksack) @@ -58,12 +58,13 @@ (grow-size :initarg :grow-size :initform nil :accessor grow-size - :documentation "Specifies a minimum amount to grow the -heap when it needs to grow. If 'grow size' is an integer, the expected -growth rate is additive and the integer is the number of octets to -add; if it is a float, the expected growth rate for the heap is -multiplicative and the float is the ratio of the new size to the old -size. (The actual size might be rounded up.)"))) + :documentation + "Specifies a minimum amount to grow the heap when it needs to grow. +If 'grow size' is an integer, the expected growth rate is additive and +the integer is the number of octets to add; if it is a float, the +expected growth rate for the heap is multiplicative and the float is +the ratio of the new size to the old size. (The actual size might be +rounded up.)"))) (defparameter *initial-heap-size* (* 1024 1024) --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/08 13:35:18 1.3 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: index.lisp,v 1.3 2006/08/08 13:35:18 alemmens Exp $ (in-package :rucksack) @@ -62,7 +62,7 @@ ;; An index spec is a symbol or a list starting with a symbol ;; and followed by a plist of keywords and values. -;; Examples: BTREE, (BTREE :KEY< < :KEY= = :VALUE= EQL) +;; Examples: BTREE, (BTREE :KEY< < :VALUE= EQL) (defun make-index (index-spec) (if (symbolp index-spec) --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/04 22:04:43 1.5 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/08 13:35:18 1.6 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $ +;; $Id: objects.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $ (in-package :rucksack) @@ -161,8 +161,12 @@ ;; DO: Other array functions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Conses +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + ;; -;; Cons +;; Basics ;; (defclass persistent-cons (persistent-data) @@ -195,11 +199,77 @@ (p-cons (car objects) (apply #'p-list (cdr objects))))) +(defun unwrap-persistent-list (list) + "Converts a persistent list to a 'normal' Lisp list." + (loop until (p-endp list) + collect (p-car list) + do (setq list (p-cdr list)))) ;; +;; Other functions from chapter 14 of the spec. +;; + +(defmethod p-endp ((object (eql nil))) + t) + +(defmethod p-endp ((object persistent-cons)) + nil) + +(defmethod p-endp ((object t)) + (error 'type-error + :datum object + :expected-type '(or null persistent-cons))) + +(defmethod p-cddr ((cons persistent-cons)) + (p-cdr (p-cdr cons))) + +(defun p-mapcar (function list) + ;; DO: Accept more than one list argument. + (let ((result '())) + (loop while list do + (setq result (p-cons (funcall function (p-car list)) + result) + list (p-cdr list))) + result)) + +(defun p-mapc (function list) + ;; DO: Accept more than one list argument. + (let ((tail list)) + (loop while tail do + (funcall function (p-car tail)) + (setq tail (p-cdr tail))) + list)) + +(defun p-maplist (function list) + ;; DO: Accept more than one list argument. + (let ((result '())) + (loop while list do + (setq result (p-cons (funcall function list) result) + list (p-cdr list))) + result)) + +(defun p-mapl (function list) + ;; DO: Accept more than one list argument. + (let ((tail list)) + (loop while tail do + (funcall function tail) + (setq tail (p-cdr tail))) + list)) + +(defun p-member-if (predicate list &key key) + (unless key + (setq key #'identity)) + (p-mapl (lambda (tail) + (when (funcall predicate (funcall key (p-car tail))) + (return-from p-member-if tail))) + list) + nil) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Persistent sequence functions ;; (Just a start...) -;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun check-p-vector (persistent-array function-name) (unless (= 1 (length (p-array-dimensions persistent-array))) @@ -211,6 +281,15 @@ (check-p-vector vector 'p-length) (first (p-array-dimensions vector))) +(defmethod p-length ((list persistent-cons)) + ;; DO: Check for circular lists. + (let ((result 0)) + (p-mapc (lambda (pair) + (declare (ignore pair)) + (incf result)) + list) + result)) + (defmethod p-find (value (vector persistent-array) &key (key #'identity) (test #'p-eql) (start 0) (end nil)) @@ -226,12 +305,11 @@ &key (key #'identity) (test #'p-eql) (start 0) (end nil)) ;; Move list to start position. - (setq list - (loop repeat start - do (setq list (p-cdr list)))) + (loop repeat start + do (setq list (p-cdr list))) ;; The real work. (loop for i from start do - (if (or (endp list) (and end (= i end))) + (if (or (p-endp list) (and end (= i end))) (return-from p-find nil) (let ((elt (funcall key (p-car list)))) (if (funcall test value elt) @@ -269,6 +347,43 @@ (cache-touch-object vector-1 (cache vector-1)) vector-1) + +(defmethod p-delete-if (test (list persistent-cons) + &key (from-end nil) (start 0) end count key) + ;; DO: Implement FROM-END. + ;; DO: Write tests. + (declare (ignore from-end)) + (unless key + (setq key #'identity)) + ;; Move list to start position. + (let ((tail list) + (prev nil)) + (loop repeat start + do (setq prev tail + tail (p-cdr tail))) + ;; The real work. + (let ((nr-deleted 0)) + (loop for i from start do + (if (or (p-endp tail) + (and end (= i end)) + (and count (>= nr-deleted count))) + (return-from p-delete-if list) + (if (funcall test (funcall key (p-car tail))) + ;; Delete the element. + (progn + (if prev + (setf (p-cdr prev) (p-cdr tail)) + (setq list (p-cdr tail))) + ;; Keep count. + (incf nr-deleted)) + ;; Don't delete anything. + (setq prev tail))) + ;; Keep moving. + (setq tail (p-cdr tail))))) + ;; Return the (possibly modified) list. + list) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Full fledged persistent objects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/04 22:04:43 1.7 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/08 13:35:18 1.8 @@ -1,7 +1,11 @@ -;; $Id: p-btrees.lisp,v 1.7 2006/08/04 22:04:43 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $ (in-package :rucksack) +;; DO: We probably need a lock per btree. Each btree operation should +;; be wrapped in a WITH-LOCK to make sure that nobody else changes the btree +;; halfway during a btree operation. + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Btrees: API ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -14,12 +18,14 @@ #:btree-max-node-size #:btree-unique-keys-p #:btree-key-type #:btree-value-type #:btree-node-class + #:btree-nr-keys #:btree-nr-values ;; Nodes #:btree-node ;; Functions - #:btree-search #:btree-insert #:btree-delete #:map-btree + #:btree-search #:btree-insert #:btree-delete #:btree-delete-key + #:map-btree #:map-btree-keys ;; Conditions #:btree-error #:btree-search-error #:btree-insertion-error @@ -27,9 +33,99 @@ #:btree-error-btree #:btree-error-key #:btree-error-value |# +(defgeneric btree-nr-keys (btree) + (:documentation "Returns the number of keys in a btree.")) + +(defgeneric btree-nr-values (btree) + (:documentation "Returns the number of values in a btree.")) + + +(defgeneric btree-search (btree key &key errorp default-value) + (:documentation + "Returns the value (or persistent list of values, for btrees that +don't have unique keys) associated with KEY. If the btree has +non-unique keys and no value is found, the empty list is returned. If +the btree has unique keys and no value is found, the result depends on +the ERRORP option: if ERRORP is true, a btree-search-error is +signalled; otherwise, DEFAULT-VALUE is returned.")) + +(defgeneric btree-insert (btree key value &key if-exists) + (:documentation + "Adds an association from KEY to VALUE to a btree. + +IF-EXISTS can be either :OVERWRITE (default) or :ERROR. + +If the btree has unique keys (see BTREE-UNIQUE-KEYS-P) and KEY is +already associated with another (according to BTREE-VALUE=) value, the +result depends on the IF-EXISTS option: if IF-EXISTS is :OVERWRITE, +the old value is overwriten; if IF-EXISTS is :ERROR, a +BTREE-KEY-ALREADY-PRESENT-ERROR is signaled. + +For btrees with non-unique keys, the IF-EXISTS option is ignored and +VALUE is just added to the list of values associated with KEY (unless +VALUE is already associated with KEY; in that case nothing +happens).")) + + +(defgeneric btree-delete (btree key value &key if-does-not-exist) + (:documentation + "Removes an association from KEY to VALUE from a btree. +IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR. +If there is no association from KEY to VALUE and IF-DOES-NOT-EXIST +is :ERROR, a BTREE-DELETION-ERROR is signaled.")) -#+nil(declaim (optimize (debug 3) (speed 0) (space 0))) +(defgeneric btree-delete-key (btree key &key if-does-not-exist) + (:documentation + "Removes KEY and all associated values from a btree. +IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR. + +For a btree with unique-keys that contains a value for KEY, this +operation is identical to + + (btree-delete btree key (btree-search btree key)) + +For a btree with non-unique keys, it's identical to + + (dolist (value (unwrap-persistent-list (btree-search btree key))) + (btree-delete btree key value))")) + + +(defgeneric map-btree (btree function + &key min max include-min include-max order) + (:documentation + "Calls FUNCTION for all key/value associations in the btree where +key is in the specified interval (this means that FUNCTION can be +called with the same key more than once for btrees with non-unique +keys). FUNCTION must be a binary function; the first argument is the +btree key, the second argument is an associated value. + +MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The +interval is left-open if MIN is nil, right-open if MAX is nil. The +interval is inclusive on the left if INCLUDE-MIN is true (and +exclusive on the left otherwise). The interval is inclusive on the +right if INCLUDE-MAX is true (and exclusive on the right otherwise). + +ORDER is either :ASCENDING (default) or :DESCENDING.")) + + +(defgeneric map-btree-keys (btree function + &key min max include-min include-max order) + (:documentation + "Calls FUNCTION for all keys in the btree where key is in the +specified interval. FUNCTION must be a binary function; the first +argument is the btree key, the second argument is the btree value (or +persistent list of values, for btrees with non-unique keys). FUNCTION +will be called exactly once for each key in the btree. + +MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The +interval is left-open if MIN is nil, right-open if MAX is nil. The +interval is inclusive on the left if INCLUDE-MIN is true (and +exclusive on the left otherwise). The interval is inclusive on the +right if INCLUDE-MAX is true (and exclusive on the right otherwise). + +ORDER is either :ASCENDING (default) or :DESCENDING.")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; B-trees @@ -77,6 +173,15 @@ (define-condition btree-type-error (btree-error type-error) ()) +(define-condition btree-deletion-error (btree-error) + ((key :initarg :key :reader btree-error-key) + (value :initarg :value :reader btree-error-value)) + (:report (lambda (condition stream) + (format stream "Can't delete the association from ~S to ~S +because it doesn't exist." + (btree-error-key condition) + (btree-error-value condition))))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Classes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -92,12 +197,13 @@ (max-node-size :initarg :max-node-size :reader btree-max-node-size :initform 100 - :documentation "An integer specifying the preferred maximum number -of keys per btree node.") + :documentation "An integer specifying the preferred +maximum number of keys per btree node.") (unique-keys-p :initarg :unique-keys-p :reader btree-unique-keys-p :initform t - :documentation "If false, one key can correspond to more than one value.") + :documentation + "If false, one key can correspond to more than one value.") (key-type :initarg :key-type :reader btree-key-type :initform t @@ -139,7 +245,7 @@ (defmethod btree-key>= ((btree btree)) (lambda (key1 key2) - (funcall (btree-key< btree) key2 key1))) + (not (funcall (btree-key< btree) key1 key2)))) (defmethod btree-key<= ((btree btree)) (let ((key< (btree-key< btree))) @@ -175,6 +281,32 @@ (:metaclass persistent-class)) ;; +;; Info functions +;; + +(defmethod btree-nr-keys ((btree btree)) + (if (slot-boundp btree 'root) + (btree-node-nr-keys (btree-root btree)) + 0)) + +(defmethod btree-node-nr-keys ((node btree-node)) + (if (btree-node-leaf-p node) + (btree-node-index-count node) + (loop for i below (btree-node-index-count node) + sum (btree-node-nr-keys (binding-value (node-binding node i)))))) + + +(defmethod btree-nr-values ((btree btree)) + (if (btree-unique-keys-p btree) + (btree-nr-keys btree) + (let ((result 0)) + (map-btree-keys btree + (lambda (key p-values) + (declare (ignore key)) + (incf result (p-length p-values)))) + result))) + +;; ;; Bindings ;; @@ -220,7 +352,7 @@ (defmethod print-object ((node btree-node) stream) (print-unreadable-object (node stream :type t :identity t) - (format stream "with ~D pairs" (btree-node-index-count node)))) + (format stream "with ~D bindings" (btree-node-index-count node)))) ;; ;; Debugging @@ -229,30 +361,56 @@ (defun display-node (node) (pprint (node-as-cons node))) -(defun node-as-cons (node) +(defun node-as-cons (node &optional (unique-keys t)) (loop with index = (btree-node-index node) with leaf-p = (btree-node-leaf-p node) for i below (btree-node-index-count node) for binding = (p-aref index i) collect (list (binding-key binding) (if leaf-p - (binding-value binding) + (if unique-keys + (binding-value binding) + (unwrap-persistent-list (binding-value binding))) (node-as-cons (binding-value binding)))))) +(defun btree-as-cons (btree) + (and (slot-value btree 'root) + (node-as-cons (btree-root btree) (btree-unique-keys-p btree)))) + + +;; +;; Depth and balance +;; + +(defmethod node-max-depth ((node btree-node)) + (if (btree-node-leaf-p node) + 0 + (loop for i below (btree-node-index-count node) + for binding = (node-binding node i) + maximize (1+ (node-max-depth (binding-value binding)))))) + +(defmethod node-min-depth ((node btree-node)) + (if (btree-node-leaf-p node) + 0 + (loop for i below (btree-node-index-count node) + for binding = (node-binding node i) + minimize (1+ (node-min-depth (binding-value binding)))))) + +(defmethod btree-depths ((btree btree)) + (if (slot-value btree 'root) + (values (node-min-depth (btree-root btree)) + (node-max-depth (btree-root btree))) + (values 0 0))) + +(defmethod btree-balanced-p ((btree btree)) + (multiple-value-bind (min max) + (btree-depths btree) + (<= (- max min) 1))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Search ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric btree-search (btree key &key errorp default-value) - (:documentation "Returns the value (or list of values, for btrees -that don't have unique keys) corresponding to KEY. If the btree has -non-unique keys and no value is found, the empty list is returned. If -the btree has unique keys and no value is found, the result depends on -ERRORP option: if ERRORP is true, a btree-search-error is signalled; -otherwise, DEFAULT-VALUE is returned.")) - - (defmethod btree-search (btree key &key (errorp t) (default-value nil)) (restart-case (if (slot-boundp btree 'root) @@ -260,7 +418,7 @@ (not-found btree key errorp default-value)) (use-value (value) :report (lambda (stream) - (format stream "Specifiy a value to use this time for key ~S." key)) + (format stream "Specify a value to use this time for key ~S." key)) :interactive (lambda () (format t "Enter a value for key ~S: " key) (multiple-value-list (eval (read)))) @@ -285,28 +443,19 @@ ;; Node-search ;; -(defun find-binding-in-node (key node btree) - (let ((index-count (btree-node-index-count node))) - (and (plusp index-count) - (loop with array = (btree-node-index node) - with btree-key< = (btree-key< btree) - for i from 0 below index-count - for candidate = (p-aref array i) - for candidate-key = (binding-key candidate) - while (funcall btree-key< candidate-key key) - finally (when (funcall (btree-key= btree) key candidate-key) - (return candidate)))))) - (defgeneric node-search (btree node key errorp default-value) (:method ((btree btree) (node btree-node) key errorp default-value) + (let ((binding (node-search-binding btree node key))) + (if binding + (binding-value binding) + (not-found btree key errorp default-value))))) + +(defgeneric node-search-binding (btree node key) + (:method ((btree btree) (node btree-node) key) (if (btree-node-leaf-p node) - (let ((binding (find-binding-in-node key node btree))) - (if binding - (binding-value binding) - (not-found btree key errorp default-value))) + (find-binding-in-node key node btree) (let ((subnode (find-subnode btree node key))) - (node-search btree subnode key errorp default-value))))) - + (node-search-binding btree subnode key))))) (defun find-subnode (btree node key) "Returns the subnode that contains more information for the given key." @@ -323,13 +472,22 @@ do (return-from find-subnode (binding-value binding))) (error "This shouldn't happen.")) +(defun find-binding-in-node (key node btree) + (let ((index-count (btree-node-index-count node))) + (and (plusp index-count) + (loop with array = (btree-node-index node) + with btree-key< = (btree-key< btree) + for i from 0 below index-count + for candidate = (p-aref array i) + for candidate-key = (binding-key candidate) + while (funcall btree-key< candidate-key key) + finally (when (funcall (btree-key= btree) key candidate-key) + (return candidate)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Insert ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defgeneric btree-insert (btree key value &key if-exists)) - (defmethod btree-insert ((btree btree) key value &key (if-exists :overwrite)) ;; Check that key and value are of the right type. (unless (typep key (btree-key-type btree)) @@ -361,14 +519,17 @@ (defun check-btree (btree) ;; Check that it is completely sorted. (let (prev-key) - (map-btree btree - (lambda (key value) - (declare (ignore value)) - (when prev-key - (unless (funcall (btree-key< btree) prev-key key) - (display-node (btree-root btree)) - (error "Btree inconsistency between ~D and ~D" prev-key key))) - (setq prev-key key))))) + (map-btree-keys btree + (lambda (key value) + (declare (ignore value)) + (when prev-key + (unless (funcall (btree-key< btree) prev-key key) + (pprint (btree-as-cons btree)) + (error "Btree inconsistency between ~D and ~D" prev-key key))) + (setq prev-key key)))) + ;; Check that it is balanced + (unless (btree-balanced-p btree) + (error "Btree ~S is not balanced." btree))) (defun make-root (btree left-key left-subnode right-key right-subnode) @@ -385,11 +546,13 @@ (defgeneric btree-node-insert (btree node parent-stack key value if-exists)) -(defmethod btree-node-insert ((btree btree) (node btree-node) parent-stack key value if-exists) +(defmethod btree-node-insert ((btree btree) (node btree-node) + parent-stack key value if-exists) (cond ((btree-node-leaf-p node) (leaf-insert btree node parent-stack key value if-exists)) (t (let ((subnode (find-subnode btree node key))) - (btree-node-insert btree subnode (cons node parent-stack) key value if-exists))))) + (btree-node-insert btree subnode (cons node parent-stack) + key value if-exists))))) (defun smallest-key (node) (if (btree-node-leaf-p node) @@ -397,9 +560,10 @@ (smallest-key (binding-value (node-binding node 0))))) [351 lines skipped] --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/04 22:04:43 1.4 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/08 13:35:18 1.5 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.4 2006/08/04 22:04:43 alemmens Exp $ +;; $Id: package.lisp,v 1.5 2006/08/08 13:35:18 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -32,8 +32,11 @@ #:p-cons #:p-array #:p-eql #:p-car #:p-cdr #:p-list + #:unwrap-persistent-list + #:p-mapcar #:p-mapc #:p-maplist #:p-mapl + #:p-member-if #:p-make-array #:p-aref #:p-array-dimensions - #:p-length #:p-find #:p-replace #:p-position + #:p-length #:p-find #:p-replace #:p-delete-if #:p-position ;; Heaps #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap @@ -83,8 +86,10 @@ #:btree-max-node-size #:btree-unique-keys-p #:btree-key-type #:btree-value-type #:btree-node-class #:btree-node + #:btree-nr-keys #:btree-nr-values ;; Functions - #:btree-search #:btree-insert #:btree-delete #:map-btree + #:btree-search #:btree-insert #:btree-delete #:btree-delete-key + #:map-btree #:map-btree-keys ;; Conditions #:btree-error #:btree-search-error #:btree-insertion-error #:btree-key-already-present-error #:btree-type-error --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/04 22:04:43 1.5 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 13:35:18 1.6 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.5 2006/08/04 22:04:43 alemmens Exp $ +;; $Id: test.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $ (in-package :test-rucksack) @@ -58,7 +58,8 @@ (p-test (p-make-array 2 :initial-contents '(a b)) (equal '(a b) (list (p-aref it 0) (p-aref it 1)))) - + + ;; ;; Persistent-objects ;; @@ -92,6 +93,37 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Test objects +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun test-objects () + ;; P-DELETE-IF + (p-test (p-list 1 2 3 4 5) + (equal '(1 3 5) + (unwrap-persistent-list (p-delete-if #'evenp it)))) + (p-test (p-list 1 2 3 4 5) + (equal '(2 4) + (unwrap-persistent-list (p-delete-if #'oddp it)))) + (p-test (p-list 1 2 4 6) + (equal '(1) + (unwrap-persistent-list (p-delete-if #'evenp it )))) + (p-test (p-list 1 2 3 4 5) + (equal '() + (unwrap-persistent-list (p-delete-if (constantly t) it )))) + (p-test (p-list 1 2 3 4 5) + (equal '(3 4 5) + (unwrap-persistent-list (p-delete-if (constantly t) it :count 2)))) + (p-test (p-list 1 2 3 4 5) + (equal '(1 2 3 4 5) + (unwrap-persistent-list (p-delete-if (constantly t) it :count 0)))) + ;; DO: We need a lot more tests here for other functions like + ;; P-MEMBER-IF, P-FIND, P-REPLACE, etcetera. + :ok) + + + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Test basic create, load and update functionality with many objects, so ;;; the incremental garbage collector needs to do some work too. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -153,6 +185,10 @@ ;; Test btrees as just another persistent data structure. ;; +(defparameter *format-strings* + ;; Different ways of printing integers. + '("~R" "~:R" "~@R" "~D")) + (defun shuffle (array) (loop with n = (array-dimension array 0) repeat n @@ -161,19 +197,16 @@ when (/= i j) do (rotatef (aref array i) (aref array j)))) + (defun check-size (btree expected) (format t "~&Counting~%") - (let ((count 0)) - (map-btree btree - (lambda (key value) - (declare (ignore key value)) - (incf count))) - (unless (= count expected) + (let ((count (btree-nr-values btree))) + (unless (= count expected) (error "Wrong btree size - expected ~A, got ~A." expected count)))) (defun check-order (btree) - (format t "~&Checking order~%") + (format t "~&Checking order and balance~%") (rs::check-btree btree)) (defun check-contents (btree) @@ -189,7 +222,9 @@ (prog1 (progn , at body) (format t "~&Committing...")))) -(defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) check-contents) +(defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) + (unique-keys t) + check-contents) ;; Create a rucksack with a btree of size N that maps random ;; integers to the equivalent strings as a cardinal English number. ;; Use node size NODE-SIZE for the btree. @@ -206,7 +241,11 @@ for i from 1 when (zerop (mod i 1000)) do (format t "~D " i) - do (btree-insert btree key (format nil "~R" key))) + do (btree-insert btree key + (format nil (first *format-strings*) key)) + do (unless unique-keys + (loop for format-string in (rest *format-strings*) + do (btree-insert btree key (format nil format-string key))))) (add-rucksack-root btree rucksack)))) (with-rucksack (rucksack *test-suite*) (with-transaction () @@ -225,7 +264,7 @@ (dotimes (i delete) (when (zerop (mod (1+ i) 1000)) (format t "~D " (1+ i))) - (btree-delete btree (aref array i))) + (btree-delete-key btree (aref array i))) (check-order btree) (check-contents btree))) (with-transaction* () @@ -249,9 +288,107 @@ (check-contents btree))))))) :ok) +;; +;; Btrees with non-unique keys + +(defun check-non-unique-contents (btree) + (format t "~&Checking contents~%") + (map-btree btree + (lambda (key value) + (let ((strings (loop for format-string in *format-strings* + collect (format nil format-string key)))) + (unless (member value strings :test #'string-equal) + (error "Value mismatch: Expected one of ~S for ~S, got ~S." + strings key value)))))) + + +(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 8)) + check-contents) + ;; Create a rucksack with a btree of size N (N must be a multiple of 4) that + ;; maps random integers to four different equivalent strings (in Roman and + ;; English notation). + ;; Use node size NODE-SIZE for the btree. + ;; If DELETE is not NIL, it must be a multiple of 4; delete that number of + ;; elements as well. + (let* ((nr-formats (length *format-strings*)) + (array-size (floor n nr-formats)) + (array (make-array array-size + :initial-contents (loop for i from 1 to array-size collect i)))) + (assert (zerop (mod n nr-formats))) + (assert (zerop (mod delete nr-formats))) + (shuffle array) + (with-rucksack (rucksack *test-suite* :if-exists :supersede) + (with-transaction* () + (format t "~&Inserting~%") + (let ((btree (make-instance 'btree :value= 'string-equal + :max-node-size node-size + :unique-keys-p nil))) + (loop for key across array + for i from 1 + when (zerop (mod i 200)) + do (format t "~D " i) + do (loop for format-string in *format-strings* + do (btree-insert btree key (format nil format-string key)))) + (add-rucksack-root btree rucksack)))) + (with-rucksack (rucksack *test-suite*) + (with-transaction () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree n) + (when check-contents + (check-non-unique-contents btree)))) + (when delete + (shuffle array) + (setq array (subseq array 0 (floor delete nr-formats))) + (shuffle array) + (with-transaction* () + (format t "~&Deleting~%") + (let ((btree (first (rucksack-roots rucksack)))) + (loop for i below (floor delete nr-formats) + do (loop for j below nr-formats + do (when (zerop (mod (+ j (* nr-formats i)) 10)) + (format t "~D " (+ j (* nr-formats i)))) + do (let* ((key (aref array i)) + (from-end (oddp key)) + (index (if from-end + j + (- nr-formats (1+ j)))) + (format-string (elt *format-strings* index)) + (value (format nil format-string key))) + (btree-delete btree key value + :if-does-not-exist :error)))) + (check-order btree) + (check-size btree (- n delete)) + (check-non-unique-contents btree))) + (with-transaction* () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree (- n delete)) + (when check-contents + (check-contents btree)) + (format t "~&Reinserting~%") + (shuffle array) + (dotimes (i (floor delete nr-formats)) + (when (zerop (mod (1+ i) 10)) + (format t "~D " (1+ i))) + (let ((key (aref array i))) + (loop for format-string in *format-strings* + do (btree-insert btree key (format nil format-string key))))))) + (with-transaction () + (let ((btree (first (rucksack-roots rucksack)))) + (check-order btree) + (check-size btree n) + (when check-contents + (check-contents btree))))))) + :ok) +(defun btree-stress-test (&key (n 1000)) + (loop for i below n + do (print i) + do (test-non-unique-btree :n 1600 :node-size 12 :delete 1500))) -(defun test-btree-map (&key (display t)) +(defun test-btree-map (&key (display t) min max include-min include-max + (order :ascending)) ;; Print out the contents of the btree. (with-rucksack (rucksack *test-suite*) (with-transaction () @@ -259,7 +396,12 @@ (map-btree btree (lambda (key value) (when display - (format t "~&~D -> ~A~%" key value)))))))) + (format t "~&~D -> ~A~%" key value))) + :min min + :include-min include-min + :max max + :include-max include-max + :order order))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Garbage collector --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/04 10:37:59 1.7 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/08 13:35:18 1.8 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.7 2006/08/04 10:37:59 alemmens Exp $ +;; $Id: transactions.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $ (in-package :rucksack) @@ -70,19 +70,21 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defgeneric transaction-changed-object (transaction object-id) - (:documentation "If the given transaction has modified the object -with the given object id, this function returns the modified object. -Otherwise it returns nil.")) + (:documentation + "If the given transaction has modified the object with the given +object id, this function returns the modified object. Otherwise it +returns nil.")) (defgeneric transaction-older-p (a b) - (:documentation "Returns true iff transaction A is older than -transaction B.")) + (:documentation + "Returns true iff transaction A is older than transaction B.")) (defgeneric find-conflicting-transaction (object-id cache transaction) - (:documentation "Tries to find an open transaction that has modified -the object with the given object-id and is older than the given -transaction. Returns this conflicting transaction, if there is one. -Otherwise it returns nil.")) + (:documentation + "Tries to find an open transaction that has modified the object +with the given object-id and is older than the given transaction. +Returns this conflicting transaction, if there is one. Otherwise it +returns nil.")) (defmethod transaction-nr-dirty-objects ((transaction standard-transaction)) (hash-table-count (dirty-objects transaction))) From alemmens at common-lisp.net Tue Aug 8 15:48:24 2006 From: alemmens at common-lisp.net (alemmens) Date: Tue, 8 Aug 2006 11:48:24 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060808154824.856B02E1B2@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv12813 Modified Files: garbage-collector.lisp test.lisp Log Message: Add a flag to MARK-AND-SWEEP-HEAP to prevent recursive GC calls. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 13:35:18 1.15 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 15:48:24 1.16 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.15 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.16 2006/08/08 15:48:24 alemmens Exp $ (in-package :rucksack) @@ -45,6 +45,9 @@ :finishing :ready) :accessor state) + (doing-work :initform nil :accessor gc-doing-work + :documentation + "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.") ;; Some counters that keep track of the amount of work done by ;; the garbage collector. (nr-object-bytes-marked :initform 0 :accessor nr-object-bytes-marked) @@ -207,35 +210,40 @@ ;; Collect at least the specified amount of garbage ;; (i.e. mark or sweep at least the specified amount of octets). ;; DO: We probably need a heap lock here? - (loop until (or (eql (state heap) :ready) (<= amount 0)) - do (ecase (state heap) - (:starting - ;; We were not collecting garbage; start doing that now. - (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 - ;; 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))) - (:scanning - (decf amount (mark-some-roots heap amount))) - (:sweeping-heap - (decf amount (sweep-some-heap-blocks heap amount))) - (:sweeping-object-table - (decf amount (sweep-some-object-blocks heap amount))) - (:finishing - ;; Grow the heap by the specified GROW-SIZE. - (if (integerp (grow-size heap)) - (incf (max-heap-end heap) (grow-size heap)) - (setf (max-heap-end heap) - (round (* (grow-size heap) (max-heap-end heap))))) - ;; - (setf (state heap) :ready))))) - + (unless (gc-doing-work heap) ; Don't do recursive GCs. + (unwind-protect + (progn + (setf (gc-doing-work heap) t) + (loop until (or (eql (state heap) :ready) (<= amount 0)) + do (ecase (state heap) + (:starting + ;; We were not collecting garbage; start doing that now. + (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 + ;; 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))) + (:scanning + (decf amount (mark-some-roots heap amount))) + (:sweeping-heap + (decf amount (sweep-some-heap-blocks heap amount))) + (:sweeping-object-table + (decf amount (sweep-some-object-blocks heap amount))) + (:finishing + ;; Grow the heap by the specified GROW-SIZE. + (if (integerp (grow-size heap)) + (incf (max-heap-end heap) (grow-size heap)) + (setf (max-heap-end heap) + (round (* (grow-size heap) (max-heap-end heap))))) + ;; + (setf (state heap) :ready))))) + (setf (gc-doing-work heap) nil)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Marking the object table ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 13:35:18 1.6 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 15:48:24 1.7 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: test.lisp,v 1.7 2006/08/08 15:48:24 alemmens Exp $ (in-package :test-rucksack) @@ -223,7 +223,6 @@ (format t "~&Committing...")))) (defun test-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) - (unique-keys t) check-contents) ;; Create a rucksack with a btree of size N that maps random ;; integers to the equivalent strings as a cardinal English number. From alemmens at common-lisp.net Wed Aug 9 13:23:18 2006 From: alemmens at common-lisp.net (alemmens) Date: Wed, 9 Aug 2006 09:23:18 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060809132318.6CF8B39007@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv3042 Modified Files: garbage-collector.lisp heap.lisp objects.lisp rucksack.lisp test.lisp transactions.lisp Log Message: Add a SERIAL-TRANSACTION-RUCKSACK-CLASS that allows for only one transaction at a time (by using a transaction lock). Don't do any GC at all while a transaction is writing objects to disk. Instead we keep track of the amount of disk space allocated by the committing transaction. Then we do a (partial) GC immediately after committing the transaction. --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 15:48:24 1.16 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/09 13:23:18 1.17 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.16 2006/08/08 15:48:24 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.17 2006/08/09 13:23:18 alemmens Exp $ (in-package :rucksack) @@ -46,6 +46,8 @@ :ready) :accessor state) (doing-work :initform nil :accessor gc-doing-work + ;; NOTE: This flag is probably not necessary anymore and + ;; should probably be removed. :documentation "A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.") ;; Some counters that keep track of the amount of work done by @@ -129,11 +131,13 @@ ;; ;; or: Work = (Size / Free) * WorkLeft ;; - (let* ((free (free-space heap)) - (work-left (work-left heap))) - (if (>= size free) - work-left - (floor (* size work-left) free)))) + (if (zerop size) + 0 + (let* ((free (free-space heap)) + (work-left (work-left heap))) + (if (>= size free) + work-left + (floor (* size work-left) free))))) (defmethod free-space ((heap mark-and-sweep-heap)) --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/04 10:26:23 1.9 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/09 13:23:18 1.10 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.9 2006/08/04 10:26:23 alemmens Exp $ +;; $Id: heap.lisp,v 1.10 2006/08/09 13:23:18 alemmens Exp $ (in-package :rucksack) @@ -24,6 +24,16 @@ (defgeneric (setf heap-end) (value heap) (:documentation "Modifies the end of the heap.")) +(defgeneric allocate-block (heap &key size expand) + (:documentation "Allocates a block of the requested size and returns +the heap position of that block. If the free list is full and EXPAND +is true, the system will try to expand the free list; otherwise it +returns nil. + As a second value, ALLOCATE-BLOCK returns the number of octets that +were allocated. +Note: both the requested size and the returned heap position include +the block's header.")) + ;; DO: Many more generic functions. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -47,7 +57,13 @@ (max-size :initarg :max-size :initform nil :accessor max-heap-size :documentation "The maximum size (in octets) for the heap. -If nil, the heap is allowed to expand indefinitely."))) +If nil, the heap is allowed to expand indefinitely.") + (nr-allocated-octets :initform 0 + :accessor nr-allocated-octets + :documentation "The number of octets that have been +allocated by ALLOCATE-BLOCK since the last time that RESET-ALLOCATION-COUNTER +was called."))) + ;; @@ -134,6 +150,29 @@ (initialize-block new-block block-size heap) new-block)) +;; +;; Keeping track of allocations +;; + +(defmethod allocate-block :around ((heap heap) &key &allow-other-keys) + (multiple-value-bind (block nr-octets) + (call-next-method) + (incf (nr-allocated-octets heap) nr-octets) + (values block nr-octets))) + +(defmethod reset-allocation-counter ((heap heap)) + ;; Resets the allocation counter (and returns the old value of the counter). + (let ((old-value (nr-allocated-octets heap))) + (setf (nr-allocated-octets heap) 0) + old-value)) + +(defmacro with-allocation-counter ((heap) &body body) + (let ((heap-var (gensym "HEAP")) + (old-counter (gensym "COUNTER"))) + `(let* ((,heap-var ,heap) + (,old-counter (reset-allocation-counter ,heap-var))) + (unwind-protect (progn , at body) + (setf (nr-allocated-octets ,heap-var) ,old-counter))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Free list heap @@ -266,14 +305,6 @@ ;; Allocating and deallocating blocks ;; -(defgeneric allocate-block (heap &key size expand) - (:documentation "Allocates a block of the requested size and returns -the heap position of that block. If the free list is full and EXPAND -is true, the system will try to expand the free list; otherwise it -returns nil. -Note: both the requested size and the returned heap position include -the block's header.")) - (defmethod allocate-block ((heap free-list-heap) &key (size (min-block-size heap)) (expand t)) ;; We don't bother to do something with the unused part of the block. @@ -288,7 +319,8 @@ (when (free-list-empty-p size-class heap) (if expand (setq block (expand-free-list size-class heap)) - (return-from allocate-block nil))) + (return-from allocate-block + (values nil 0)))) ;; Unhook the block from the free list ;; (the block header of an unused block contains a pointer to the ;; next unused block). @@ -298,7 +330,7 @@ ;; into header. (setf (block-size block heap) (size-class-block-size size-class heap)) ;; Return the block. - block)) + (values block size))) (defmethod deallocate-block (block (heap free-list-heap)) --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/08 13:35:18 1.6 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/09 13:23:18 1.7 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: objects.lisp,v 1.7 2006/08/09 13:23:18 alemmens Exp $ (in-package :rucksack) @@ -611,11 +611,6 @@ ;; 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. (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))) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/28 11:22:54 1.7 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/09 13:23:18 1.8 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.7 2006/05/28 11:22:54 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $ (in-package :rucksack) @@ -206,6 +206,17 @@ #-(or allegro lispworks sbcl openmcl) (not-implemented 'with-lock)) +(defun process-lock (lock) + #+lispworks + (mp:process-lock lock) + #-lispworks + (not-implemented 'process-lock)) + +(defun process-unlock (lock) + #+lispworks + (mp:process-unlock lock) + #-lispworks + (not-implemented 'process-unlock)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Rucksacks @@ -299,7 +310,6 @@ ;; We don't need to nreverse the list, because the order isn't specified. result)) - ;; ;; Opening ;; @@ -310,7 +320,7 @@ (defun open-rucksack (directory-designator &rest args &key - (class 'standard-rucksack) + (class 'serial-transaction-rucksack) (if-exists :overwrite) (if-does-not-exist :create) (cache-class 'standard-cache) (cache-args '()) &allow-other-keys) --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 15:48:24 1.7 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/09 13:23:18 1.8 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.7 2006/08/08 15:48:24 alemmens Exp $ +;; $Id: test.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $ (in-package :test-rucksack) @@ -187,7 +187,7 @@ (defparameter *format-strings* ;; Different ways of printing integers. - '("~R" "~:R" "~@R" "~D")) + '("~R" "~:R" "... ~R" "~D")) (defun shuffle (array) (loop with n = (array-dimension array 0) @@ -241,10 +241,7 @@ when (zerop (mod i 1000)) do (format t "~D " i) do (btree-insert btree key - (format nil (first *format-strings*) key)) - do (unless unique-keys - (loop for format-string in (rest *format-strings*) - do (btree-insert btree key (format nil format-string key))))) + (format nil (first *format-strings*) key))) (add-rucksack-root btree rucksack)))) (with-rucksack (rucksack *test-suite*) (with-transaction () @@ -301,7 +298,7 @@ strings key value)))))) -(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 8)) +(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 10)) check-contents) ;; Create a rucksack with a btree of size N (N must be a multiple of 4) that ;; maps random integers to four different equivalent strings (in Roman and @@ -407,6 +404,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defun check-gc (n) + ;; This used to fail for large values of N (e.g. 10,000). (with-rucksack (rucksack *test-suite* :if-exists :supersede) (with-transaction () ;; after this, INNER can be reached directly from the root --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/08 13:35:18 1.8 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/09 13:23:18 1.9 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: transactions.lisp,v 1.9 2006/08/09 13:23:18 alemmens Exp $ (in-package :rucksack) @@ -142,6 +142,32 @@ ;; And return the new transaction. transaction)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Rucksacks with serial transactions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defclass serial-transaction-rucksack (standard-rucksack) + ((transaction-lock :initform (make-lock :name "Rucksack transaction lock") + :reader rucksack-transaction-lock)) + (:documentation + "A serial transaction rucksack allows only one active transaction +at a time.")) + +(defmethod transaction-start-1 :before ((cache standard-cache) + (rucksack serial-transaction-rucksack) + &key &allow-other-keys) + (process-lock (rucksack-transaction-lock rucksack))) + +(defmethod transaction-commit-1 :after ((transaction standard-transaction) + (cache standard-cache) + (rucksack serial-transaction-rucksack)) + (process-unlock (rucksack-transaction-lock rucksack))) + +(defmethod transaction-rollback-1 :after ((transaction standard-transaction) + (cache standard-cache) + (rucksack serial-transaction-rucksack)) + (process-unlock (rucksack-transaction-lock rucksack))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Committing a transaction @@ -160,30 +186,40 @@ ;; 2. Commit all dirty objects. ;; Q: What if this is interleaved with other commits? (let ((queue (dirty-queue transaction)) - (table (dirty-objects transaction))) - (loop until (queue-empty-p queue) - do (let* ((id (queue-remove queue)) - (object (gethash id table))) - (when object - ;; If it's not in the dirty-objects table anymore, the - ;; object was already saved during this transaction-commit. - ;; That's possible, because the queue can contain duplicates. - (save-dirty-object object cache transaction id) - ;; Remove from hash-table too. - (remhash id table)))) + (table (dirty-objects transaction)) + (heap (heap cache)) + nr-allocated-octets) + (with-allocation-counter (heap) + (loop until (queue-empty-p queue) + do (let* ((id (queue-remove queue)) + (object (gethash id table))) + (when object + ;; If it's not in the dirty-objects table anymore, the + ;; object was already saved during this transaction-commit. + ;; That's possible, because the queue can contain duplicates. + (save-dirty-object object cache transaction id) + ;; Remove from hash-table too. + (remhash id table)))) + (setq nr-allocated-octets (nr-allocated-octets heap))) ;; Check for consistency between hash table and queue. (unless (zerop (hash-table-count table)) (internal-rucksack-error "Mismatch between dirty hash-table and queue while committing ~S: ~D objects left in hash-table." transaction - (hash-table-count table)))) - ;; 3. Remove transaction from the cache's open transactions. - (close-transaction cache transaction) - ;; 4. Delete the commit file to indicate that everything went fine - ;; and we don't need to recover from this commit. - (delete-commit-file transaction cache)) + (hash-table-count table))) + ;; 3. Remove transaction from the cache's open transactions. + (close-transaction cache transaction) + ;; 4. Delete the commit file to indicate that everything went fine + ;; and we don't need to recover from this commit. + (delete-commit-file transaction cache) + ;; 5. Let the garbage collector do an amount of work proportional + ;; to the number of octets that were allocated during the commit. + (collect-some-garbage heap + (gc-work-for-size heap nr-allocated-octets)))) + + ;; ;; Commit file ;; From alemmens at common-lisp.net Thu Aug 10 12:36:17 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 10 Aug 2006 08:36:17 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060810123617.70775722A6@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv23772 Modified Files: cache.lisp heap.lisp index.lisp mop.lisp objects.lisp p-btrees.lisp package.lisp rucksack.lisp schema-table.lisp test.lisp transactions.lisp Log Message: Do a FINISH-OUTPUT at the end of a transaction commit (suggested by Marco Baringer). Add :KEY-KEY and :VALUE-KEY initargs to btrees. Add some standard slot indexes. Add :UNIQUE initarg for persistent slots (not finished yet). --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/04 10:37:59 1.8 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/10 12:36:16 1.9 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.8 2006/08/04 10:37:59 alemmens Exp $ +;; $Id: cache.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -378,8 +378,15 @@ (remhash (transaction-id transaction) (transactions cache))) (defmethod map-transactions ((cache standard-cache) function) - (loop for transaction being the hash-value of (transactions cache) - do (funcall function transaction))) + ;; FUNCTION may be a function that closes the transaction (removing + ;; it from the hash table), so we create a fresh list with transactions + ;; before doing the actual iteration. + (let ((transactions '())) + (loop for transaction being the hash-value of (transactions cache) + do (push transaction transactions)) + ;; Now we can iterate safely. + (mapc function transactions))) + ;; ;; Commit/rollback @@ -397,7 +404,9 @@ (defmethod cache-commit ((cache standard-cache)) + ;; Commit all transactions. (map-transactions cache #'transaction-commit) + ;; Save the schema table. (save-schema-table (schema-table cache))) ;; --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/09 13:23:18 1.10 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/10 12:36:16 1.11 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.10 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: heap.lisp,v 1.11 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -96,6 +96,8 @@ (defmethod close-heap ((heap heap)) (close (heap-stream heap))) +(defmethod finish-heap-output ((heap heap)) + (finish-output (heap-stream heap))) ;; ;; Heap start/end --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/08 13:35:18 1.3 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/10 12:36:16 1.4 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.3 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: index.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -62,7 +62,7 @@ ;; An index spec is a symbol or a list starting with a symbol ;; and followed by a plist of keywords and values. -;; Examples: BTREE, (BTREE :KEY< < :VALUE= EQL) +;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL) (defun make-index (index-spec) (if (symbolp index-spec) @@ -82,3 +82,28 @@ (plist-subset-p (rest index-spec-1) (rest index-spec-2)) (plist-subset-p (rest index-spec-2) (rest index-spec-1)))))) + +;; +;; Predefined index specs for slots of persistent classes. +;; + +(defparameter *number-index* + '(btree :key< < :value= p-eql)) + +(defparameter *string-index* + '(btree :key< string< :value p-eql)) + +(defparameter *symbol-index* + '(btree :key< string< :value p-eql)) + +(defparameter *case-insensitive-string-index* + '(btree :key< string-lessp :value p-eql)) + +(defparameter *trimmed-string-index* + ;; Like *STRING-INDEX*, but with whitespace trimmed left and right. + '(btree :key< string< + :key-key trim-whitespace + :value p-eql)) + +(defun trim-whitespace (string) + (string-trim '(#\space #\tab #\return #\newline) string)) --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/05/28 12:07:55 1.3 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/10 12:36:16 1.4 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.3 2006/05/28 12:07:55 alemmens Exp $ +;; $Id: mop.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -25,7 +25,19 @@ transient slots. Default value is T.") (index :initarg :index :initform nil - :reader slot-index))) + :reader slot-index + :documentation "An index spec for indexed slots, NIL for +non-indexed slots. Default value is NIL.") + (unique :initarg :unique + :initform nil + :reader slot-unique + :documentation "Only relevant for indexed slots. Can be +either NIL (slot values are not unique), T (slot values are unique, +and an error will be signaled for attempts to add a duplicate slot +value) or :NO-ERROR (slot values are unique, but no error will be +signaled for attempts to add a duplicate slot value). :NO-ERROR +should only be used when speed is critical. + The default value is NIL."))) (defclass persistent-direct-slot-definition (persistent-slot-mixin standard-direct-slot-definition) @@ -49,7 +61,7 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Processing class and slot options for objects of metaclass -;; PERSISTENT-CLASS. +;;; PERSISTENT-CLASS. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #+lispworks @@ -58,7 +70,7 @@ value already-processed-options slot) - (if (member option '(:index :persistence)) + (if (member option '(:index :persistence :unique)) (list* option value already-processed-options) (call-next-method))) @@ -66,7 +78,7 @@ (defmethod clos:process-a-class-option ((class persistent-class) option-name value) - (if (member value '(:index)) + (if (member value '(:index :unique)) (list option-name value) (call-next-method))) @@ -169,28 +181,28 @@ (defmethod compute-effective-slot-definition ((class persistent-class) slot-name direct-slot-definitions) - (let ((effective-slotd (call-next-method)) - (persistent-slotds - (remove-if-not (lambda (slotd) - (typep slotd 'persistent-direct-slot-definition)) + (let ((effective-slotdef (call-next-method)) + (persistent-slotdefs + (remove-if-not (lambda (slotdef) + (typep slotdef '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)) + (setf (slot-value effective-slotdef 'persistence) + (some #'slot-persistence persistent-slotdefs)) - ;; If exactly one direct slot is indexed, then the effecive one is + ;; If exactly one direct slot is indexed, then the effective 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) + (let ((index-slotdefs (remove-if-not #'slot-index persistent-slotdefs))) + (cond ((cdr index-slotdefs) (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)))))) + (mapcar #'slot-index index-slotdefs))) + (index-slotdefs + (setf (slot-value effective-slotdef 'index) + (slot-index (car index-slotdefs)))))) ;; Return the effective slot definition. - effective-slotd)) + effective-slotdef)) --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/09 13:23:18 1.7 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/10 12:36:16 1.8 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.7 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: objects.lisp,v 1.8 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -88,10 +88,11 @@ (transaction-id :reader transaction-id) (rucksack :initarg :rucksack :initform (current-rucksack) :reader rucksack) (contents :initarg :contents :accessor contents)) - (:documentation "PERSISTENT-DATA classes do not have -PERSISTENT-CLASS as metaclass because we don't want to specialize -SLOT-VALUE-USING-CLASS & friends for persistent-data instances. Their -contents are accessed by special functions like P-CAR instead.")) + (:documentation + "PERSISTENT-DATA classes do not have PERSISTENT-CLASS as metaclass +because we don't want to specialize SLOT-VALUE-USING-CLASS & friends +for persistent-data instances. Their contents are accessed by special +functions like P-CAR instead.")) (defmethod print-object ((object persistent-data) stream) (print-unreadable-object (object stream :type t :identity nil) --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/08 13:35:18 1.8 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/10 12:36:16 1.9 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $ (in-package :rucksack) @@ -187,9 +187,18 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass btree () - ((key< :initarg :key< :reader btree-key< :initform '<) - (value= :initarg :value= :reader btree-value= :initform 'p-eql + ((key< :initarg :key< :initform '<) + (value= :initarg :value= :initform 'p-eql :documentation "This is only used for btrees with non-unique keys.") + (key-key :initarg :key-key :reader btree-key-key :initform 'identity + :documentation "A unary function that is applied to a +btree key before comparing it to another key with a key comparison +predicate like BTREE-KEY<.") + (value-key :initarg :value-key :reader btree-value-key :initform 'identity + :documentation "A unary function that is applied to a +btree value before comparing it to another value with the BTREE-VALUE= +predicate.") + ;; (node-class :initarg :node-class :reader btree-node-class @@ -218,48 +227,75 @@ (defmethod initialize-instance :around ((btree btree) &rest initargs - &key key< value= + &key key< key-key value= value-key &allow-other-keys) ;; It must be possible to save these btrees in the cache, but ;; that will not work for function objects because they can't be ;; serialized. This means that you should only specify symbols that ;; name a function. For program-independent databases you should - ;; only use symbols from the COMMON-LISP package. + ;; only use symbols from the COMMON-LISP or RUCKSACK packages. (declare (ignore initargs)) - (if (and (symbolp key<) (symbolp value=)) + (if (and (symbolp key<) (symbolp value=) + (symbolp key-key) (symbolp value-key)) (call-next-method) - (error "The :key< and :value= initargs for persistent btrees -must be symbols naming a function, otherwise they can't be saved on -disk."))) + (error "The :key<, :key-key, :value= and :value-key initargs for +persistent btrees must be symbols naming a function, otherwise they +can't be saved on disk."))) ;; ;; Comparison functions that can be deduced from KEY< (because the ;; btree keys have a total order). ;; +(defmethod btree-key< ((btree btree)) + (let ((key< (slot-value btree 'key<)) + (key-key (btree-key-key btree))) + (lambda (key1 key2) + (funcall key< + (funcall key-key key1) + (funcall key-key key2))))) + (defmethod btree-key= ((btree btree)) - (let ((key< (btree-key< btree))) + (let ((key< (slot-value btree 'key<)) + (key-key (btree-key-key btree))) (lambda (key1 key2) - (and (not (funcall key< key1 key2)) - (not (funcall key< key2 key1)))))) + (let ((key1 (funcall key-key key1)) + (key2 (funcall key-key key2))) + (and (not (funcall key< key1 key2)) + (not (funcall key< key2 key1))))))) (defmethod btree-key>= ((btree btree)) (lambda (key1 key2) (not (funcall (btree-key< btree) key1 key2)))) (defmethod btree-key<= ((btree btree)) - (let ((key< (btree-key< btree))) + (let ((key< (slot-value btree 'key<)) + (key-key (btree-key-key btree))) (lambda (key1 key2) - (or (funcall key< key1 key2) - (not (funcall key< key2 key1)))))) + (let ((key1 (funcall key-key key1)) + (key2 (funcall key-key key2))) + (or (funcall key< key1 key2) + (not (funcall key< key2 key1))))))) (defmethod btree-key> ((btree btree)) - (let ((key< (btree-key< btree))) + (let ((key< (slot-value btree 'key<)) + (key-key (btree-key-key btree))) (lambda (key1 key2) - (and (not (funcall key< key1 key2)) - (funcall key< key2 key1))))) + (let ((key1 (funcall key-key key1)) + (key2 (funcall key-key key2))) + (and (not (funcall key< key1 key2)) + (funcall key< key2 key1)))))) +(defmethod btree-value= ((btree btree)) + (let ((value= (slot-value btree 'value=)) + (value-key (btree-value-key btree))) + (lambda (value1 value2) + (let ((value1 (funcall value-key value1)) + (value2 (funcall value-key value2))) + (funcall value= value1 value2))))) + + ;; ;; The next two classes are for internal use only, so we don't bother ;; with fancy long names. --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/08 13:35:18 1.5 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/10 12:36:17 1.6 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.5 2006/08/08 13:35:18 alemmens Exp $ +;; $Id: package.lisp,v 1.6 2006/08/10 12:36:17 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -78,6 +78,8 @@ ;; Indexes #:map-index #:index-insert #:index-delete #:make-index + #:*string-index* #:*number-index* #:*symbol-index* + #:*trimmed-string-index* #:*case-insensitive-string-index* ;; Btrees #:btree --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/09 13:23:18 1.8 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/10 12:36:17 1.9 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $ (in-package :rucksack) @@ -283,6 +283,9 @@ (rucksack-roots-pathname rucksack)) (setf (roots-changed-p rucksack) nil)) +(defun save-roots-if-necessary (rucksack) + (when (roots-changed-p rucksack) + (save-roots rucksack))) (defmethod add-rucksack-root (object (rucksack standard-rucksack)) (add-rucksack-root-id (object-id object) rucksack)) @@ -438,7 +441,7 @@ (rucksack-add-class-index rucksack class :errorp t)) (t ;; We don't need to change anything - 'no-change)))) + :no-change)))) (defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack) (class persistent-class)) @@ -447,7 +450,7 @@ (current-index (rucksack-slot-index rucksack class slot))) (cond ((index-spec-equal index-needed current-index) ;; We keep the same index: no change needed. - 'no-change) + :no-change) ((and current-index (null index-needed)) ;; The index is not wanted anymore: remove it. (rucksack-remove-slot-index rucksack class slot :errorp t)) @@ -519,7 +522,8 @@ (defmethod rucksack-make-class-index ((rucksack standard-rucksack) class &key - (index-spec '(btree :key< < :key= = :value= eql))) + (index-spec '(btree :key< < :key= = :value= eql :unique-keys-p t))) + ;; A class index maps object ids to objects. (declare (ignore class)) (make-index index-spec)) --- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/10 12:36:17 1.3 @@ -1,4 +1,4 @@ -;; $Id: schema-table.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Id: schema-table.lisp,v 1.3 2006/08/10 12:36:17 alemmens Exp $ (in-package :rucksack) @@ -86,6 +86,9 @@ (setf (dirty-p table) nil) (save-objects (list table) (schema-table-pathname table))) +(defmethod save-schema-table-if-necessary ((table schema-table)) + (when (dirty-p table) + (save-schema-table table))) (defun open-schema-table (pathname &key if-exists if-does-not-exist) ;; Load existing schemas from the file. --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/09 13:23:18 1.8 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/10 12:36:17 1.9 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: test.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $ (in-package :test-rucksack) @@ -430,3 +430,32 @@ (inner (p-cdr (p-cdr (p-cdr root))))) ;; we expect the list ("Waldorf" "Statler") here (list (p-car inner) (p-cdr inner)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Indexing, class redefinitions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +(with-rucksack (rucksack *test-suite* :if-exists :supersede) + ;; For classes that may change during program development, you should + ;; wrap all class definitions in a WITH-RUCKSACK to make sure that + ;; the corresponding schema definitions and indexes are updated correctly. + ;; (This is only necessary if you already have a rucksack that contains + ;; instances of the class that's being redefined, of course.) + + ;; Define a class person + (defclass person () + ((id :initform (gensym "PERSON-") + :reader person-id + : +(name :initform (elt *names* (random (length *names*))) + :accessor name) + (age :initform (random 100) :accessor age)) + (:metaclass persistent-class)) + + ;; Fill the rucksack with some persons. + (with-transaction () + (loop repeat 1000 + do (make-instance 'person)) +|# --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/09 13:23:18 1.9 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/10 12:36:17 1.10 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.9 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: transactions.lisp,v 1.10 2006/08/10 12:36:17 alemmens Exp $ (in-package :rucksack) @@ -216,8 +216,20 @@ ;; 5. Let the garbage collector do an amount of work proportional ;; to the number of octets that were allocated during the commit. (collect-some-garbage heap - (gc-work-for-size heap nr-allocated-octets)))) - + (gc-work-for-size heap nr-allocated-octets)) + ;; 6. Make sure that all changes are actually on disk before + ;; we continue. + (finish-all-output rucksack))) + +(defmethod finish-all-output ((rucksack standard-rucksack)) + (let ((cache (rucksack-cache rucksack))) + (finish-heap-output (heap cache)) + (finish-heap-output (object-table (heap cache))) + ;; NOTE: I'm not totally sure that saving the roots and schema table + ;; for each transaction commit is necessary, but it probably is. So + ;; let's play safe for now. + (save-roots-if-necessary rucksack) + (save-schema-table-if-necessary (schema-table cache)))) ;; From alemmens at common-lisp.net Fri Aug 11 12:44:21 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 11 Aug 2006 08:44:21 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060811124421.A503C1B001@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv3790 Modified Files: glossary.txt index.lisp mop.lisp package.lisp rucksack.lisp serialize.lisp test.lisp Log Message: Save and load the index tables when closing/opening a rucksack. Add/remove indexes to/from the roots when necessary. Implement the :UNIQUE slot option. Improve predefined index specs. --- /project/rucksack/cvsroot/rucksack/glossary.txt 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/glossary.txt 2006/08/11 12:44:21 1.3 @@ -1,4 +1,4 @@ -;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.2 2006/05/16 22:01:27 alemmens Exp $ +;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.3 2006/08/11 12:44:21 alemmens Exp $ * block @@ -23,6 +23,22 @@ The object version that's compatible with a transaction T is the most recent version that's not younger than T. +* index spec + +A non-keyword symbol (the name of an indexing class) or a list +starting with a symbol (the name of an indexing class) followed by a +plist of keywords and values (initargs for the indexing class). + +Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL). + + +* index spec designator + +Either an index spec or the name (i.e. a keyword) of an index spec +that has been defined with DEFINE-INDEX-SPEC. + +Example: :STRING-INDEX. + * object version list --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/10 12:36:16 1.4 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/11 12:44:21 1.5 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: index.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $ (in-package :rucksack) @@ -26,17 +26,20 @@ ORDER is either :ASCENDING (default) or :DESCENDING.")) (defgeneric index-insert (index key value &key if-exists) - (:documentation "Insert a key/value pair into an index. IF-EXISTS -can be either :OVERWRITE (default) or :ERROR.")) + (:documentation + "Insert a key/value pair into an index. IF-EXISTS can be either +:OVERWRITE (default) or :ERROR.")) (defgeneric index-delete (index key value &key if-does-not-exist) - (:documentation "Remove a key/value pair from an index. -IF-DOES-NOT-EXIST can be either :IGNORE (default) or :ERROR.")) + (:documentation + "Remove a key/value pair from an index. IF-DOES-NOT-EXIST can be +either :IGNORE (default) or :ERROR.")) -;; make-index (index-spec) [Function] +;; make-index (index-spec unique-keys-p) [Function] ;; index-spec-equal (index-spec-1 index-spec-2) [Function] + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -64,10 +67,15 @@ ;; and followed by a plist of keywords and values. ;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL) -(defun make-index (index-spec) + +(defun make-index (index-spec unique-keys-p) + ;; NOTE: All index classes must accept the :UNIQUE-KEYS-P initarg. (if (symbolp index-spec) - (make-instance index-spec) - (apply #'make-instance (first index-spec) (rest index-spec)))) + (make-instance index-spec :unique-keys-p unique-keys-p) + (apply #'make-instance + (first index-spec) + :unique-keys-p unique-keys-p + (rest index-spec)))) (defun index-spec-equal (index-spec-1 index-spec-2) "Returns T iff two index specs are equal." @@ -83,27 +91,60 @@ (plist-subset-p (rest index-spec-2) (rest index-spec-1)))))) -;; -;; Predefined index specs for slots of persistent classes. -;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Defining index specs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defparameter *number-index* - '(btree :key< < :value= p-eql)) +(eval-when (:compile-toplevel :load-toplevel :execute) -(defparameter *string-index* - '(btree :key< string< :value p-eql)) + ;; + ;; Defining index specs + ;; + + (defparameter *index-specs* + (make-hash-table)) + + (defun define-index-spec (name spec &key (if-exists :overwrite)) + "NAME must be a keyword. SPEC must be an index spec. IF-EXISTS must be +either :OVERWRITE (default) or :ERROR." + (assert (member if-exists '(:overwrite :error))) + (when (eql if-exists :error) + (let ((existing-spec (gethash name *index-specs*))) + (when (and existing-spec + (not (index-spec-equal existing-spec spec))) + (error "Index spec ~S is already defined. Its definition is: ~S." + name existing-spec)))) + (setf (gethash name *index-specs*) spec)) + + (defun find-index-spec (name &key (errorp t)) + (or (gethash name *index-specs*) + (and errorp + (error "Can't find index spec called ~S." name))))) -(defparameter *symbol-index* - '(btree :key< string< :value p-eql)) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Predefined index specs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defparameter *case-insensitive-string-index* - '(btree :key< string-lessp :value p-eql)) - -(defparameter *trimmed-string-index* - ;; Like *STRING-INDEX*, but with whitespace trimmed left and right. - '(btree :key< string< - :key-key trim-whitespace - :value p-eql)) - (defun trim-whitespace (string) - (string-trim '(#\space #\tab #\return #\newline) string)) + (string-trim '(#\space #\tab #\return #\newline) string)) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (define-index-spec :number-index + '(btree :key< < :value= p-eql)) + + (define-index-spec :string-index + '(btree :key< string< :value p-eql)) + + (define-index-spec :symbol-index + '(btree :key< string< :value p-eql)) + + (define-index-spec :case-insensitive-string-index + '(btree :key< string-lessp :value p-eql)) + + (define-index-spec :trimmed-string-index + ;; Like :STRING-INDEX, but with whitespace trimmed left + ;; and right. + '(btree :key< string< + :key-key trim-whitespace + :value p-eql))) --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/10 12:36:16 1.4 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/11 12:44:21 1.5 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.4 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: mop.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $ (in-package :rucksack) @@ -15,7 +15,7 @@ :accessor class-persistent-slots) (index :initarg :index :initform nil :accessor class-index :documentation "Can be either NIL (for no class index) or T -(for the standard class index). Default value is NIL."))) +(for the standard class index). Default value is T."))) (defclass persistent-slot-mixin () ((persistence :initarg :persistence @@ -26,8 +26,8 @@ (index :initarg :index :initform nil :reader slot-index - :documentation "An index spec for indexed slots, NIL for -non-indexed slots. Default value is NIL.") + :documentation "An index spec designator for indexed slots, +NIL for non-indexed slots. Default value is NIL.") (unique :initarg :unique :initform nil :reader slot-unique @@ -105,25 +105,31 @@ ;; slot-value-using-class. #+lispworks :optimize-slot-access #+lispworks nil args))) - (ensure-class-schema class) + (ensure-class-schema class '()) result)) (defmethod reinitialize-instance :around ((class persistent-class) &rest args &key direct-superclasses &allow-other-keys) - ;; This is a copy of the code for initialize-instance at the moment. - (let ((result (apply #'call-next-method - class - :direct-superclasses (maybe-add-persistent-object-class - class - direct-superclasses) - ;; Tell Lispworks that it shouldn't bypass - ;; slot-value-using-class. - #+lispworks :optimize-slot-access #+lispworks nil - args))) - (ensure-class-schema class) - result)) + (let* ((old-slot-defs (class-direct-slots class)) + ;; Create a simple alist with slot name as key and + ;; a list with slot-index and slot-unique as value. + (old-slot-indexes (loop for slot-def in old-slot-defs + collect (list (slot-definition-name slot-def) + (slot-index slot-def) + (slot-unique slot-def))))) + (let ((result (apply #'call-next-method + class + :direct-superclasses (maybe-add-persistent-object-class + class + direct-superclasses) + ;; Tell Lispworks that it shouldn't bypass + ;; slot-value-using-class. + #+lispworks :optimize-slot-access #+lispworks nil + args))) + (ensure-class-schema class old-slot-indexes) + result))) (defun maybe-add-persistent-object-class (class direct-superclasses) @@ -140,7 +146,7 @@ direct-superclasses (cons root-class direct-superclasses)))) -(defun ensure-class-schema (class) +(defun ensure-class-schema (class old-slot-indexes) ;; Update class and slot indexes. (when (some #'slot-persistence (class-direct-slots class)) ;; NOTE: We get the current-rucksack only if there are some @@ -151,7 +157,7 @@ (let ((rucksack (current-rucksack))) (when rucksack (rucksack-update-class-index rucksack class) - (rucksack-update-slot-indexes rucksack class)))) + (rucksack-update-slot-indexes rucksack class old-slot-indexes)))) ;; DO: Update schema in schema table, when necessary. 'DO-THIS) --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/10 12:36:17 1.6 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/11 12:44:21 1.7 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.6 2006/08/10 12:36:17 alemmens Exp $ +;; $Id: package.lisp,v 1.7 2006/08/11 12:44:21 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -78,8 +78,7 @@ ;; Indexes #:map-index #:index-insert #:index-delete #:make-index - #:*string-index* #:*number-index* #:*symbol-index* - #:*trimmed-string-index* #:*case-insensitive-string-index* + #:define-index-spec #:find-index-spec ;; Btrees #:btree --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/10 12:36:17 1.9 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/11 12:44:21 1.10 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $ (in-package :rucksack) @@ -62,17 +62,19 @@ (defgeneric rucksack-update-class-index (rucksack class) (:documentation "Compares the current class index for CLASS to the class index -that's specified in the :INDEX class options of CLASS. An obsolete +that's specified in the :INDEX class option of CLASS. An obsolete class index (i.e. a class index that's specified anymore in the class option) is removed, new class indexes are added.")) -(defgeneric rucksack-update-slot-indexes (rucksack class) +(defgeneric rucksack-update-slot-indexes (rucksack class old-slot-indexes) (:documentation "Compares the current slot indexes for CLASS to the slot indexes that are specified in the slot options for the direct slots of CLASS. Obsolete slot indexes (i.e. slot indexes that are not specified anymore in the slot options) are removed, new slot indexes are -added.")) +added. + OLD-SLOT-INDEXES is a list with the name, index and unique-p info +of each slot.")) (defgeneric rucksack-add-class-index (rucksack class-designator &key errorp)) @@ -95,15 +97,15 @@ (defgeneric rucksack-add-slot-index (rucksack class-designator slot index-spec - &key errorp) + unique-p &key errorp) (:documentation "Creates a new slot index for the slot designated by CLASS-DESIGNATOR and SLOT. The type of index is specified by INDEX-SPEC. Returns the new index. Signals an error if ERRORP is T -and there is already an index for the designated slot.")) +and there already is an index for the designated slot.")) (defgeneric rucksack-remove-slot-index (rucksack class-designator slot - &key errorp)) + &key errorp)) @@ -153,11 +155,13 @@ &key equal min max include-min include-max order id-only include-subclasses) (:documentation - " FUNCTION is a unary function that gets called for all instances of + " FUNCTION is a unary function that gets called for all instances of the specified class that have a slot value matching the EQUAL, MIN, -MAX INCLUDE-MIN and INCLUDE-MAX arguments. ORDER can be either -:ASCENDING (default) or :DESCENDING; currently, the specified order -will be respected for instances of one class but not across subclasses. +MAX INCLUDE-MIN and INCLUDE-MAX arguments (see the documentation of +MAP-INDEX for a description of these arguments). + ORDER can be either :ASCENDING (default) or :DESCENDING; currently, +the specified order will be respected for instances of one class but +not across subclasses. If ID-ONLY is T (default is NIL), the function will be called with object ids instead of 'real' objects. This can be handy if you want to do more filtering before actually loading objects from disk. @@ -273,13 +277,23 @@ (defun load-roots (rucksack) ;; Read roots (i.e. object ids) from the roots file (if there is one). + ;; Also load the class and slot index tables. (let ((roots-file (rucksack-roots-pathname rucksack))) (when (probe-file roots-file) - (setf (slot-value rucksack 'roots) - (load-objects roots-file))))) + (destructuring-bind (root-list class-index slot-index) + (load-objects roots-file) + (with-slots (roots class-index-table slot-index-tables) + rucksack + (setf roots root-list + class-index-table (maybe-dereference-proxy class-index) + slot-index-tables (maybe-dereference-proxy slot-index)))))) + rucksack) + (defun save-roots (rucksack) - (save-objects (slot-value rucksack 'roots) + (save-objects (list (slot-value rucksack 'roots) + (class-index-table rucksack) + (slot-index-tables rucksack)) (rucksack-roots-pathname rucksack)) (setf (roots-changed-p rucksack) nil)) @@ -443,37 +457,61 @@ ;; We don't need to change anything :no-change)))) + (defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack) - (class persistent-class)) + (class persistent-class) + old-slot-indexes) (dolist (slot (class-direct-slots class)) - (let ((index-needed (and (slot-persistence slot) (slot-index slot))) - (current-index (rucksack-slot-index rucksack class slot))) - (cond ((index-spec-equal index-needed current-index) - ;; We keep the same index: no change needed. - :no-change) - ((and current-index (null index-needed)) - ;; The index is not wanted anymore: remove it. - (rucksack-remove-slot-index rucksack class slot :errorp t)) - ((and (null current-index) index-needed) - ;; We didn't have an index but we need one now: add one. - (rucksack-add-slot-index rucksack class slot index-needed - :errorp t)) - ((and current-index index-needed) - ;; We have an index but need a different one now. This requires - ;; some care because we need to re-index all objects from the old - ;; index. - (let ((new-index (rucksack-add-slot-index rucksack class slot - index-needed - :errorp nil))) - ;; Re-index all objects for the new index. - (map-index current-index - (lambda (slot-value object-id) - (index-insert new-index slot-value object-id))) - ;; We don't need to remove the old index explicitly, because - ;; RUCKSACK-ADD-SLOT-INDEX already did that for us. - )))))) + (let* ((index-spec (and (slot-persistence slot) + (or (find-index-spec (slot-index slot) :errorp nil) + (slot-index slot)))) + (unique-p (slot-unique slot))) + (multiple-value-bind (current-index-spec current-unique-p) + (find-old-index-spec (slot-definition-name slot) old-slot-indexes) + (cond ((and (index-spec-equal index-spec current-index-spec) + (eql unique-p current-unique-p)) + ;; We keep the same index: no change needed. + :no-change) + ((and current-index-spec (null index-spec)) + ;; The index is not wanted anymore: remove it. + (rucksack-remove-slot-index rucksack class slot :errorp t)) + ((and (null current-index-spec) index-spec) + ;; We didn't have an index but we need one now: add one. + (rucksack-add-slot-index rucksack class slot index-spec unique-p + :errorp t)) + ((and current-index-spec index-spec) + ;; We have an index but need a different one now. This requires + ;; some care because we need to re-index all objects from the old + ;; index. + (let ((current-index (rucksack-slot-index rucksack class slot)) + (new-index (rucksack-add-slot-index rucksack class slot + index-spec + unique-p + :errorp nil))) + ;; Re-index all objects for the new index. + ;; DO: This re-indexing can cause an error (e.g. if the old + ;; index has non-unique keys, the new index has unique keys + ;; and some keys occur more than once). We need to handle + ;; that error here and offer some decent restarts (e.g. + ;; remove the index entirely, or go back to the old index). + (map-index current-index + (lambda (slot-value object-id) + (index-insert new-index slot-value object-id))) + ;; We don't need to remove the old index explicitly, because + ;; RUCKSACK-ADD-SLOT-INDEX already did that for us. + ))))))) + +(defun find-old-index-spec (slot-name old-slot-indexes) + (let ((slot-info (cdr (assoc slot-name old-slot-indexes)))) + (and slot-info + (destructuring-bind (index-spec-designator unique-p) + slot-info + (values (or (find-index-spec index-spec-designator :errorp nil) + index-spec-designator) + unique-p))))) + ;; ;; Some simple dispatchers. ;; @@ -516,16 +554,18 @@ (simple-rucksack-error "Class index for ~S already exists in ~A." class rucksack)) - (setf (gethash class (class-index-table rucksack)) - (rucksack-make-class-index rucksack class))) + (let ((index (rucksack-make-class-index rucksack class))) + (setf (gethash class (class-index-table rucksack)) index) + (add-rucksack-root index rucksack) + index)) (defmethod rucksack-make-class-index ((rucksack standard-rucksack) class &key - (index-spec '(btree :key< < :key= = :value= eql :unique-keys-p t))) + (index-spec '(btree :key< < :value= p-eql))) ;; A class index maps object ids to objects. (declare (ignore class)) - (make-index index-spec)) + (make-index index-spec t)) (defmethod rucksack-remove-class-index ((rucksack standard-rucksack) class &key (errorp nil)) @@ -536,7 +576,9 @@ (simple-rucksack-error "Class index for ~S doesn't exist in ~A." class rucksack)) - (remhash class (class-index-table rucksack))) + (let ((index (gethash class (class-index-table rucksack)))) + (remhash class (class-index-table rucksack)) + (delete-rucksack-root index rucksack))) (defmethod rucksack-map-class-indexes (rucksack function) @@ -589,7 +631,7 @@ ;; (defmethod rucksack-add-slot-index ((rucksack standard-rucksack) - class slot index-spec + class slot index-spec unique-p &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) @@ -602,14 +644,18 @@ (let ((table (make-hash-table))) (setf (gethash class slot-index-tables) table) table))) - (new-slot-index (make-index index-spec))) + (new-slot-index (make-index index-spec unique-p)) + (old-slot-index (gethash slot slot-index-table))) ;; Add a new slot index table if necessary. - (when (and errorp (gethash slot slot-index-table)) + (when (and errorp old-slot-index) (simple-rucksack-error "Slot index for slot ~S of class ~S already exists in ~A." slot class rucksack)) + (add-rucksack-root new-slot-index rucksack) + (when old-slot-index + (delete-rucksack-root old-slot-index rucksack)) (setf (gethash slot slot-index-table) new-slot-index))) (defmethod rucksack-remove-slot-index (rucksack class slot &key (errorp nil)) @@ -628,7 +674,9 @@ (if errorp (let ((index (gethash slot slot-index-table))) (if index - (remhash slot slot-index-table) + (progn + (remhash slot slot-index-table) + (delete-rucksack-root index rucksack)) (oops))) (remhash slot slot-index-table)) (and errorp (oops)))))) @@ -684,14 +732,15 @@ (and slot-index-table (gethash slot slot-index-table))))) (or (find-index class) - (loop for superclass in (class-precedence-list (find-class class)) + (loop for superclass in (class-precedence-list + (find-class class)) thereis (find-index (class-name superclass))) (and errorp - (simple-rucksack-error "Can't find slot index for slot -~S of class ~S in ~A." - slot - class - rucksack)))))) + (simple-rucksack-error + "Can't find slot index for slot ~S of class ~S in ~A." + slot + class + rucksack)))))) (defmethod rucksack-map-slot ((rucksack standard-rucksack) class slot function --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/04 10:26:23 1.5 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/11 12:44:21 1.6 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.5 2006/08/04 10:26:23 alemmens Exp $ +;; $Id: serialize.lisp,v 1.6 2006/08/11 12:44:21 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -1203,7 +1203,8 @@ ;; uses non-serializable objects to represent host or device or directory ;; or name or type or version, this will break. (serialize-marker +pathname+ stream) - (serialize (pathname-host pathname) stream) + #-sbcl(serialize (pathname-host pathname) stream) + #+sbcl(serialize (host-namestring pathname) stream) (serialize (pathname-device pathname) stream) (serialize (pathname-directory pathname) stream) (serialize (pathname-name pathname) stream) --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/10 12:36:17 1.9 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/11 12:44:21 1.10 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.9 2006/08/10 12:36:17 alemmens Exp $ +;; $Id: test.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $ (in-package :test-rucksack) @@ -432,30 +432,3 @@ (list (p-car inner) (p-cdr inner)))))) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indexing, class redefinitions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| -(with-rucksack (rucksack *test-suite* :if-exists :supersede) - ;; For classes that may change during program development, you should - ;; wrap all class definitions in a WITH-RUCKSACK to make sure that - ;; the corresponding schema definitions and indexes are updated correctly. - ;; (This is only necessary if you already have a rucksack that contains - ;; instances of the class that's being redefined, of course.) - - ;; Define a class person - (defclass person () - ((id :initform (gensym "PERSON-") - :reader person-id - : -(name :initform (elt *names* (random (length *names*))) - :accessor name) - (age :initform (random 100) :accessor age)) - (:metaclass persistent-class)) - - ;; Fill the rucksack with some persons. - (with-transaction () - (loop repeat 1000 - do (make-instance 'person)) -|# From alemmens at common-lisp.net Fri Aug 11 12:52:53 2006 From: alemmens at common-lisp.net (alemmens) Date: Fri, 11 Aug 2006 08:52:53 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060811125253.C4D6A1F007@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv5815 Added Files: example-1.lisp Log Message: Add indexing example (doesn't work yet). --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/11 12:52:53 NONE +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/11 12:52:53 1.1 ;; $Id: example-1.lisp,v 1.1 2006/08/11 12:52:53 alemmens Exp $ (in-package :test-rucksack) ;; NOTE: This example doesn't run at the moment, because indexing doesn't ;; work correctly yet. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing, class redefinitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *example-1* #p"/tmp/rucksack/example-1/") (defparameter *hackers* '("David" "Jim" "Peter" "Thomas" "Arthur" "Jans" "Klaus" "James" "Martin")) (with-rucksack (rucksack *example-1* :if-exists :supersede) (with-transaction () ;; For classes that may change during program development, you should ;; wrap all class definitions in a WITH-RUCKSACK to make sure that ;; the corresponding schema definitions and indexes are updated correctly. ;; (This is only necessary if you already have a rucksack that contains ;; instances of the class that's being redefined, of course.) ;; Define a class hacker (defclass hacker () ((id :initform (gensym "HACKER-") :reader hacker-id :index :symbol-index :unique t) (name :initform (elt *hackers* (random (length *hackers*))) :accessor name :index :case-insensitive-string-index) (age :initform (random 100) :accessor age)) (:metaclass persistent-class)))) (defmethod print-object ((hacker hacker) stream) (print-unreadable-object (hacker stream :type t) (format stream "~S called ~S of age ~D" (hacker-id hacker) (name hacker) (age hacker)))) (defun example-1 () (with-rucksack (rucksack *example-1*) ;; Fill the rucksack with some hackers. (with-transaction () (loop repeat 1000 do (make-instance 'hacker)) #+nil (rucksack-map-slot rucksack 'hacker 'name (lambda (hacker) (print-object hacker *standard-output*) (terpri)))))) (defun show-hackers () (with-rucksack (rucksack *example-1*) (rucksack-map-class rucksack 'hacker (lambda (hacker) (print-object hacker *standard-output*) (terpri))))) From alemmens at common-lisp.net Thu Aug 24 15:21:25 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 24 Aug 2006 11:21:25 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060824152125.00E142608B@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv9687 Modified Files: cache.lisp garbage-collector.lisp make.lisp objects.lisp package.lisp rucksack.lisp serialize.lisp test.lisp transactions.lisp Log Message: The class and slot indexes were normal hash tables, but they should be persistent objects like everything else: I replaced them by btrees. Get PROCESS-LOCK and PROCESS-UNLOCK working on SBCL (thanks to Geoff Cant). --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/10 12:36:16 1.9 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/24 15:21:25 1.10 @@ -1,4 +1,4 @@ -;; $Id: cache.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: cache.lisp,v 1.10 2006/08/24 15:21:25 alemmens Exp $ (in-package :rucksack) @@ -281,7 +281,8 @@ ;; current transaction? Fine, let's use it. (let ((object (gethash object-id (objects cache)))) (and object - (<= (transaction-id object) (transaction-id transaction)) + (or (null transaction) + (<= (transaction-id object) (transaction-id transaction))) object)) ;; Modified by an open transaction? Try to find the ;; 'compatible' version. @@ -318,22 +319,23 @@ ;; EFFICIENCY: Maybe we should use another data structure than a ;; hash table for faster searching in the potentially relevant ;; transactions? An in-memory btree might be good... - (or - ;; Modified by the current-transaction itself? Then use that version. - (transaction-changed-object current-transaction object-id) - ;; Otherwise iterate over all open transactions, keeping track - ;; of the best candidate. - (let ((result-transaction nil) - (result nil)) - (loop for transaction being the hash-value of (transactions cache) - for object = (transaction-changed-object transaction object-id) - when (and object - (transaction-older-p transaction current-transaction) - (or (null result-transaction) - (transaction-older-p result-transaction transaction))) - do (setf result-transaction transaction - result object)) - result))) + (and current-transaction + (or + ;; Modified by the current-transaction itself? Then use that version. + (transaction-changed-object current-transaction object-id) + ;; Otherwise iterate over all open transactions, keeping track + ;; of the best candidate. + (let ((result-transaction nil) + (result nil)) + (loop for transaction being the hash-value of (transactions cache) + for object = (transaction-changed-object transaction object-id) + when (and object + (transaction-older-p transaction current-transaction) + (or (null result-transaction) + (transaction-older-p result-transaction transaction))) + do (setf result-transaction transaction + result object)) + result)))) --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/09 13:23:18 1.17 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/24 15:21:25 1.18 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.17 2006/08/09 13:23:18 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.18 2006/08/24 15:21:25 alemmens Exp $ (in-package :rucksack) @@ -221,14 +221,21 @@ (loop until (or (eql (state heap) :ready) (<= amount 0)) do (ecase (state heap) (:starting - ;; We were not collecting garbage; start doing that now. - (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 - ;; 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)) + (let ((rucksack (rucksack heap))) + ;; We were not collecting garbage; start doing that now. + (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 + ;; We don't need to copy the roots, because we're not + ;; going to modify the list (just push and pop). + ;; But we do need to add the btrees for the class-index-table + ;; and slot-index-tables to the GC roots. + (roots heap) (append (and (slot-boundp rucksack 'class-index-table) + (list (slot-value rucksack 'class-index-table))) + (and (slot-boundp rucksack 'slot-index-tables) + (list (slot-value rucksack 'slot-index-tables))) + (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/make.lisp 2006/05/25 13:01:38 1.3 +++ /project/rucksack/cvsroot/rucksack/make.lisp 2006/08/24 15:21:25 1.4 @@ -1,4 +1,4 @@ -;; $Id: make.lisp,v 1.3 2006/05/25 13:01:38 alemmens Exp $ +;; $Id: make.lisp,v 1.4 2006/08/24 15:21:25 alemmens Exp $ (in-package :cl-user) @@ -23,7 +23,7 @@ "index" "rucksack" "transactions" - "test") + #+nil "test") do (tagbody :retry (let ((lisp (make-pathname :name file --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/10 12:36:16 1.8 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/24 15:21:25 1.9 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.8 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: objects.lisp,v 1.9 2006/08/24 15:21:25 alemmens Exp $ (in-package :rucksack) @@ -75,9 +75,9 @@ object) (defun cache (object) - (let ((rucksack (rucksack object))) - (and rucksack - (rucksack-cache (rucksack object))))) + (and (slot-boundp object 'rucksack) + (rucksack object) + (rucksack-cache (rucksack object)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Low level persistent data structures. --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/11 12:44:21 1.7 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/24 15:21:25 1.8 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.7 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: package.lisp,v 1.8 2006/08/24 15:21:25 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -68,7 +68,7 @@ ;; Transactions #:current-transaction #:transaction-start #:transaction-commit #:transaction-rollback - #:with-transaction + #:with-transaction #:*transaction* #:transaction #:standard-transaction #:transaction-start-1 #:transaction-commit-1 #:transaction-id --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/11 12:44:21 1.10 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/24 15:21:25 1.11 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ (in-package :rucksack) @@ -213,15 +213,64 @@ (defun process-lock (lock) #+lispworks (mp:process-lock lock) - #-lispworks + #+sbcl + (sb-thread:get-mutex lock) + #-(or sbcl lispworks) (not-implemented 'process-lock)) + (defun process-unlock (lock) #+lispworks (mp:process-unlock lock) - #-lispworks + #+sbcl + (sb-thread:release-mutex lock) + #-(or sbcl lispworks) (not-implemented 'process-unlock)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; WITH-TRANSACTION +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; It would be prettier if we could put this macro in TRANSACTIONS.LISP, but +;; we need it here already. + +(defparameter *transaction* nil + "The currently active transaction.") + +(defmacro with-transaction ((&rest args + &key (rucksack '(current-rucksack)) + &allow-other-keys) + &body body) + (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 + ,@(sans args :rucksack))) + (let ((*transaction* ,transaction)) + (with-simple-restart (abort "Abort ~S" ,transaction) + (setf ,result (progn , 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 ,result ,committed))) + (unless ,committed + (transaction-rollback ,transaction))))) + ;; Normal exit from the above block -- we selected the RETRY restart. + )))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Rucksacks ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -239,16 +288,12 @@ from which the garbage collector can reach all live objects.") (roots-changed-p :initform nil :accessor roots-changed-p) ;; Indexes - (class-index-table :initform (make-hash-table) - :documentation - "A mapping from class names to indexes. Each index contains the ids -of all instances from a class." - :reader class-index-table) - (slot-index-tables :initform (make-hash-table) - :reader slot-index-tables - :documentation - "A mapping from class names to slot index tables, where each slot -index table is a mapping from slot names to slot indexes. Each slot + (class-index-table :documentation + "A btree mapping class names to indexes. Each index contains the ids +of all instances from a class.") + (slot-index-tables :documentation + "A btree mapping class names to slot index tables, where each slot +index table is a btree mapping slot names to slot indexes. Each slot index maps slot values to object ids."))) (defmethod print-object ((rucksack rucksack) stream) @@ -261,6 +306,43 @@ (merge-pathnames "roots" (rucksack-directory rucksack))) +(defmethod class-index-table ((rucksack standard-rucksack)) + ;; Create class-index-table if it doesn't exist yet. + (flet ((do-it () + (unless (slot-boundp rucksack 'class-index-table) + (let ((btree (make-instance 'btree + :rucksack rucksack + :key< 'string< + :value= 'p-eql + :unique-keys-p t))) + (setf (slot-value rucksack 'class-index-table) (object-id btree)))) + (cache-get-object (slot-value rucksack 'class-index-table) + (rucksack-cache rucksack)))) + (if (current-transaction) + (do-it) + (with-transaction (:rucksack rucksack) + (do-it))))) + + +(defmethod slot-index-tables ((rucksack standard-rucksack)) + ;; Create slot-index-tables if they don't exist yet. + (flet ((do-it () + (unless (slot-boundp rucksack 'slot-index-tables) + (let ((btree (make-instance 'btree + :rucksack rucksack + :key< 'string< + :value= 'p-eql + :unique-keys-p t))) + (setf (slot-value rucksack 'slot-index-tables) (object-id btree)))) + ;; + (cache-get-object (slot-value rucksack 'slot-index-tables) + (rucksack-cache rucksack)))) + (if (current-transaction) + (do-it) + (with-transaction (:rucksack rucksack) + (do-it))))) + + (defmethod initialize-instance :after ((rucksack standard-rucksack) &key (cache-class 'standard-cache) @@ -275,6 +357,7 @@ (load-roots rucksack)) + (defun load-roots (rucksack) ;; Read roots (i.e. object ids) from the roots file (if there is one). ;; Also load the class and slot index tables. @@ -282,18 +365,22 @@ (when (probe-file roots-file) (destructuring-bind (root-list class-index slot-index) (load-objects roots-file) - (with-slots (roots class-index-table slot-index-tables) + (with-slots (roots class-index-table slot-index-tables cache) rucksack - (setf roots root-list - class-index-table (maybe-dereference-proxy class-index) - slot-index-tables (maybe-dereference-proxy slot-index)))))) + (setf roots root-list) + (when class-index + (setf class-index-table class-index)) + (when slot-index + (setf slot-index-tables slot-index)))))) rucksack) (defun save-roots (rucksack) (save-objects (list (slot-value rucksack 'roots) - (class-index-table rucksack) - (slot-index-tables rucksack)) + (and (slot-boundp rucksack 'class-index-table) + (slot-value rucksack 'class-index-table)) + (and (slot-boundp rucksack 'slot-index-tables) + (slot-value rucksack 'slot-index-tables))) (rucksack-roots-pathname rucksack)) (setf (roots-changed-p rucksack) nil)) @@ -403,9 +490,11 @@ (rucksack-commit rucksack)) (defmethod rucksack-commit ((rucksack standard-rucksack)) - (cache-commit (rucksack-cache rucksack)) - (when (roots-changed-p rucksack) - (save-roots rucksack))) + (when (or (roots-changed-p rucksack) + (not (slot-boundp rucksack 'class-index-table)) + (not (slot-boundp rucksack 'slot-index-tables))) + (save-roots rucksack)) + (cache-commit (rucksack-cache rucksack))) ;; ;; Rollback @@ -550,13 +639,13 @@ &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) - (when (and errorp (gethash class (class-index-table rucksack))) + (when (and errorp (btree-search (class-index-table rucksack) class + :errorp nil :default-value nil)) (simple-rucksack-error "Class index for ~S already exists in ~A." class rucksack)) (let ((index (rucksack-make-class-index rucksack class))) - (setf (gethash class (class-index-table rucksack)) index) - (add-rucksack-root index rucksack) + (btree-insert class index :if-exists :overwrite) index)) (defmethod rucksack-make-class-index @@ -571,14 +660,16 @@ &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) - (when (and errorp - (not (gethash class (class-index-table rucksack)))) - (simple-rucksack-error "Class index for ~S doesn't exist in ~A." - class - rucksack)) - (let ((index (gethash class (class-index-table rucksack)))) - (remhash class (class-index-table rucksack)) - (delete-rucksack-root index rucksack))) + (handler-bind ((btree-deletion-error + ;; Translate a btree error to something that makes more sense + ;; in this context. + (lambda (error) + (declare (ignore error)) + (simple-rucksack-error "Class index for ~S doesn't exist in ~A." + class + rucksack)))) + (btree-delete-key class + :if-does-not-exist (if errorp :error :ignore)))) (defmethod rucksack-map-class-indexes (rucksack function) @@ -588,11 +679,19 @@ &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) - (or (gethash class (class-index-table rucksack)) - (and errorp - (simple-rucksack-error "Can't find class index for ~S in ~A." - class - rucksack)))) + (and (slot-boundp rucksack 'class-index-table) + (handler-bind ((btree-search-error + ;; Translate a btree error to something that makes more sense + ;; in this context. + (lambda (error) + (declare (ignore error)) + (simple-rucksack-error "Can't find class index for ~S in ~A." + class + rucksack)))) + (btree-search (class-index-table rucksack) class + :errorp errorp + :default-value nil)))) + (defmethod rucksack-maybe-index-new-object ((rucksack standard-rucksack) class object) @@ -640,67 +739,72 @@ ;; Find the slot index table for CLASS, create a slot index and add that ;; index to the table. (let* ((slot-index-tables (slot-index-tables rucksack)) - (slot-index-table (or (gethash class slot-index-tables) - (let ((table (make-hash-table))) - (setf (gethash class slot-index-tables) table) - table))) - (new-slot-index (make-index index-spec unique-p)) - (old-slot-index (gethash slot slot-index-table))) - ;; Add a new slot index table if necessary. - (when (and errorp old-slot-index) - (simple-rucksack-error "Slot index for slot ~S of class ~S + (slot-index-table + (or (btree-search slot-index-tables class :errorp nil) + (let ((table (make-instance 'btree + :key< 'string< + :value= 'p-eql + :unique-keys-p t))) + (btree-insert table slot-index-tables :if-exists :error) + table))) + (new-slot-index (make-index index-spec unique-p))) + (handler-bind ((btree-key-already-present-error + (lambda (error) + (declare (ignore error)) + (simple-rucksack-error "Slot index for slot ~S of class ~S already exists in ~A." - slot - class - rucksack)) - (add-rucksack-root new-slot-index rucksack) - (when old-slot-index - (delete-rucksack-root old-slot-index rucksack)) - (setf (gethash slot slot-index-table) new-slot-index))) + slot + class + rucksack)))) + (btree-insert slot slot-index-table new-slot-index + :if-exists (if errorp :error :overwrite))) + new-slot-index)) + (defmethod rucksack-remove-slot-index (rucksack class slot &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) (unless (symbolp slot) (setq slot (slot-definition-name slot))) - (flet ((oops () + (flet ((oops (error) + (declare (ignore error)) (simple-rucksack-error "Attempt to remove non-existing slot index for slot ~S of class ~S in ~A." slot class rucksack))) - (let ((slot-index-table (gethash class (slot-index-tables rucksack)))) - (if slot-index-table - (if errorp - (let ((index (gethash slot slot-index-table))) - (if index - (progn - (remhash slot slot-index-table) - (delete-rucksack-root index rucksack)) - (oops))) - (remhash slot slot-index-table)) - (and errorp (oops)))))) + ;; Return the slot name if everything went fine; otherwise, return + ;; NIL (or signal an error). + (and (handler-bind ((btree-search-error #'oops)) + + (let ((slot-index-table (btree-search (slot-index-tables rucksack) class + :errorp errorp))) + (handler-bind ((btree-deletion-error #'oops)) + (btree-delete-key slot slot-index-table + :if-does-not-exist (if errorp :error :ignore))))) + slot))) (defmethod rucksack-map-slot-indexes ((rucksack standard-rucksack) function &key (class t) (include-subclasses t)) (if (eql class t) - (maphash (lambda (class slot-index-table) - (maphash (lambda (slot slot-index) - (funcall function class slot slot-index)) - slot-index-table)) - (slot-index-tables rucksack)) + (map-btree (slot-index-tables rucksack) + (lambda (class slot-index-table) + (map-btree slot-index-table + (lambda (slot slot-index) + (funcall function class slot slot-index))))) (let ((visited-p (make-hash-table))) (flet ((map-indexes (class) (unless (gethash class visited-p) - (let ((slot-index-table (gethash (class-name class) - (slot-index-tables rucksack)))) + (let ((slot-index-table (btree-search (slot-index-tables rucksack) + (class-name class) + :errorp nil))) (when slot-index-table - (maphash (lambda (slot slot-index) - (funcall function (class-name class) - slot - slot-index)) - slot-index-table))) + (map-btree slot-index-table + (lambda (slot slot-index) + (funcall function (class-name class) + slot + slot-index))))) (setf (gethash class visited-p) t) (when include-subclasses (mapc #'map-indexes @@ -728,12 +832,12 @@ (setq slot (slot-definition-name slot))) (let ((slot-index-tables (slot-index-tables rucksack))) (flet ((find-index (class) - (let ((slot-index-table (gethash class slot-index-tables))) + (let ((slot-index-table (btree-search slot-index-tables class + :errorp nil))) (and slot-index-table - (gethash slot slot-index-table))))) + (btree-search slot-index-table slot :errorp nil))))) (or (find-index class) - (loop for superclass in (class-precedence-list - (find-class class)) + (loop for superclass in (class-precedence-list (find-class class)) thereis (find-index (class-name superclass))) (and errorp (simple-rucksack-error --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/11 12:44:21 1.6 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/24 15:21:25 1.7 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.6 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: serialize.lisp,v 1.7 2006/08/24 15:21:25 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -1124,6 +1124,11 @@ do (scan serializer gc)))) +(defmethod scan-contents ((marker (eql +unbound-slot+)) serializer gc) + ;; Just skip the marker and continue. + :do-nothing) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Structures ;;; --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/11 12:44:21 1.10 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:21:25 1.11 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: test.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ (in-package :test-rucksack) @@ -26,7 +26,7 @@ (defclass p-thing-1 () () (:metaclass persistent-class)) - + (defclass p-thing-2 () ((x :initarg :x :reader x-of :persistence t)) (:metaclass persistent-class)) @@ -258,7 +258,7 @@ (format t "~&Deleting~%") (let ((btree (first (rucksack-roots rucksack)))) (dotimes (i delete) - (when (zerop (mod (1+ i) 1000)) + (when (zerop (mod (1+ i) 100)) (format t "~D " (1+ i))) (btree-delete-key btree (aref array i))) (check-order btree) --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/10 12:36:17 1.10 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/24 15:21:25 1.11 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.10 2006/08/10 12:36:17 alemmens Exp $ +;; $Id: transactions.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ (in-package :rucksack) @@ -58,8 +58,6 @@ (transaction-id transaction) (hash-table-count (dirty-objects transaction))))) -(defparameter *transaction* nil - "The currently active transaction.") (defun current-transaction () *transaction*) @@ -181,45 +179,48 @@ (cache standard-cache) (rucksack standard-rucksack)) ;; Save all dirty objects to disk. - ;; 1. Create the commit file - (create-commit-file transaction cache) - ;; 2. Commit all dirty objects. - ;; Q: What if this is interleaved with other commits? - (let ((queue (dirty-queue transaction)) - (table (dirty-objects transaction)) - (heap (heap cache)) - nr-allocated-octets) - (with-allocation-counter (heap) - (loop until (queue-empty-p queue) - do (let* ((id (queue-remove queue)) - (object (gethash id table))) - (when object - ;; If it's not in the dirty-objects table anymore, the - ;; object was already saved during this transaction-commit. - ;; That's possible, because the queue can contain duplicates. - (save-dirty-object object cache transaction id) - ;; Remove from hash-table too. - (remhash id table)))) - (setq nr-allocated-octets (nr-allocated-octets heap))) - ;; Check for consistency between hash table and queue. - (unless (zerop (hash-table-count table)) - (internal-rucksack-error - "Mismatch between dirty hash-table and queue while committing ~S: + (if (zerop (transaction-nr-dirty-objects transaction)) + (close-transaction cache transaction) + (progn + ;; 1. Create the commit file + (create-commit-file transaction cache) + ;; 2. Commit all dirty objects. + ;; Q: What if this is interleaved with other commits? + (let ((queue (dirty-queue transaction)) + (table (dirty-objects transaction)) + (heap (heap cache)) + nr-allocated-octets) + (with-allocation-counter (heap) + (loop until (queue-empty-p queue) + do (let* ((id (queue-remove queue)) + (object (gethash id table))) + (when object + ;; If it's not in the dirty-objects table anymore, the + ;; object was already saved during this transaction-commit. + ;; That's possible, because the queue can contain duplicates. + (save-dirty-object object cache transaction id) + ;; Remove from hash-table too. + (remhash id table)))) + (setq nr-allocated-octets (nr-allocated-octets heap))) + ;; Check for consistency between hash table and queue. + (unless (zerop (hash-table-count table)) + (internal-rucksack-error + "Mismatch between dirty hash-table and queue while committing ~S: ~D objects left in hash-table." - transaction - (hash-table-count table))) - ;; 3. Remove transaction from the cache's open transactions. - (close-transaction cache transaction) - ;; 4. Delete the commit file to indicate that everything went fine - ;; and we don't need to recover from this commit. - (delete-commit-file transaction cache) - ;; 5. Let the garbage collector do an amount of work proportional - ;; to the number of octets that were allocated during the commit. - (collect-some-garbage heap - (gc-work-for-size heap nr-allocated-octets)) - ;; 6. Make sure that all changes are actually on disk before - ;; we continue. - (finish-all-output rucksack))) + transaction + (hash-table-count table))) + ;; 3. Remove transaction from the cache's open transactions. + (close-transaction cache transaction) + ;; 4. Delete the commit file to indicate that everything went fine + ;; and we don't need to recover from this commit. + (delete-commit-file transaction cache) + ;; 5. Let the garbage collector do an amount of work proportional + ;; to the number of octets that were allocated during the commit. + (collect-some-garbage heap + (gc-work-for-size heap nr-allocated-octets)) + ;; 6. Make sure that all changes are actually on disk before + ;; we continue. + (finish-all-output rucksack))))) (defmethod finish-all-output ((rucksack standard-rucksack)) (let ((cache (rucksack-cache rucksack))) @@ -362,42 +363,6 @@ (close-transaction cache transaction)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; WITH-TRANSACTION -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmacro with-transaction ((&rest args - &key (rucksack '(current-rucksack)) - &allow-other-keys) - &body body) - (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 - ,@(sans args :rucksack))) - (let ((*transaction* ,transaction)) - (with-simple-restart (abort "Abort ~S" ,transaction) - (setf ,result (progn , 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 ,result ,committed))) - (unless ,committed - (transaction-rollback ,transaction))))) - ;; Normal exit from the above block -- we selected the RETRY restart. - )))) From alemmens at common-lisp.net Thu Aug 24 15:45:02 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 24 Aug 2006 11:45:02 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060824154502.DE4BE2200F@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv13062 Modified Files: make.lisp test.lisp Log Message: Put TEST back. --- /project/rucksack/cvsroot/rucksack/make.lisp 2006/08/24 15:21:25 1.4 +++ /project/rucksack/cvsroot/rucksack/make.lisp 2006/08/24 15:45:02 1.5 @@ -1,4 +1,4 @@ -;; $Id: make.lisp,v 1.4 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: make.lisp,v 1.5 2006/08/24 15:45:02 alemmens Exp $ (in-package :cl-user) @@ -23,7 +23,7 @@ "index" "rucksack" "transactions" - #+nil "test") + "test") do (tagbody :retry (let ((lisp (make-pathname :name file --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:21:25 1.11 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:45:02 1.12 @@ -1,4 +1,4 @@ -;; $Id: test.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: test.lisp,v 1.12 2006/08/24 15:45:02 alemmens Exp $ (in-package :test-rucksack) @@ -381,7 +381,7 @@ (defun btree-stress-test (&key (n 1000)) (loop for i below n do (print i) - do (test-non-unique-btree :n 1600 :node-size 12 :delete 1500))) + do (test-non-unique-btree :n 1600 :node-size 10 :delete 1500))) (defun test-btree-map (&key (display t) min max include-min include-max (order :ascending)) From alemmens at common-lisp.net Sat Aug 26 12:55:35 2006 From: alemmens at common-lisp.net (alemmens) Date: Sat, 26 Aug 2006 08:55:35 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060826125535.B961D710E7@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv9635 Modified Files: example-1.lisp index.lisp mop.lisp objects.lisp p-btrees.lisp rucksack.lisp Log Message: Make sure that indexing works correctly with subclasses. Fix some more indexing bugs. --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/11 12:52:53 1.1 +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/26 12:55:34 1.2 @@ -1,40 +1,52 @@ -;; $Id: example-1.lisp,v 1.1 2006/08/11 12:52:53 alemmens Exp $ +;; $Id: example-1.lisp,v 1.2 2006/08/26 12:55:34 alemmens Exp $ (in-package :test-rucksack) -;; NOTE: This example doesn't run at the moment, because indexing doesn't -;; work correctly yet. +;; NOTE: At the moment, this example works only when this file is compiled +;; exactly once. After the second compile, slot indexing will fail (because +;; ENSURE-CLASS-SCHEMA isn't complete yet). ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing, class redefinitions ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defparameter *example-1* #p"/tmp/rucksack/example-1/") +(eval-when (:compile-toplevel :load-toplevel :execute) + (defparameter *example-1* #p"/tmp/rucksack/example-1/")) (defparameter *hackers* '("David" "Jim" "Peter" "Thomas" "Arthur" "Jans" "Klaus" "James" "Martin")) -(with-rucksack (rucksack *example-1* :if-exists :supersede) - (with-transaction () +(defun random-elt (list) + (elt list (random (length list)))) - ;; For classes that may change during program development, you should - ;; wrap all class definitions in a WITH-RUCKSACK to make sure that - ;; the corresponding schema definitions and indexes are updated correctly. - ;; (This is only necessary if you already have a rucksack that contains - ;; instances of the class that's being redefined, of course.) +(eval-when (:compile-toplevel) + (with-rucksack (*rucksack* *example-1* :if-exists :supersede) + (with-transaction () + + ;; For classes that may change during program development, you should + ;; wrap all class definitions in a WITH-RUCKSACK to make sure that + ;; the corresponding schema definitions and indexes are updated correctly. + ;; (This is only necessary if you already have a rucksack that contains + ;; instances of the class that's being redefined, of course.) - ;; Define a class hacker - (defclass hacker () - ((id :initform (gensym "HACKER-") - :reader hacker-id - :index :symbol-index - :unique t) - (name :initform (elt *hackers* (random (length *hackers*))) - :accessor name - :index :case-insensitive-string-index) - (age :initform (random 100) :accessor age)) - (:metaclass persistent-class)))) - + (defclass hacker () + ((id :initform (gensym "HACKER-") + :reader hacker-id + :index :symbol-index + :unique t) + (name :initform (random-elt *hackers*) + :accessor name + :index :case-insensitive-string-index) + (age :initform (random 100) :accessor age + :index :number-index)) + (:metaclass persistent-class) + (:index t)) + + (defclass lisp-hacker (hacker) + () + (:metaclass persistent-class) + (:index t))))) + (defmethod print-object ((hacker hacker) stream) (print-unreadable-object (hacker stream :type t) @@ -44,21 +56,35 @@ (age hacker)))) (defun example-1 () - (with-rucksack (rucksack *example-1*) + (with-rucksack (*rucksack* *example-1*) ;; Fill the rucksack with some hackers. (with-transaction () - (loop repeat 1000 + (loop repeat 20 do (make-instance 'hacker)) - #+nil - (rucksack-map-slot rucksack 'hacker 'name - (lambda (hacker) - (print-object hacker *standard-output*) - (terpri)))))) + (loop repeat 10 + do (make-instance 'lisp-hacker)) + (rucksack-map-class *rucksack* 'hacker #'print)))) (defun show-hackers () - (with-rucksack (rucksack *example-1*) - (rucksack-map-class rucksack 'hacker - (lambda (hacker) - (print-object hacker *standard-output*) - (terpri))))) - + (with-rucksack (*rucksack* *example-1*) + (with-transaction () + (print "Hackers indexed by object id.") + (rucksack-map-class *rucksack* 'hacker #'print) + (print "Hackers indexed by name.") + (rucksack-map-slot *rucksack* 'hacker 'name #'print) + (print "Hackers indexed by hacker-id.") + (rucksack-map-slot *rucksack* 'hacker 'id #'print) + (print "Lisp hackers.") + (rucksack-map-class *rucksack* 'lisp-hacker #'print) + (print "Non-lisp hackers.") + (rucksack-map-class *rucksack* 'hacker #'print + :include-subclasses nil) + (print "Hacker object ids.") + (rucksack-map-class *rucksack* 'hacker #'print + :id-only t)))) + +(defun show-indexes () + (with-rucksack (r *example-1*) + (print (rs::rucksack-list-class-indexes r)) + (print (rs::rucksack-list-slot-indexes r)) + :ok)) --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/11 12:44:21 1.5 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/26 12:55:34 1.6 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: index.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $ (in-package :rucksack) @@ -15,7 +15,7 @@ If EQUAL is specified, the other arguments are ignored; the function will be called once (if there is a key with the same value as EQUAL) -or zero time (if there is no such key). +or not at all (if there is no such key). MIN, MAX, INCLUDE-MIN and INCLUDE-MAX specify the interval. The interval is left-open if MIN is nil, right-open if MAX is nil. The @@ -46,10 +46,15 @@ (defmethod map-index ((index btree) function &rest args - &key equal min max include-min include-max + &key min max include-min include-max + (equal nil equal-supplied) (order :ascending)) - (declare (ignorable equal min max include-min include-max)) - (apply #'map-btree index function :order order args)) + (declare (ignorable min max include-min include-max)) + (if equal-supplied + (let ((value (btree-search index equal :errorp nil :default-value index))) + (unless (p-eql value index) + (funcall function equal value))) + (apply #'map-btree index function :order order args))) (defmethod index-insert ((index btree) key value &key (if-exists :overwrite)) --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/11 12:44:21 1.5 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/26 12:55:34 1.6 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.5 2006/08/11 12:44:21 alemmens Exp $ +;; $Id: mop.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $ (in-package :rucksack) @@ -15,7 +15,7 @@ :accessor class-persistent-slots) (index :initarg :index :initform nil :accessor class-index :documentation "Can be either NIL (for no class index) or T -(for the standard class index). Default value is T."))) +(for the standard class index). Default value is NIL."))) (defclass persistent-slot-mixin () ((persistence :initarg :persistence @@ -148,7 +148,8 @@ (defun ensure-class-schema (class old-slot-indexes) ;; Update class and slot indexes. - (when (some #'slot-persistence (class-direct-slots class)) + (when (or (class-index class) + (some #'slot-persistence (class-direct-slots class))) ;; NOTE: We get the current-rucksack only if there are some ;; persistent slots, because this will also get called during ;; compilation of Rucksack (when the class definition of --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/24 15:21:25 1.9 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/26 12:55:34 1.10 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.9 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: objects.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $ (in-package :rucksack) @@ -404,7 +404,12 @@ (defmethod shared-initialize :before ((object persistent-object) slots - &key rucksack &allow-other-keys) + &key rucksack + ;; The DONT-INDEX argument is used + ;; when creating the indexes themselves + ;; (to prevent infinite recursion). + (dont-index nil) + &allow-other-keys) ;; This happens when persistent-objects are created in memory, not when ;; they're loaded from the cache (loading uses ALLOCATE-INSTANCE instead). (let ((rucksack (or rucksack (rucksack object)))) @@ -414,7 +419,24 @@ ;; DO: Explain why we don't set the transaction-id slot here. (unless (slot-boundp object 'rucksack) (setf (slot-value object 'rucksack) rucksack)) - (rucksack-maybe-index-new-object rucksack (class-of object) object))) + (unless dont-index + (rucksack-maybe-index-new-object rucksack (class-of object) object)))) + +(defmethod shared-initialize :after ((object persistent-object) slots + &key rucksack + (dont-index nil) + &allow-other-keys) + ;; Update slot indexes for persistent slots that are bound now. + (unless dont-index + (let ((class (class-of object))) + (dolist (slot (class-slots class)) + (let ((slot-name (slot-definition-name slot))) + (when (and (slot-boundp object slot-name) + (slot-persistence slot)) + (rucksack-maybe-index-changed-slot rucksack + class object slot + nil (slot-value object slot-name) + nil t))))))) (defmethod print-object ((object persistent-object) stream) --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/10 12:36:16 1.9 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/26 12:55:34 1.10 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $ (in-package :rucksack) @@ -751,7 +751,8 @@ :btree btree :key key :value value))))) - (let ((binding (node-search-binding btree (btree-root btree) key))) + (let ((binding (and (slot-boundp btree 'root) + (node-search-binding btree (btree-root btree) key)))) (cond ((not binding) ;; The binding doesn't exist: forget it. (forget-it)) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/24 15:21:25 1.11 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/26 12:55:34 1.12 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.12 2006/08/26 12:55:34 alemmens Exp $ (in-package :rucksack) @@ -109,7 +109,8 @@ -(defgeneric rucksack-slot-index (rucksack class-designator slot &key errorp) +(defgeneric rucksack-slot-index (rucksack class-designator slot + &key errorp include-superclasses) (:documentation "Returns the slot index for the slot specified by CLASS-DESIGNATOR and SLOT.")) @@ -314,8 +315,10 @@ :rucksack rucksack :key< 'string< :value= 'p-eql - :unique-keys-p t))) - (setf (slot-value rucksack 'class-index-table) (object-id btree)))) + :unique-keys-p t + :dont-index t))) + (setf (slot-value rucksack 'class-index-table) (object-id btree) + (roots-changed-p rucksack) t))) (cache-get-object (slot-value rucksack 'class-index-table) (rucksack-cache rucksack)))) (if (current-transaction) @@ -332,8 +335,10 @@ :rucksack rucksack :key< 'string< :value= 'p-eql - :unique-keys-p t))) - (setf (slot-value rucksack 'slot-index-tables) (object-id btree)))) + :unique-keys-p t + :dont-index t))) + (setf (slot-value rucksack 'slot-index-tables) (object-id btree) + (roots-changed-p rucksack) t))) ;; (cache-get-object (slot-value rucksack 'slot-index-tables) (rucksack-cache rucksack)))) @@ -365,7 +370,7 @@ (when (probe-file roots-file) (destructuring-bind (root-list class-index slot-index) (load-objects roots-file) - (with-slots (roots class-index-table slot-index-tables cache) + (with-slots (roots class-index-table slot-index-tables) rucksack (setf roots root-list) (when class-index @@ -645,7 +650,8 @@ class rucksack)) (let ((index (rucksack-make-class-index rucksack class))) - (btree-insert class index :if-exists :overwrite) + (btree-insert (class-index-table rucksack) class index + :if-exists :overwrite) index)) (defmethod rucksack-make-class-index @@ -673,24 +679,23 @@ (defmethod rucksack-map-class-indexes (rucksack function) - (maphash function (class-index-table rucksack))) + (map-btree (class-index-table rucksack) function)) (defmethod rucksack-class-index ((rucksack standard-rucksack) class &key (errorp nil)) (unless (symbolp class) (setq class (class-name class))) - (and (slot-boundp rucksack 'class-index-table) - (handler-bind ((btree-search-error - ;; Translate a btree error to something that makes more sense - ;; in this context. - (lambda (error) - (declare (ignore error)) - (simple-rucksack-error "Can't find class index for ~S in ~A." - class - rucksack)))) - (btree-search (class-index-table rucksack) class - :errorp errorp - :default-value nil)))) + (handler-bind ((btree-search-error + ;; Translate a btree error to something that makes more sense + ;; in this context. + (lambda (error) + (declare (ignore error)) + (simple-rucksack-error "Can't find class index for ~S in ~A." + class + rucksack)))) + (btree-search (class-index-table rucksack) class + :errorp errorp + :default-value nil))) (defmethod rucksack-maybe-index-new-object ((rucksack standard-rucksack) @@ -745,7 +750,7 @@ :key< 'string< :value= 'p-eql :unique-keys-p t))) - (btree-insert table slot-index-tables :if-exists :error) + (btree-insert slot-index-tables class table :if-exists :error) table))) (new-slot-index (make-index index-spec unique-p))) (handler-bind ((btree-key-already-present-error @@ -756,7 +761,7 @@ slot class rucksack)))) - (btree-insert slot slot-index-table new-slot-index + (btree-insert slot-index-table slot new-slot-index :if-exists (if errorp :error :overwrite))) new-slot-index)) @@ -816,16 +821,19 @@ class object slot old-value new-value old-boundp new-boundp) - (let ((index (rucksack-slot-index rucksack class slot))) + (let ((index (rucksack-slot-index rucksack class slot + :errorp nil + :include-superclasses t))) (when index - (when old-boundp - (index-delete index old-value object :if-does-not-exist :ignore)) - (when new-boundp - (index-insert index new-value object))))) + (let ((id (object-id object))) + (when old-boundp + (index-delete index old-value id :if-does-not-exist :ignore)) + (when new-boundp + (index-insert index new-value id)))))) (defmethod rucksack-slot-index ((rucksack standard-rucksack) class slot - &key (errorp nil)) + &key (errorp nil) (include-superclasses nil)) (unless (symbolp class) (setq class (class-name class))) (unless (symbolp slot) @@ -837,8 +845,9 @@ (and slot-index-table (btree-search slot-index-table slot :errorp nil))))) (or (find-index class) - (loop for superclass in (class-precedence-list (find-class class)) - thereis (find-index (class-name superclass))) + (and include-superclasses + (loop for superclass in (class-precedence-list (find-class class)) + thereis (find-index (class-name superclass)))) (and errorp (simple-rucksack-error "Can't find slot index for slot ~S of class ~S in ~A." @@ -848,7 +857,8 @@ (defmethod rucksack-map-slot ((rucksack standard-rucksack) class slot function - &key equal min max include-min include-max + &key min max include-min include-max + (equal nil equal-supplied) (order :ascending) (id-only nil) (include-subclasses t)) (let ((cache (rucksack-cache rucksack)) @@ -858,19 +868,20 @@ :errorp nil))) (when index ;; The index maps slot values to object ids. - (map-index index - (lambda (slot-value object-id) - (declare (ignore slot-value)) - (if id-only - (funcall function object-id) - (funcall function - (cache-get-object object-id cache)))) - :equal equal - :min min - :max max - :include-min include-min - :include-max include-max - :order order) + (apply #'map-index + index + (lambda (slot-value object-id) + (declare (ignore slot-value)) + (if id-only + (funcall function object-id) + (funcall function + (cache-get-object object-id cache)))) + :min min + :max max + :include-min include-min + :include-max include-max + :order order + (if equal-supplied (list :equal equal) '())) (setf (gethash class visited-p) t)) (when include-subclasses (loop for class in (class-direct-subclasses @@ -881,3 +892,25 @@ do (map-slot class)))))) (map-slot (if (symbolp class) (find-class class) class))))) +;; +;; Debugging +;; + +(defun rucksack-list-slot-indexes (rucksack) + (let ((result '())) + (with-transaction () + (rucksack-map-slot-indexes rucksack + (lambda (class-name slot-name slot-index) + (declare (ignore slot-index)) + (push (cons class-name slot-name) + result)))) + result)) + +(defun rucksack-list-class-indexes (rucksack) + (let ((result '())) + (with-transaction () + (rucksack-map-class-indexes rucksack + (lambda (class-name index) + (declare (ignore index)) + (push class-name result)))) + result)) From alemmens at common-lisp.net Tue Aug 29 11:41:41 2006 From: alemmens at common-lisp.net (alemmens) Date: Tue, 29 Aug 2006 07:41:41 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060829114141.54C0F50014@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv5405 Modified Files: example-1.lisp mop.lisp objects.lisp rucksack.lisp schema-table.lisp serialize.lisp Log Message: Some work on schema updates. Example 1: indexing should still work after recompiling. RUCKSACK-UPDATE-SLOT-INDEXES: remove indexes for old slots that don exist anymore. Compute persistent slots at the right moment. --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/26 12:55:34 1.2 +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 11:41:40 1.3 @@ -1,34 +1,34 @@ -;; $Id: example-1.lisp,v 1.2 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: example-1.lisp,v 1.3 2006/08/29 11:41:40 alemmens Exp $ (in-package :test-rucksack) -;; NOTE: At the moment, this example works only when this file is compiled -;; exactly once. After the second compile, slot indexing will fail (because -;; ENSURE-CLASS-SCHEMA isn't complete yet). - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indexing, class redefinitions +;;; Indexing example +;;; +;;; To run this example: +;;; - compile and load this file +;;; - (CREATE-HACKERS) +;;; - (SHOW-HACKERS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(eval-when (:compile-toplevel :load-toplevel :execute) - (defparameter *example-1* #p"/tmp/rucksack/example-1/")) - (defparameter *hackers* '("David" "Jim" "Peter" "Thomas" "Arthur" "Jans" "Klaus" "James" "Martin")) (defun random-elt (list) (elt list (random (length list)))) -(eval-when (:compile-toplevel) - (with-rucksack (*rucksack* *example-1* :if-exists :supersede) + +(eval-when (:compile-toplevel :load-toplevel :execute) + + (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/") + + (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () - ;; For classes that may change during program development, you should - ;; wrap all class definitions in a WITH-RUCKSACK to make sure that - ;; the corresponding schema definitions and indexes are updated correctly. - ;; (This is only necessary if you already have a rucksack that contains - ;; instances of the class that's being redefined, of course.) - + ;; We define some persistent classes with indexed slots. + ;; So we must wrap the class definition in a WITH-RUCKSACK, + ;; otherwise the indexes can't be built. + (defclass hacker () ((id :initform (gensym "HACKER-") :reader hacker-id @@ -36,12 +36,10 @@ :unique t) (name :initform (random-elt *hackers*) :accessor name - :index :case-insensitive-string-index) - (age :initform (random 100) :accessor age - :index :number-index)) + :index :case-insensitive-string-index)) (:metaclass persistent-class) (:index t)) - + (defclass lisp-hacker (hacker) () (:metaclass persistent-class) @@ -50,13 +48,12 @@ (defmethod print-object ((hacker hacker) stream) (print-unreadable-object (hacker stream :type t) - (format stream "~S called ~S of age ~D" + (format stream "~S called ~S" (hacker-id hacker) - (name hacker) - (age hacker)))) + (name hacker)))) -(defun example-1 () - (with-rucksack (*rucksack* *example-1*) +(defun create-hackers () + (with-rucksack (*rucksack* *hacker-rucksack*) ;; Fill the rucksack with some hackers. (with-transaction () (loop repeat 20 @@ -66,7 +63,7 @@ (rucksack-map-class *rucksack* 'hacker #'print)))) (defun show-hackers () - (with-rucksack (*rucksack* *example-1*) + (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () (print "Hackers indexed by object id.") (rucksack-map-class *rucksack* 'hacker #'print) @@ -84,7 +81,215 @@ :id-only t)))) (defun show-indexes () - (with-rucksack (r *example-1*) + (with-rucksack (r *hacker-rucksack*) (print (rs::rucksack-list-class-indexes r)) (print (rs::rucksack-list-slot-indexes r)) :ok)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Example output +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| + +CL-USER 2 > (in-package :test-rs) +# + +TEST-RS 3 > (create-hackers) + +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +NIL +T + +TEST-RS 4 > (show-hackers) + +"Hackers indexed by object id." +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +"Hackers indexed by name." +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +"Hackers indexed by hacker-id." +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +"Lisp hackers." +# +# +# +# +# +# +# +# +# +# +"Non-lisp hackers." +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +# +"Hacker object ids." +36 +65 +69 +73 +78 +83 +88 +92 +96 +100 +104 +109 +113 +117 +122 +126 +130 +135 +139 +144 +148 +160 +164 +168 +173 +177 +181 +185 +189 +193 +NIL +T + +|# --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/26 12:55:34 1.6 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/29 11:41:40 1.7 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: mop.lisp,v 1.7 2006/08/29 11:41:40 alemmens Exp $ (in-package :rucksack) @@ -48,6 +48,47 @@ ()) +;; +;; Copying and comparing slot definitions +;; + +(defun copy-slot-definition (slot-def) + (make-instance (class-of slot-def) + :name (slot-definition-name slot-def) + :initargs (slot-definition-initargs slot-def) + :readers (slot-definition-readers slot-def) + :writers (slot-definition-writers slot-def) + :allocation (slot-definition-allocation slot-def) + :type (slot-definition-type slot-def) + ;; Our own options. + :persistence (slot-persistence slot-def) + :index (slot-index slot-def) + :unique (slot-unique slot-def))) + + +(defun slot-definition-equal (slot-1 slot-2) + (and (equal (slot-persistence slot-1) (slot-persistence slot-2)) + (index-spec-equal (slot-index slot-1) (slot-index slot-2)) + (equal (slot-unique slot-1) (slot-unique slot-2)))) + + +(defun compare-slots (old-slots slots) + "Returns three values: a list of added slots, a list of discarded slots +and a list of changed (according to SLOT-DEFINITION-EQUAL) slots." + (let ((added-slots (set-difference slots old-slots + :key #'slot-definition-name)) + (discarded-slots (set-difference old-slots slots + :key #'slot-definition-name)) + (changed-slots + (loop for slot in slots + for old-slot = (find (slot-definition-name slot) old-slots + :key #'slot-definition-name) + if (and old-slot + (not (slot-definition-equal slot old-slot))) + collect slot))) + (values added-slots discarded-slots changed-slots))) + + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defmethod validate-superclass ((class standard-class) @@ -78,8 +119,8 @@ (defmethod clos:process-a-class-option ((class persistent-class) option-name value) - (if (member value '(:index :unique)) - (list option-name value) + (if (eql option-name :index) + (cons option-name value) (call-next-method))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -108,28 +149,23 @@ (ensure-class-schema class '()) result)) + (defmethod reinitialize-instance :around ((class persistent-class) &rest args &key direct-superclasses &allow-other-keys) - (let* ((old-slot-defs (class-direct-slots class)) - ;; Create a simple alist with slot name as key and - ;; a list with slot-index and slot-unique as value. - (old-slot-indexes (loop for slot-def in old-slot-defs - collect (list (slot-definition-name slot-def) - (slot-index slot-def) - (slot-unique slot-def))))) - (let ((result (apply #'call-next-method - class - :direct-superclasses (maybe-add-persistent-object-class - class - direct-superclasses) - ;; Tell Lispworks that it shouldn't bypass - ;; slot-value-using-class. - #+lispworks :optimize-slot-access #+lispworks nil - args))) - (ensure-class-schema class old-slot-indexes) - result))) + (let* ((old-slots (mapcar #'copy-slot-definition (class-direct-slots class))) + (result (apply #'call-next-method + class + :direct-superclasses (maybe-add-persistent-object-class + class + direct-superclasses) + ;; Tell Lispworks that it shouldn't bypass + ;; SLOT-VALUE-USING-CLASS. + #+lispworks :optimize-slot-access #+lispworks nil + args))) + (ensure-class-schema class old-slots) + result)) (defun maybe-add-persistent-object-class (class direct-superclasses) @@ -146,7 +182,7 @@ direct-superclasses (cons root-class direct-superclasses)))) -(defun ensure-class-schema (class old-slot-indexes) +(defun ensure-class-schema (class old-slots) ;; Update class and slot indexes. (when (or (class-index class) (some #'slot-persistence (class-direct-slots class))) @@ -158,15 +194,25 @@ (let ((rucksack (current-rucksack))) (when rucksack (rucksack-update-class-index rucksack class) - (rucksack-update-slot-indexes rucksack class old-slot-indexes)))) - ;; DO: Update schema in schema table, when necessary. - 'DO-THIS) + (rucksack-update-slot-indexes rucksack class old-slots) + ;; Update schema in schema table, if necessary. + (rucksack-maybe-update-schema rucksack class old-slots))))) (defmethod finalize-inheritance :after ((class persistent-class)) ;; Register all persistent slots. (setf (class-persistent-slots class) - (remove-if-not #'slot-persistence (class-slots class)))) + (remove-if-not #'slot-persistence (class-slots class))) + ;; + (when (or (class-index class) (class-persistent-slots class)) + (let ((rucksack (current-rucksack))) + (when rucksack + (let* ((schema-table (schema-table (rucksack-cache rucksack))) + (schema (find-schema-for-class schema-table class))) + (when schema + (setf (persistent-slot-names schema) + (mapcar #'slot-definition-name + (class-persistent-slots class))))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -211,5 +257,3 @@ ;; Return the effective slot definition. effective-slotdef)) - - --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/26 12:55:34 1.10 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 11:41:40 1.11 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: objects.lisp,v 1.11 2006/08/29 11:41:40 alemmens Exp $ (in-package :rucksack) @@ -396,9 +396,9 @@ (rucksack :initarg :rucksack :reader rucksack :persistence nil :index nil)) (:default-initargs :rucksack *rucksack*) - (:metaclass persistent-class - :indexed nil - :documentation "Classes of metaclass PERSISTENT-CLASS automatically + (:metaclass persistent-class) + (:index nil) + (:documentation "Classes of metaclass PERSISTENT-CLASS automatically inherit from this class.")) @@ -733,3 +733,28 @@ (internal-rucksack-error "Object-id mismatch (required: ~D; actual: ~D)." object-id id)) (values id nr-slots schema-id transaction-id prev-version))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Updating persistent instances +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; When a persistent object must be loaded from disk, Rucksack loads the +;; schema nr and finds the corresponding schema. If the schema is obsolete +;; (i.e. there is a schema for the same class with a higher version number), +;; Rucksack calls the generic function UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS +;; after calling ALLOCATE-INSTANCE for the current class version. The generic +;; function is very similar to UPDATE-INSTANCE-FOR-REDEFINED-CLASS: it takes a +;; list of added slots, a list of deleted slots and a property list containing +;; the slot names and values for slots that were discarded and had values. + +(defgeneric update-persistent-instance-for-redefined-class + (instance added-slots discarded-slots property-list + &rest initargs &key &allow-other-keys) + (:method ((instance persistent-object) added-slots discarded-slots property-list + &rest initargs &key &allow-other-keys) + ;; The default method for this function ignores the deleted slots, + ;; initializes added slots according to their initargs or initforms and + ;; initializes shared slots (that did not change) with the values that + ;; were saved on disk. + 'DO-IMPLEMENT-THIS)) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/26 12:55:34 1.12 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/29 11:41:40 1.13 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.12 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.13 2006/08/29 11:41:40 alemmens Exp $ (in-package :rucksack) @@ -66,15 +66,14 @@ class index (i.e. a class index that's specified anymore in the class option) is removed, new class indexes are added.")) -(defgeneric rucksack-update-slot-indexes (rucksack class old-slot-indexes) +(defgeneric rucksack-update-slot-indexes (rucksack class old-slots) (:documentation "Compares the current slot indexes for CLASS to the slot indexes that are specified in the slot options for the direct slots of CLASS. Obsolete slot indexes (i.e. slot indexes that are not specified -anymore in the slot options) are removed, new slot indexes are -added. - OLD-SLOT-INDEXES is a list with the name, index and unique-p info -of each slot.")) +anymore in the slot options or indexes for slots that don't exist +anymore) are removed, new slot indexes are added. + OLD-SLOTS is a list with the previous slot definitions.")) (defgeneric rucksack-add-class-index (rucksack class-designator &key errorp)) @@ -552,57 +551,85 @@ :no-change)))) + (defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack) (class persistent-class) - old-slot-indexes) - (dolist (slot (class-direct-slots class)) - (let* ((index-spec (and (slot-persistence slot) - (or (find-index-spec (slot-index slot) :errorp nil) - (slot-index slot)))) - (unique-p (slot-unique slot))) - (multiple-value-bind (current-index-spec current-unique-p) - (find-old-index-spec (slot-definition-name slot) old-slot-indexes) - (cond ((and (index-spec-equal index-spec current-index-spec) - (eql unique-p current-unique-p)) - ;; We keep the same index: no change needed. - :no-change) - ((and current-index-spec (null index-spec)) - ;; The index is not wanted anymore: remove it. - (rucksack-remove-slot-index rucksack class slot :errorp t)) - ((and (null current-index-spec) index-spec) - ;; We didn't have an index but we need one now: add one. - (rucksack-add-slot-index rucksack class slot index-spec unique-p + old-slots) + (let ((direct-slots (class-direct-slots class))) + ;; Remove indexes for old slots that don't exist anymore. + (loop for slot in old-slots + for slot-name = (slot-definition-name slot) + unless (find slot-name direct-slots :key #'slot-definition-name) + do (rucksack-remove-slot-index rucksack class slot-name :errorp t)) + ;; Update indexes for the current set of direct slots. + (dolist (slot direct-slots) + (let ((index-spec (and (slot-persistence slot) + (or (find-index-spec (slot-index slot) :errorp nil) + (slot-index slot)))) + (unique-p (slot-unique slot)) + (slot-name (slot-definition-name slot))) + (multiple-value-bind (current-index-spec current-unique-p) + (find-old-index-spec slot-name old-slots) + (cond ((and (index-spec-equal index-spec current-index-spec) + (eql unique-p current-unique-p)) + ;; We keep the same index: no change needed. + :no-change) + ((and current-index-spec (null index-spec)) + ;; The index is not wanted anymore: remove it. + (rucksack-remove-slot-index rucksack class slot :errorp t)) + ((and (null current-index-spec) index-spec) + ;; We didn't have an index but we need one now: add one. + (add-and-fill-slot-index rucksack class slot index-spec unique-p)) + ((and current-index-spec index-spec) + ;; We have an index but need a different one now. + (replace-slot-index rucksack class slot index-spec unique-p)))))))) + + +(defun add-and-fill-slot-index (rucksack class slot index-spec unique-p) + ;; We didn't have an index but we need one now: add one. + (let ((index (rucksack-add-slot-index rucksack class slot index-spec unique-p :errorp t)) - ((and current-index-spec index-spec) - ;; We have an index but need a different one now. This requires - ;; some care because we need to re-index all objects from the old - ;; index. - (let ((current-index (rucksack-slot-index rucksack class slot)) - (new-index (rucksack-add-slot-index rucksack class slot - index-spec - unique-p - :errorp nil))) - ;; Re-index all objects for the new index. - ;; DO: This re-indexing can cause an error (e.g. if the old - ;; index has non-unique keys, the new index has unique keys - ;; and some keys occur more than once). We need to handle - ;; that error here and offer some decent restarts (e.g. - ;; remove the index entirely, or go back to the old index). - (map-index current-index - (lambda (slot-value object-id) - (index-insert new-index slot-value object-id))) - ;; We don't need to remove the old index explicitly, because - ;; RUCKSACK-ADD-SLOT-INDEX already did that for us. - ))))))) - -(defun find-old-index-spec (slot-name old-slot-indexes) - (let ((slot-info (cdr (assoc slot-name old-slot-indexes)))) - (and slot-info - (destructuring-bind (index-spec-designator unique-p) - slot-info - (values (or (find-index-spec index-spec-designator :errorp nil) - index-spec-designator) - unique-p))))) + (slot-name (slot-definition-name slot))) + ;; Index all instances for the new index. + ;; NOTE: This will only work if the class is indexed, otherwise there is no + ;; affordable way to find all instances of the class. + (when (class-index class) + (rucksack-map-class rucksack class + (lambda (object) + (when (slot-boundp object slot-name) + (index-insert index (slot-value object slot-name) + (object-id object)))))))) + + +(defun replace-slot-index (rucksack class slot index-spec unique-p) + ;; We have an index but need a different one now. This requires + ;; some care because we need to re-index all objects from the old + ;; index. + (let ((current-index (rucksack-slot-index rucksack class slot)) + (new-index (rucksack-add-slot-index rucksack class slot + index-spec + unique-p + :errorp nil))) + ;; Re-index all objects for the new index. + ;; DO: This re-indexing can cause an error (e.g. if the old + ;; index has non-unique keys, the new index has unique keys + ;; and some keys occur more than once). We need to handle + ;; that error here and offer some decent restarts (e.g. + ;; remove the index entirely, or go back to the old index). + (map-index current-index + (lambda (slot-value object-id) + (index-insert new-index slot-value object-id))) + ;; We don't need to remove the old index explicitly, because + ;; RUCKSACK-ADD-SLOT-INDEX already did that for us. + )) + +(defun find-old-index-spec (slot-name old-slots) + (let ((slot (find slot-name old-slots :key #'slot-definition-name))) + (and slot + (with-slots (index unique) + slot + (values (or (find-index-spec index :errorp nil) index) + unique))))) @@ -785,7 +812,7 @@ (let ((slot-index-table (btree-search (slot-index-tables rucksack) class :errorp errorp))) (handler-bind ((btree-deletion-error #'oops)) - (btree-delete-key slot slot-index-table + (btree-delete-key slot-index-table slot :if-does-not-exist (if errorp :error :ignore))))) slot))) @@ -914,3 +941,18 @@ (declare (ignore index)) (push class-name result)))) result)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Schema updates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod rucksack-maybe-update-schema ((rucksack standard-rucksack) + class + old-slot-indexes) + ;; This is just a thin wrapper, so you can customize it if necessary. + (maybe-update-schema (schema-table (rucksack-cache rucksack)) + class + old-slot-indexes)) + + + \ No newline at end of file --- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/10 12:36:17 1.3 +++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 11:41:40 1.4 @@ -1,30 +1,50 @@ -;; $Id: schema-table.lisp,v 1.3 2006/08/10 12:36:17 alemmens Exp $ +;; $Id: schema-table.lisp,v 1.4 2006/08/29 11:41:40 alemmens Exp $ (in-package :rucksack) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema table -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - +;;; ;;; The schema table keeps track of all classes that have instances that ;;; were saved by the cache. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Schema +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass schema () - ((id :initarg :id :reader schema-id) + ((id :initarg :id :reader schema-id + :documentation "A unique number that identifies a schema.") (class-name :initarg :class-name :reader schema-class-name) - (version :initarg :version :initform 0 :reader schema-version) - ;; DO: Keep track of all slots: their names, their initforms and their - ;; persistence related slot options (persistence and index). - ;; Also keep track of persistence related class options here? + (version :initarg :version :initform 0 :reader schema-version + :documentation "The combination of class-name and version number +also uniquely identifies a schema.") + ;; Slot info + ;; DO: Keep track of all slots: their names, their initforms and their + ;; persistence related slot options. + ;; PERSISTENT-SLOT-NAMES is set during FINALIZE-INHERITANCE. (persistent-slot-names :initarg :persistent-slot-names - :reader persistent-slot-names))) + :accessor persistent-slot-names + :documentation "A list with the names of all +persistent effective slots.") + ;; Class info + (class-index :initarg :class-index :reader class-index))) (defmethod nr-persistent-slots ((schema schema)) (length (persistent-slot-names schema))) -;; -;; -;; +(defmethod print-object ((schema schema) stream) + (print-unreadable-object (schema stream :type t :identity t) + (format stream "~A ~D.~D with ~D slots" + (schema-class-name schema) + (schema-id schema) + (schema-version schema) + (nr-persistent-slots schema)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Schema table +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defclass schema-table () ((pathname :initarg :pathname :accessor schema-table-pathname) @@ -34,53 +54,102 @@ :reader schema-table-by-name) (by-id :initform (make-hash-table) :documentation "A mapping from a schema id to a schema." - :reader schema-table-by-id) + :accessor schema-table-by-id) (highest-schema-id :initform 0 :accessor highest-schema-id) (dirty-p :initform nil :accessor dirty-p :documentation "When dirty, the schema table will be saved at the next commit."))) +;; +;; Serializing schema table +;; + +(defmethod saved-slots ((table schema-table)) + ;; Don't serialize the BY-ID hash table, but rebuild it by hand after the + ;; other slots are deserialized. This is necessary because schemas are + ;; referenced more than once, and the serializer doesn't handle shared + ;; objects (unless they're 'real' persistent objects). + '(pathname by-name highest-schema-id)) + +(defmethod load-slots :after ((table schema-table) serializer) + ;; Reconstruct the BY-ID hash table. This method is called by the + ;; serializer after an object is deserialized. + (setf (schema-table-by-id table) (make-hash-table)) + (loop for schemas being the hash-value of (schema-table-by-name table) + do (loop for schema in schemas + do (setf (gethash (schema-id schema) + (schema-table-by-id table)) + schema))) + ;; + (setf (dirty-p table) nil) + table) + +;; +;; Finding schemas +;; + +(defmethod fresh-schema-id ((table schema-table)) + (prog1 (highest-schema-id table) + (incf (highest-schema-id table)))) + (defmethod find-schema-for-id ((table schema-table) id &key (errorp t)) (or (gethash id (schema-table-by-id table)) (and errorp (error "Can't find schema with id ~D in ~S." id table)))) +(defmethod find-schema-for-class ((table schema-table) class) + ;; Returns the most recent schema for a class + ;; (or NIL if there is no schema for the class). + (first (gethash (class-name class) (schema-table-by-name table)))) + +(defmethod schema-obsolete-p ((table schema-table) schema) + (let ((most-recent-schema (find-schema-for-class table + (schema-class-name schema)))) + (not (= (schema-version most-recent-schema) + (schema-version schema))))) + (defmethod find-or-create-schema-for-object ((table schema-table) object) ;; NOTE: This assumes that the class hasn't changed without the ;; schema table knowing about it. We probably must assume that, ;; otherwise we'd have a very expensive check whenever we want to ;; save an object. - (let ((class-name (class-name (class-of object)))) - (or (first (gethash class-name (schema-table-by-name table))) + (let ((class (class-of object))) + (or (find-schema-for-class table class) ;; There is no schema yet. Create it. - (let ((new-schema (create-schema-using-class table - (class-of object) - object))) - (add-schema table new-schema) - new-schema)))) - -(defmethod create-schema-using-class ((table schema-table) class object) - (let ((persistent-slots (compute-persistent-slot-names class object))) - (make-instance 'schema - :class-name (class-name class) - :id (highest-schema-id table) - :version 0 - :persistent-slot-names persistent-slots))) + (let ((persistent-slots (compute-persistent-slot-names class object))) + (create-schema table class 0 persistent-slots))))) + +(defmethod create-schema ((table schema-table) class version + &optional (persistent-slots '())) + (let ((schema (make-instance 'schema + :id (fresh-schema-id table) + :class-name (class-name class) + :version version + :persistent-slot-names persistent-slots + :class-index (compute-class-index class)))) + (add-schema table schema) + schema)) + + (defmethod compute-persistent-slot-names ((class persistent-class) object) (declare (ignore object)) (mapcar #'slot-definition-name (class-persistent-slots class))) - +(defgeneric compute-class-index (class) + (:method ((class persistent-class)) + (class-index class)) + (:method ((class t)) + nil)) (defmethod add-schema ((table schema-table) (schema schema)) (setf (gethash (schema-id schema) (schema-table-by-id table)) schema) (push schema (gethash (schema-class-name schema) (schema-table-by-name table) '())) - (incf (highest-schema-id table)) (setf (dirty-p table) t)) + (defmethod save-schema-table ((table schema-table)) ;; Clear dirty flag first, because it's saved (and loaded) too. (setf (dirty-p table) nil) @@ -121,3 +190,25 @@ (when (and commit (dirty-p table)) (save-schema-table table))) +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Schema updates +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defmethod maybe-update-schema ((table schema-table) class old-slots) + ;; Rucksack analyzes the new class definition; if it's different from the + ;; previous version, a new schema is added to the schema table. From that + ;; moment, when an instance of the redefined class is created it will be + ;; saved with the new schema id. + ;; This is called by the (RE-)INITIALIZE-INSTANCE method for + ;; PERSISTENT-CLASS. + (let ((old-schema (find-schema-for-class table class))) + (if (null old-schema) + ;; There is no schema yet: create the first one. + (create-schema table class 0) + ;; There is a schema: create a new one if necessary. + (multiple-value-bind (added-slots discarded-slots changed-slots) + (compare-slots old-slots (class-direct-slots class)) + (when (or added-slots discarded-slots changed-slots + (not (equal (class-index class) (class-index old-schema)))) + ;; Add a new schema for this class. + (create-schema table class (1+ (schema-version old-schema)))))))) --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/24 15:21:25 1.7 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/29 11:41:40 1.8 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.7 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: serialize.lisp,v 1.8 2006/08/29 11:41:40 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -1105,7 +1105,8 @@ (let ((nr-slots (deserialize stream)) (slots (saved-slots object))) (unless (= nr-slots (length slots)) - (error "Slot mismatch while deserializing a standard object.")) + (error "Slot mismatch while deserializing a standard object of class ~S." + (class-of object))) (loop for slot-name in (saved-slots object) do (let ((marker (read-next-marker stream))) (if (eql marker +unbound-slot+) From alemmens at common-lisp.net Tue Aug 29 13:50:19 2006 From: alemmens at common-lisp.net (alemmens) Date: Tue, 29 Aug 2006 09:50:19 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060829135019.49CA71C019@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv6896 Modified Files: example-1.lisp objects.lisp package.lisp schema-table.lisp Log Message: Partial implementation of UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS and friends. --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 11:41:40 1.3 +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 13:50:18 1.4 @@ -1,4 +1,4 @@ -;; $Id: example-1.lisp,v 1.3 2006/08/29 11:41:40 alemmens Exp $ +;; $Id: example-1.lisp,v 1.4 2006/08/29 13:50:18 alemmens Exp $ (in-package :test-rucksack) @@ -7,6 +7,7 @@ ;;; ;;; To run this example: ;;; - compile and load this file +;;; - (IN-PACKAGE :TEST-RS) ;;; - (CREATE-HACKERS) ;;; - (SHOW-HACKERS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 11:41:40 1.11 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 13:50:18 1.12 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.11 2006/08/29 11:41:40 alemmens Exp $ +;; $Id: objects.lisp,v 1.12 2006/08/29 13:50:18 alemmens Exp $ (in-package :rucksack) @@ -663,31 +663,53 @@ (transaction-id transaction) (heap cache)) (declare (ignore id)) - (let* ((schema (find-schema-for-id (schema-table cache) schema-id)) + (let* ((table (schema-table cache)) + (schema (find-schema-for-id table schema-id)) (object (allocate-instance (find-class (schema-class-name schema))))) (unless (= nr-slots (nr-persistent-slots schema)) (internal-rucksack-error "Schema inconsistency (expected ~D slots, got ~D slots)." (nr-persistent-slots schema) nr-slots)) - ;; Load and set slot values. - ;; DO: We should probably initialize the transient slots to their - ;; initforms here. And we should also deal with changed classes - ;; at this point. - ;; NOTE: The MOP doesn't intercept the (setf slot-value) here, - ;; because the rucksack and object-id slots are still unbound. - (loop for slot-name in (persistent-slot-names schema) - do (let ((marker (read-next-marker buffer))) - (if (eql marker +unbound-slot+) - (slot-makunbound object slot-name) - (setf (slot-value object slot-name) - (deserialize-contents marker buffer))))) - ;; Set CACHE, OBJECT-ID and TRANSACTION-ID slots if it's a persistent - ;; object. This needs to be done before persistent slots are initialized. - (when (typep object '(or persistent-object persistent-data)) - (setf (slot-value object 'rucksack) (current-rucksack) - (slot-value object 'object-id) object-id - (slot-value object 'transaction-id) (transaction-id transaction))) + (let ((added-slots '()) + (discarded-slots '()) + ;; DISCARDED-SLOT-VALUES is a list of discarded slot names and + ;; their (obsolete) values. + (discarded-slot-values '())) + (when (schema-obsolete-p schema) + (setf added-slots (schema-added-slot-names schema) + discarded-slots (schema-discarded-slot-names schema))) + ;; Load and set slot values. + ;; DO: We should probably initialize the transient slots to their + ;; initforms here. + ;; NOTE: The MOP doesn't intercept the (setf slot-value) here, + ;; because the rucksack and object-id slots are still unbound. + (loop for slot-name in (persistent-slot-names schema) + do (let ((marker (read-next-marker buffer)) + (old-slot-p (member slot-name discarded-slots))) + (if (eql marker +unbound-slot+) + (unless old-slot-p + (slot-makunbound object slot-name)) + ;; Deserialize the value + (let ((value (deserialize-contents marker buffer))) + (if old-slot-p + (progn + (push value discarded-slot-values) + (push slot-name discarded-slot-values)) + (setf (slot-value object slot-name) value)))))) + ;; Set CACHE, OBJECT-ID and TRANSACTION-ID slots if it's a persistent + ;; object. + (when (typep object '(or persistent-object persistent-data)) + (setf (slot-value object 'rucksack) (current-rucksack) + (slot-value object 'object-id) object-id + (slot-value object 'transaction-id) (transaction-id transaction))) + ;; Call UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS if necessary. + (when (schema-obsolete-p schema) + (update-persistent-instance-for-redefined-class + object + added-slots + discarded-slots + discarded-slot-values))) ;; (values object most-recent-p)))) @@ -753,8 +775,15 @@ &rest initargs &key &allow-other-keys) (:method ((instance persistent-object) added-slots discarded-slots property-list &rest initargs &key &allow-other-keys) - ;; The default method for this function ignores the deleted slots, - ;; initializes added slots according to their initargs or initforms and - ;; initializes shared slots (that did not change) with the values that - ;; were saved on disk. - 'DO-IMPLEMENT-THIS)) + ;; Default method: ignore the discarded slots and initialize added slots + ;; according to their initargs or initforms. + (let ((slots (class-slots (class-of instance)))) + (loop for slot-name in added-slots + for slot = (find slot-name slots :key #'slot-definition-name) + for initfunction = (and slot + (slot-definition-initfunction slot)) + when initfunction + ;; DO: Handle initargs! + do (setf (slot-value instance slot-name) + (funcall initfunction)))))) + --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/24 15:21:25 1.8 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/29 13:50:18 1.9 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.8 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: package.lisp,v 1.9 2006/08/29 13:50:18 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -24,6 +24,7 @@ ;; MOP related #:persistent-class + #:update-persistent-instance-for-redefined-class ;; Objects #:persistent-object @@ -75,6 +76,8 @@ ;; Conditions #:rucksack-error #:simple-rucksack-error #:transaction-conflict + #:internal-rucksack-error + #:duplicate-slot-value #:slot-error ;; Indexes #:map-index #:index-insert #:index-delete #:make-index --- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 11:41:40 1.4 +++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 13:50:18 1.5 @@ -1,4 +1,4 @@ -;; $Id: schema-table.lisp,v 1.4 2006/08/29 11:41:40 alemmens Exp $ +;; $Id: schema-table.lisp,v 1.5 2006/08/29 13:50:18 alemmens Exp $ (in-package :rucksack) @@ -20,15 +20,15 @@ (version :initarg :version :initform 0 :reader schema-version :documentation "The combination of class-name and version number also uniquely identifies a schema.") - ;; Slot info - ;; DO: Keep track of all slots: their names, their initforms and their - ;; persistence related slot options. - ;; PERSISTENT-SLOT-NAMES is set during FINALIZE-INHERITANCE. + (obsolete-p :initform nil :accessor schema-obsolete-p) + ;; Slot info (computed during FINALIZE-INHERITANCE). + (added-slot-names :initform '() :accessor schema-added-slot-names) + (discarded-slot-names :initform '() :accessor schema-discarded-slot-names) (persistent-slot-names :initarg :persistent-slot-names :accessor persistent-slot-names :documentation "A list with the names of all persistent effective slots.") - ;; Class info + ;; Class info (computed at schema creation time). (class-index :initarg :class-index :reader class-index))) (defmethod nr-persistent-slots ((schema schema)) @@ -102,11 +102,6 @@ ;; (or NIL if there is no schema for the class). (first (gethash (class-name class) (schema-table-by-name table)))) -(defmethod schema-obsolete-p ((table schema-table) schema) - (let ((most-recent-schema (find-schema-for-class table - (schema-class-name schema)))) - (not (= (schema-version most-recent-schema) - (schema-version schema))))) (defmethod find-or-create-schema-for-object ((table schema-table) object) ;; NOTE: This assumes that the class hasn't changed without the @@ -211,4 +206,9 @@ (when (or added-slots discarded-slots changed-slots (not (equal (class-index class) (class-index old-schema)))) ;; Add a new schema for this class. - (create-schema table class (1+ (schema-version old-schema)))))))) + (create-schema table class (1+ (schema-version old-schema))) + ;; Mark all older versions as obsolete. + (let ((old-schemas (rest (gethash (class-name class) + (schema-table-by-name table))))) + (loop for schema in old-schemas + do (setf (schema-obsolete-p schema) t)))))))) From alemmens at common-lisp.net Wed Aug 30 14:05:42 2006 From: alemmens at common-lisp.net (alemmens) Date: Wed, 30 Aug 2006 10:05:42 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060830140542.601B436027@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv26918 Modified Files: example-1.lisp mop.lisp objects.lisp package.lisp rucksack.lisp schema-table.lisp test.lisp Log Message: - FINALIZE-INHERITANCE: compute slot diffs for obsolete schemas. - More work on UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/29 13:50:18 1.4 +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/30 14:05:40 1.5 @@ -1,13 +1,13 @@ -;; $Id: example-1.lisp,v 1.4 2006/08/29 13:50:18 alemmens Exp $ +;; $Id: example-1.lisp,v 1.5 2006/08/30 14:05:40 alemmens Exp $ -(in-package :test-rucksack) +(in-package :rucksack-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing example ;;; ;;; To run this example: ;;; - compile and load this file -;;; - (IN-PACKAGE :TEST-RS) +;;; - (IN-PACKAGE :RUCKSACK-TEST) ;;; - (CREATE-HACKERS) ;;; - (SHOW-HACKERS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -94,9 +94,6 @@ #| -CL-USER 2 > (in-package :test-rs) -# - TEST-RS 3 > (create-hackers) # --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/29 11:41:40 1.7 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/30 14:05:40 1.8 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.7 2006/08/29 11:41:40 alemmens Exp $ +;; $Id: mop.lisp,v 1.8 2006/08/30 14:05:40 alemmens Exp $ (in-package :rucksack) @@ -146,7 +146,7 @@ ;; slot-value-using-class. #+lispworks :optimize-slot-access #+lispworks nil args))) - (ensure-class-schema class '()) + (update-indexes class '()) result)) @@ -164,7 +164,7 @@ ;; SLOT-VALUE-USING-CLASS. #+lispworks :optimize-slot-access #+lispworks nil args))) - (ensure-class-schema class old-slots) + (update-indexes class old-slots) result)) @@ -182,37 +182,29 @@ direct-superclasses (cons root-class direct-superclasses)))) -(defun ensure-class-schema (class old-slots) +(defun update-indexes (class old-slots) ;; Update class and slot indexes. - (when (or (class-index class) - (some #'slot-persistence (class-direct-slots class))) - ;; NOTE: We get the current-rucksack only if there are some - ;; persistent slots, because this will also get called during - ;; compilation of Rucksack (when the class definition of - ;; PERSISTENT-OBJECT is compiled). At that stage the CURRENT-RUCKSACK - ;; function isn't even defined yet, so we shouldn't call it. + (when (fboundp 'current-rucksack) + ;; This function is also called during compilation of Rucksack + ;; (when the class definition of PERSISTENT-OBJECT is compiled). + ;; At that stage the CURRENT-RUCKSACK function isn't even defined + ;; yet, so we shouldn't call it. (let ((rucksack (current-rucksack))) (when rucksack (rucksack-update-class-index rucksack class) - (rucksack-update-slot-indexes rucksack class old-slots) - ;; Update schema in schema table, if necessary. - (rucksack-maybe-update-schema rucksack class old-slots))))) + (rucksack-update-slot-indexes rucksack class old-slots))))) (defmethod finalize-inheritance :after ((class persistent-class)) - ;; Register all persistent slots. + ;; Register all (effective) persistent slots. (setf (class-persistent-slots class) (remove-if-not #'slot-persistence (class-slots class))) - ;; - (when (or (class-index class) (class-persistent-slots class)) + ;; Update schemas if necessary. + (when (fboundp 'current-rucksack) ; see comment for UPDATE-INDEXES (let ((rucksack (current-rucksack))) (when rucksack - (let* ((schema-table (schema-table (rucksack-cache rucksack))) - (schema (find-schema-for-class schema-table class))) - (when schema - (setf (persistent-slot-names schema) - (mapcar #'slot-definition-name - (class-persistent-slots class))))))))) + (maybe-update-schemas (schema-table (rucksack-cache rucksack)) + class))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/29 13:50:18 1.12 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/30 14:05:40 1.13 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.12 2006/08/29 13:50:18 alemmens Exp $ +;; $Id: objects.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $ (in-package :rucksack) @@ -677,8 +677,8 @@ ;; their (obsolete) values. (discarded-slot-values '())) (when (schema-obsolete-p schema) - (setf added-slots (schema-added-slot-names schema) - discarded-slots (schema-discarded-slot-names schema))) + (setf added-slots (added-slot-names schema) + discarded-slots (discarded-slot-names schema))) ;; Load and set slot values. ;; DO: We should probably initialize the transient slots to their ;; initforms here. --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/29 13:50:18 1.9 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/30 14:05:40 1.10 @@ -1,4 +1,4 @@ -;; $Id: package.lisp,v 1.9 2006/08/29 13:50:18 alemmens Exp $ +;; $Id: package.lisp,v 1.10 2006/08/30 14:05:40 alemmens Exp $ #-(or allegro lispworks sbcl openmcl) (error "Unsupported implementation: ~A" (lisp-implementation-type)) @@ -102,7 +102,10 @@ -(defpackage :test-rucksack - (:nicknames :test-rs) - (:use :cl :rucksack)) - +(defpackage :rucksack-test + (:nicknames :rs-test) + (:use :common-lisp :rucksack)) + +(defpackage :rucksack-test-schema-update + (:nicknames :rs-tsu) + (:use :common-lisp :rucksack)) \ No newline at end of file --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/29 11:41:40 1.13 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/30 14:05:40 1.14 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.13 2006/08/29 11:41:40 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.14 2006/08/30 14:05:40 alemmens Exp $ (in-package :rucksack) @@ -560,7 +560,7 @@ (loop for slot in old-slots for slot-name = (slot-definition-name slot) unless (find slot-name direct-slots :key #'slot-definition-name) - do (rucksack-remove-slot-index rucksack class slot-name :errorp t)) + do (rucksack-remove-slot-index rucksack class slot-name :errorp nil)) ;; Update indexes for the current set of direct slots. (dolist (slot direct-slots) (let ((index-spec (and (slot-persistence slot) @@ -808,12 +808,12 @@ ;; Return the slot name if everything went fine; otherwise, return ;; NIL (or signal an error). (and (handler-bind ((btree-search-error #'oops)) - (let ((slot-index-table (btree-search (slot-index-tables rucksack) class :errorp errorp))) - (handler-bind ((btree-deletion-error #'oops)) - (btree-delete-key slot-index-table slot - :if-does-not-exist (if errorp :error :ignore))))) + (and slot-index-table + (handler-bind ((btree-deletion-error #'oops)) + (btree-delete-key slot-index-table slot + :if-does-not-exist (if errorp :error :ignore)))))) slot))) @@ -942,17 +942,6 @@ (push class-name result)))) result)) -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Schema updates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod rucksack-maybe-update-schema ((rucksack standard-rucksack) - class - old-slot-indexes) - ;; This is just a thin wrapper, so you can customize it if necessary. - (maybe-update-schema (schema-table (rucksack-cache rucksack)) - class - old-slot-indexes)) \ No newline at end of file --- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/29 13:50:18 1.5 +++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/30 14:05:40 1.6 @@ -1,4 +1,4 @@ -;; $Id: schema-table.lisp,v 1.5 2006/08/29 13:50:18 alemmens Exp $ +;; $Id: schema-table.lisp,v 1.6 2006/08/30 14:05:40 alemmens Exp $ (in-package :rucksack) @@ -22,14 +22,20 @@ also uniquely identifies a schema.") (obsolete-p :initform nil :accessor schema-obsolete-p) ;; Slot info (computed during FINALIZE-INHERITANCE). - (added-slot-names :initform '() :accessor schema-added-slot-names) - (discarded-slot-names :initform '() :accessor schema-discarded-slot-names) + (added-slot-names :initform '() + :accessor added-slot-names + :documentation "A list with the names of all +persistent slots that were added by the most recent version (compared +to this version).") + (discarded-slot-names :initform '() + :accessor discarded-slot-names + :documentation "A list with the names of all +persistent slots that were discarded by the most recent version +(compared to this version).") (persistent-slot-names :initarg :persistent-slot-names :accessor persistent-slot-names :documentation "A list with the names of all -persistent effective slots.") - ;; Class info (computed at schema creation time). - (class-index :initarg :class-index :reader class-index))) +persistent effective slots."))) (defmethod nr-persistent-slots ((schema schema)) (length (persistent-slot-names schema))) @@ -102,6 +108,8 @@ ;; (or NIL if there is no schema for the class). (first (gethash (class-name class) (schema-table-by-name table)))) +(defmethod old-schemas-for-class ((table schema-table) class) + (rest (gethash (class-name class) (schema-table-by-name table)))) (defmethod find-or-create-schema-for-object ((table schema-table) object) ;; NOTE: This assumes that the class hasn't changed without the @@ -121,8 +129,7 @@ :id (fresh-schema-id table) :class-name (class-name class) :version version - :persistent-slot-names persistent-slots - :class-index (compute-class-index class)))) + :persistent-slot-names persistent-slots))) (add-schema table schema) schema)) @@ -131,11 +138,6 @@ (declare (ignore object)) (mapcar #'slot-definition-name (class-persistent-slots class))) -(defgeneric compute-class-index (class) - (:method ((class persistent-class)) - (class-index class)) - (:method ((class t)) - nil)) (defmethod add-schema ((table schema-table) (schema schema)) (setf (gethash (schema-id schema) (schema-table-by-id table)) @@ -189,26 +191,25 @@ ;;; Schema updates ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod maybe-update-schema ((table schema-table) class old-slots) +(defmethod maybe-update-schemas ((table schema-table) class) ;; Rucksack analyzes the new class definition; if it's different from the ;; previous version, a new schema is added to the schema table. From that ;; moment, when an instance of the redefined class is created it will be ;; saved with the new schema id. - ;; This is called by the (RE-)INITIALIZE-INSTANCE method for - ;; PERSISTENT-CLASS. - (let ((old-schema (find-schema-for-class table class))) + ;; This is called by the FINALIZE-INHERITANCE method for PERSISTENT-CLASS. + (let ((slots (mapcar #'slot-definition-name (class-persistent-slots class))) + (old-schema (find-schema-for-class table class))) (if (null old-schema) ;; There is no schema yet: create the first one. - (create-schema table class 0) - ;; There is a schema: create a new one if necessary. - (multiple-value-bind (added-slots discarded-slots changed-slots) - (compare-slots old-slots (class-direct-slots class)) - (when (or added-slots discarded-slots changed-slots - (not (equal (class-index class) (class-index old-schema)))) - ;; Add a new schema for this class. - (create-schema table class (1+ (schema-version old-schema))) - ;; Mark all older versions as obsolete. - (let ((old-schemas (rest (gethash (class-name class) - (schema-table-by-name table))))) - (loop for schema in old-schemas - do (setf (schema-obsolete-p schema) t)))))))) + (create-schema table class 0 slots) + ;; There is a schema already: create a new one if necessary. + (when (set-difference slots (persistent-slot-names old-schema)) + ;; Add a new schema for this class. + (create-schema table class (1+ (schema-version old-schema)) slots) + ;; Mark all older versions as obsolete and compute their + ;; slot diffs w.r.t. to the new schema + (dolist (schema (old-schemas-for-class table class)) + (let ((old-slots (persistent-slot-names schema))) + (setf (schema-obsolete-p schema) t + (added-slot-names schema) (set-difference slots old-slots) + (discarded-slot-names schema) (set-difference old-slots slots)))))))) --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:45:02 1.12 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/30 14:05:40 1.13 @@ -1,6 +1,6 @@ -;; $Id: test.lisp,v 1.12 2006/08/24 15:45:02 alemmens Exp $ +;; $Id: test.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $ -(in-package :test-rucksack) +(in-package :rucksack-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; A few quick tests to make sure the basics work. From alemmens at common-lisp.net Thu Aug 31 15:47:59 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Aug 2006 11:47:59 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060831154759.0BE4C72080@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv9153 Modified Files: example-1.lisp index.lisp objects.lisp rucksack.lisp Added Files: test-schema-update-1a.lisp test-schema-update-1b.lisp test-schema-update-1c.lisp Log Message: Add test cases for schema updates and user defined methods of UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. Indexing: compare the specified slot/class indexes to the indexes that exist in the rucksack, *not* to the indexes specified in the previous version of the class definition. Otherwise we get inconsistencies when we recompile class definitions from scratch with a rucksack that already exists. --- /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/30 14:05:40 1.5 +++ /project/rucksack/cvsroot/rucksack/example-1.lisp 2006/08/31 15:47:58 1.6 @@ -1,4 +1,4 @@ -;; $Id: example-1.lisp,v 1.5 2006/08/30 14:05:40 alemmens Exp $ +;; $Id: example-1.lisp,v 1.6 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack-test) @@ -83,8 +83,9 @@ (defun show-indexes () (with-rucksack (r *hacker-rucksack*) - (print (rs::rucksack-list-class-indexes r)) - (print (rs::rucksack-list-slot-indexes r)) + (with-transaction () + (print (rs::rucksack-list-class-indexes r)) + (print (rs::rucksack-list-slot-indexes r))) :ok)) --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/26 12:55:34 1.6 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2006/08/31 15:47:58 1.7 @@ -1,4 +1,4 @@ -;; $Id: index.lisp,v 1.6 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: index.lisp,v 1.7 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack) @@ -39,16 +39,62 @@ ;; index-spec-equal (index-spec-1 index-spec-2) [Function] - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indexing +;;; Index class ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -(defmethod map-index ((index btree) function +(defclass index () + ((spec :initarg :spec :reader index-spec) + (unique-keys-p :initarg :unique-keys-p :reader index-unique-keys-p) + (data :initarg :data :reader index-data + :documentation "The actual index data structure (e.g. a btree).")) + (:metaclass persistent-class) + (:index nil)) + +(defmethod print-object ((index index) stream) + (print-unreadable-object (index stream :type t :identity t) + (format stream "~S with ~:[non-unique~;unique~] keys" + (index-spec index) + (index-unique-keys-p index)))) + +(defmethod index-similar-p ((index-1 index) (index-2 index)) + (and (index-spec-equal (index-spec index-1) (index-spec index-2)) + (equal (index-unique-keys-p index-1) (index-unique-keys-p index-2)))) + +;; +;; Trampolines +;; + +(defmethod map-index ((index index) function &rest args &key min max include-min include-max - (equal nil equal-supplied) + (equal nil) (order :ascending)) + (declare (ignorable min max include-min include-max equal order)) + (apply #'map-index-data (index-data index) function args)) + +(defmethod index-insert ((index index) key value &key (if-exists :overwrite)) + (index-data-insert (index-data index) key value + :if-exists if-exists)) + +(defmethod index-delete ((index index) key value + &key (if-does-not-exist :ignore)) + (index-data-delete (index-data index) key value + :if-does-not-exist if-does-not-exist)) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Indexing +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;; NOTE: If you define your own indexing data structures, you need to supply +;; methods for the three generic functions below: MAP-INDEX-DATA, +;; INDEX-DATA-INSERT and INDEX-DATA-DELETE. + +(defmethod map-index-data ((index btree) function + &rest args + &key min max include-min include-max + (equal nil equal-supplied) + (order :ascending)) (declare (ignorable min max include-min include-max)) (if equal-supplied (let ((value (btree-search index equal :errorp nil :default-value index))) @@ -57,30 +103,35 @@ (apply #'map-btree index function :order order args))) -(defmethod index-insert ((index btree) key value &key (if-exists :overwrite)) +(defmethod index-data-insert ((index btree) key value + &key (if-exists :overwrite)) (btree-insert index key value :if-exists if-exists)) -(defmethod index-delete ((index btree) key value - &key (if-does-not-exist :ignore)) +(defmethod index-data-delete ((index btree) key value + &key (if-does-not-exist :ignore)) (btree-delete index key value :if-does-not-exist if-does-not-exist)) -;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; Index specs -;; +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; An index spec is a symbol or a list starting with a symbol ;; and followed by a plist of keywords and values. ;; Examples: BTREE, (BTREE :KEY< < :VALUE= P-EQL) +(defun make-index (index-spec unique-keys-p &key (class 'index)) + ;; NOTE: All index data classes must accept the :UNIQUE-KEYS-P initarg. + (let ((data (if (symbolp index-spec) + (make-instance index-spec :unique-keys-p unique-keys-p) + (apply #'make-instance + (first index-spec) + :unique-keys-p unique-keys-p + (rest index-spec))))) + (make-instance class + :spec index-spec + :unique-keys-p unique-keys-p + :data data))) -(defun make-index (index-spec unique-keys-p) - ;; NOTE: All index classes must accept the :UNIQUE-KEYS-P initarg. - (if (symbolp index-spec) - (make-instance index-spec :unique-keys-p unique-keys-p) - (apply #'make-instance - (first index-spec) - :unique-keys-p unique-keys-p - (rest index-spec)))) (defun index-spec-equal (index-spec-1 index-spec-2) "Returns T iff two index specs are equal." --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/30 14:05:40 1.13 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/31 15:47:58 1.14 @@ -1,4 +1,4 @@ -;; $Id: objects.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $ +;; $Id: objects.lisp,v 1.14 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack) @@ -784,6 +784,5 @@ (slot-definition-initfunction slot)) when initfunction ;; DO: Handle initargs! - do (setf (slot-value instance slot-name) - (funcall initfunction)))))) + do (setf (slot-value instance slot-name) (funcall initfunction)))))) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/30 14:05:40 1.14 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 15:47:58 1.15 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.14 2006/08/30 14:05:40 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.15 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack) @@ -555,10 +555,10 @@ (defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack) (class persistent-class) old-slots) - (let ((direct-slots (class-direct-slots class))) - ;; Remove indexes for old slots that don't exist anymore. - (loop for slot in old-slots - for slot-name = (slot-definition-name slot) + (let ((direct-slots (class-direct-slots class)) + (indexed-slot-names (rucksack-indexed-slots-for-class rucksack class))) + ;; Remove indexes for slots that don't exist anymore. + (loop for slot-name in indexed-slot-names unless (find slot-name direct-slots :key #'slot-definition-name) do (rucksack-remove-slot-index rucksack class slot-name :errorp nil)) ;; Update indexes for the current set of direct slots. @@ -568,8 +568,11 @@ (slot-index slot)))) (unique-p (slot-unique slot)) (slot-name (slot-definition-name slot))) - (multiple-value-bind (current-index-spec current-unique-p) - (find-old-index-spec slot-name old-slots) + (let* ((current-index (rucksack-slot-index rucksack class slot-name + :errorp nil + :include-superclasses nil)) + (current-index-spec (and current-index (index-spec current-index))) + (current-unique-p (and current-index (index-unique-keys-p current-index)))) (cond ((and (index-spec-equal index-spec current-index-spec) (eql unique-p current-unique-p)) ;; We keep the same index: no change needed. @@ -919,27 +922,39 @@ do (map-slot class)))))) (map-slot (if (symbolp class) (find-class class) class))))) + +(defun rucksack-indexed-slots-for-class (rucksack class) + "Returns a list with the names of the indexed direct slots of CLASS." + (unless (symbolp class) + (setq class (class-name class))) + (let ((result '())) + (rucksack-map-slot-indexes rucksack + (lambda (class-name slot-name slot-index) + (declare (ignore slot-index)) + (when (eql class-name class) + (push slot-name result)))) + result)) + + ;; ;; Debugging ;; (defun rucksack-list-slot-indexes (rucksack) (let ((result '())) - (with-transaction () - (rucksack-map-slot-indexes rucksack - (lambda (class-name slot-name slot-index) - (declare (ignore slot-index)) - (push (cons class-name slot-name) - result)))) + (rucksack-map-slot-indexes rucksack + (lambda (class-name slot-name slot-index) + (declare (ignore slot-index)) + (push (cons class-name slot-name) + result))) result)) (defun rucksack-list-class-indexes (rucksack) (let ((result '())) - (with-transaction () - (rucksack-map-class-indexes rucksack - (lambda (class-name index) - (declare (ignore index)) - (push class-name result)))) + (rucksack-map-class-indexes rucksack + (lambda (class-name index) + (declare (ignore index)) + (push class-name result))) result)) --- /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/08/31 15:47:59 NONE +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1a.lisp 2006/08/31 15:47:59 1.1 ;; $Id: test-schema-update-1a.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 1 of 3 ;;; ;;; After compiling and loading this file, compile and load ;;; test-schema-update-1b.lisp. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *names* '(john dick mary jane peter ronald)) ;; ;; Initial class definition of PERSON ;; (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *dir* #P"/tmp/rucksack/schema-update/") (with-rucksack (*rucksack* *dir* :if-exists :supersede) (with-transaction () (defclass person () ((name :initarg :name :initform (elt *names* (random (length *names*))) :reader name) (age :initarg :age :initform (random 100) :reader age)) (:metaclass persistent-class) (:index t))))) (defmethod print-object ((person person) stream) (print-unreadable-object (person stream :type t) (format stream "#~D ~A with age ~D" (object-id person) (name person) (age person)))) ;; Create some persons. (with-rucksack (*rucksack* *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) ;; Show them. (with-rucksack (*rucksack* *dir*) (with-transaction () (rucksack-map-class *rucksack* 'person #'print))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| # # # # # # # # # # |# --- /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/08/31 15:47:59 NONE +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1b.lisp 2006/08/31 15:47:59 1.1 ;; $Id: test-schema-update-1b.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 2 of 3 ;;; ;;; Compile and load this file after compiling and loading ;;; test-schema-update-1a.lisp. Study the output, and then compile ;;; and load test-schema-update-1c.lisp. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Redefine the PERSON class ;; (eval-when (:compile-toplevel :load-toplevel :execute) (with-rucksack (*rucksack* *dir*) (with-transaction () (defclass person () ((name :initarg :name :initform (elt *names* (random (length *names*))) :reader name) (year-of-birth :initform (random-year) :accessor year-of-birth)) (:metaclass persistent-class) (:index t))))) (defconstant +this-year+ 2006) (defun random-year () (+ 1900 (random 100))) (defmethod update-persistent-instance-for-redefined-class ((person person) added-slots discarded-slots plist &key &allow-other-keys) ;; Make sure that existing PERSONS get the YEAR-OF-BIRTH value ;; corresponding to their (obsolete) AGE slot. (let ((age (getf plist 'age))) (setf (year-of-birth person) (- +this-year+ age)) (format *trace-output* "~&Setting year of birth for ~D to ~D." age (year-of-birth person)))) (defmethod age ((person person)) ;; Make sure that the AGE method still works. (- +this-year+ (year-of-birth person))) ;; Create some persons with the new class definition. (with-rucksack (*rucksack* *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) ;; Show some PERSON instances and some old PERSON instances. ;; (We don't show all PERSON instances, because showing them may ;; update them and we want to keep a few old instances for the next ;; part of the test). (with-rucksack (*rucksack* *dir*) (with-transaction () (let ((cache (rucksack-cache *rucksack*)) (count 0)) (rucksack-map-class *rucksack* 'person (lambda (id) (when (evenp count) (print (cache-get-object id cache))) (incf count)) :id-only t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| ;; Some old PERSON instances (updated after being loaded). Setting year of birth for 77 to 1929. # Setting year of birth for 39 to 1967. # Setting year of birth for 41 to 1965. # Setting year of birth for 75 to 1931. # Setting year of birth for 11 to 1995. # Setting year of birth for 72 to 1934. ;; Some new PERSON instances. # # # # # # |# --- /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/08/31 15:47:59 NONE +++ /project/rucksack/cvsroot/rucksack/test-schema-update-1c.lisp 2006/08/31 15:47:59 1.1 ;; $Id: test-schema-update-1c.lisp,v 1.1 2006/08/31 15:47:58 alemmens Exp $ (in-package :rucksack-test-schema-update) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Schema updates and UPDATE-INSTANCE-FOR-REDEFINED-CLASS, part 3 of 3 ;;; ;;; Compile and load this file after compiling and loading ;;; test-schema-update-1c.lisp ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;; ;; Redefine the PERSON class once more. ;; (eval-when (:compile-toplevel :load-toplevel :execute) (with-rucksack (*rucksack* *dir*) (with-transaction () (defclass person () ((name :initarg :name :initform (elt *names* (random (length *names*))) :reader name) (date-of-birth :accessor date-of-birth :initform (random-date))) (:metaclass persistent-class) (:index t))))) (defun random-date () (make-date (random-year) (+ 1 (random 12)) (+ 1 (random 28)))) (defun make-date (year &optional (month 1) (day 1)) (encode-universal-time 0 0 0 day month year)) (defun date-string (universal-time) (multiple-value-bind (sec min hr day month year) (decode-universal-time universal-time) (declare (ignore sec min hr)) (format nil "~D-~2,'0D-~2,'0D" year month day))) (defmethod update-persistent-instance-for-redefined-class ((person person) added-slots discarded-slots plist &key &allow-other-keys) ;; Now we need to deal with version 0 persons (with an obsolete ;; AGE slot) and with version 1 persons (with an obsolete ;; YEAR-OF-BIRTH slot). (cond ((member 'age discarded-slots) ;; Version 0 (let* ((age (getf plist 'age)) (year (- +this-year+ age))) (setf (date-of-birth person) (make-date year 1 1)) (format *trace-output* "~&Setting date of birth from age ~D to ~A." age (date-string (date-of-birth person))))) ((member 'year-of-birth discarded-slots) ;; Version 1 (let ((year (getf plist 'year-of-birth))) (setf (date-of-birth person) (make-date year 1 1)) (format *trace-output* "~&Setting date of birth from year ~D to ~A." year (date-string (date-of-birth person))))))) (defmethod year-of-birth ((person person)) ;; Make sure that the YEAR-OF-BIRTH method still works. (nth-value 5 (decode-universal-time (date-of-birth person)))) ;; Create some persons with the second version of the class definition. (with-rucksack (*rucksack* *dir*) (with-transaction () (loop repeat 10 do (make-instance 'person)))) ;; Show all persons (for three versions of the class definition). (with-rucksack (*rucksack* *dir*) (with-transaction () (rucksack-map-class *rucksack* 'person #'print))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Sample output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Note that we see three different kinds of output, corresponding to the ;;; three class versions. ;;; ;;; Output like: ;;; ;;; Setting date of birth from age 6 to 2000-01-01. ;;; # ;;; ;;; is for version 0 instances that are updated to version 2. ;;; ;;; Output like: ;;; ;;; Setting date of birth from year 2001 to 2001-01-01. ;;; # ;;; ;;; is for version 1 PERSON instances that are updated to version 2. ;;; ;;; And output like: ;;; ;;; # ;;; ;;; is for version 2 instances (that don't need to be updated). ;;; Note also that you'll get this kind of output only once. If you load ;;; the file again, all old version instances have been updated already ;;; so you won't see any "Setting date of birth..." messages anymore. #| Setting date of birth from year 2001 to 2001-01-01. # Setting date of birth from age 46 to 1960-01-01. # Setting date of birth from year 1955 to 1955-01-01. # Setting date of birth from age 6 to 2000-01-01. # Setting date of birth from year 1920 to 1920-01-01. # Setting date of birth from age 33 to 1973-01-01. # Setting date of birth from year 1917 to 1917-01-01. # Setting date of birth from age 15 to 1991-01-01. # Setting date of birth from year 1922 to 1922-01-01. # Setting date of birth from age 26 to 1980-01-01. # [32 lines skipped] From alemmens at common-lisp.net Thu Aug 31 15:50:28 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Aug 2006 11:50:28 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060831155028.431191A@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv9397 Added Files: test-index-1a.lisp test-index-1b.lisp Removed Files: example-1.lisp Log Message: Write test case for slots with redefined indexes. This also tests the default method for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. --- /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 15:50:27 NONE +++ /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 15:50:27 1.1 ;; $Id: test-index-1a.lisp,v 1.1 2006/08/31 15:50:27 alemmens Exp $ (in-package :rucksack-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Indexing example ;;; ;;; To run this example: ;;; - compile and load this file ;;; - (IN-PACKAGE :RUCKSACK-TEST) ;;; - (CREATE-HACKERS) ;;; - (SHOW-HACKERS) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (defparameter *hackers* '("David" "Jim" "Peter" "Thomas" "Arthur" "Jans" "Klaus" "James" "Martin")) (defun random-elt (list) (elt list (random (length list)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/") (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () ;; We define some persistent classes with indexed slots. ;; So we must wrap the class definition in a WITH-RUCKSACK, ;; otherwise the indexes can't be built. (defclass hacker () ((id :initform (gensym "HACKER-") :reader hacker-id :index :symbol-index :unique t) (name :initform (random-elt *hackers*) :accessor name :index :case-insensitive-string-index)) (:metaclass persistent-class) (:index t)) (defclass lisp-hacker (hacker) () (:metaclass persistent-class) (:index t))))) (defmethod print-object ((hacker hacker) stream) (print-unreadable-object (hacker stream :type t) (format stream "~S called ~S" (hacker-id hacker) (name hacker)))) (defun create-hackers () (with-rucksack (*rucksack* *hacker-rucksack*) ;; Fill the rucksack with some hackers. (with-transaction () (loop repeat 20 do (make-instance 'hacker)) (loop repeat 10 do (make-instance 'lisp-hacker)) (rucksack-map-class *rucksack* 'hacker #'print)))) (defun show-hackers () (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () (print "Hackers indexed by object id.") (rucksack-map-class *rucksack* 'hacker #'print) (print "Hackers indexed by name.") (rucksack-map-slot *rucksack* 'hacker 'name #'print) (print "Hackers indexed by hacker-id.") (rucksack-map-slot *rucksack* 'hacker 'id #'print) (print "Lisp hackers.") (rucksack-map-class *rucksack* 'lisp-hacker #'print) (print "Non-lisp hackers.") (rucksack-map-class *rucksack* 'hacker #'print :include-subclasses nil) (print "Hacker object ids.") (rucksack-map-class *rucksack* 'hacker #'print :id-only t)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Example output ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; #| TEST-RS 3 > (create-hackers) # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # NIL T TEST-RS 4 > (show-hackers) "Hackers indexed by object id." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Hackers indexed by name." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Hackers indexed by hacker-id." # # # # # # # # # # # # # # # # # # # # # # # # # # # # # # "Lisp hackers." # # # # # # # # # # "Non-lisp hackers." # # # # # # # # # # # # # # # # # # # # "Hacker object ids." 36 65 69 73 78 83 88 92 96 100 104 109 113 117 122 126 130 135 139 144 148 160 164 168 173 177 181 185 189 193 NIL T |# --- /project/rucksack/cvsroot/rucksack/test-index-1b.lisp 2006/08/31 15:50:28 NONE +++ /project/rucksack/cvsroot/rucksack/test-index-1b.lisp 2006/08/31 15:50:28 1.1 ;; $Id: test-index-1b.lisp,v 1.1 2006/08/31 15:50:27 alemmens Exp $ (in-package :rs-test) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Class redefinition example ;;; ;;; To run this example: ;;; - First run the indexing example in test-index-1a.lisp. ;;; - Compile and load this file ;;; This will change the class definition of HACKER. ;;; Because of this change, Rucksack will remove some slot indexes and ;;; create (and fill) other slot indexes. ;;; - (SHOW-HACKERS) ;;; Notice that "Hackers indexed by hacker-id." now doesn't list any hackers, ;;; because the ID index was removed. ;;; - (SHOW-HACKERS-BY-AGE) ;;; This will print the hackers sorted by age. It shows that: ;;; (1) the existing hackers all got a new age slot, initialized by ;;; UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS to a random ;;; number according to their initform ;;; (2) a new index has been created for the new age slot ;;; (3) the index has been filled with the new values for the age slot. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () ;; For classes that may change during program development, you should ;; wrap all class definitions in a WITH-RUCKSACK to make sure that ;; the corresponding schemas and indexes are updated correctly. ;; In this case we redefine the HACKER class: we remove the index for ;; the ID slot, and we add a new AGE slot (with an index). (defclass hacker () ((id :initform (gensym "HACKER-") :reader hacker-id) (name :initform (random-elt *hackers*) :accessor name :index :case-insensitive-string-index) (age :initform (random 100) :accessor age :index :number-index)) (:metaclass persistent-class) (:index t)))) (defun show-hackers-by-age () (with-rucksack (*rucksack* *hacker-rucksack*) (with-transaction () (print "Hackers by age.") (rucksack-map-slot *rucksack* 'hacker 'age (lambda (hacker) (format t "~&~A has age ~D.~%" (name hacker) (age hacker))))))) From alemmens at common-lisp.net Thu Aug 31 15:53:58 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Aug 2006 11:53:58 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060831155358.77CC610C7@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv9793 Added Files: do.txt done.txt notes.txt Log Message: Add list of things to do, list of things done, and some random notes. --- /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 15:53:58 NONE +++ /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 15:53:58 1.1 DO: - Handle initargs in LOAD-OBJECT and UPDATE-PERSISTENT-... - Initialize transient slots during LOAD-OBJECT. - Figure out if there's a better way than (eval-when (:compile-toplevel :load-toplevel :execute) ...) to make sure that class definitions within a WITH-RUCKSACK are treated as top level definitions. - Maybe signal a continuable error when the in-memory class definition does not correspond to the most recent schema. If the user decides to continue, UPDATE-PERSISTENT-INSTANCE-... will be called when necessary. - What about in-memory persistent instances when the class definition changes? We should make sure that those are updated too. There seem to be three strategies: 1. Rely on Lisp's normal UPDATE-INSTANCE-FOR-REDEFINED-CLASS mechanism. Then the programmer must write methods for both UPDATE-INSTANCE-... and UPDATE-PERSISTENT-INSTANCE-... . That seems error prone. 2. Remove all instances of the redefined class from the cache. Then the objects will be loaded from disk again, and U-P-I-F-R-C will be called automatically. This has the disadvantage that all values of transient slots will be gone. 3. Forbid it and signal some kind of error. - Get rid of the PROCESS-A-CLASS-OPTION stuff and handle the :INDEX class option in a way that's compatible with AMOP. - I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for RUCKSACK-MAP-SLOT. Think about this. - Does indexing in example-1 work correctly if we don't use *RUCKSACK* in WITH-RUCKSACK? Maybe WITH-RUCKSACK should always bind *RUCKSACK*? - There's still a btree bug that's uncovered by the stress test. Fix it. - Check that btrees actually signal an error for duplicate keys. Handle those errors correctly for slot indexes. - Make sure that the GC gets rid of all obsolete object versions. - Add export/import to s-expression format. This is necessary for migrating existing rucksacks to a new version of Rucksack. - Give each transaction its own commit file (the name can be generated from the transaction id). That's one step towards avoiding locks on transaction commit. - Deal with CHANGE-CLASS: call UPDATE-PERSISTENT-INSTANCE-FOR-DIFFERENT-CLASS when necessary. (Maybe it's never necessary and we can just use the existing UPDATE-INSTANCE-FOR-DIFFERENT-CLASS mechanism?) --- /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 15:53:58 NONE +++ /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 15:53:58 1.1 * 2006-08-31 - Write test cases for schema updates and user defined methods for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. - Indexing: compare the specified slot/class indexes to the indexes that exist in the Rucksack, *not* to the indexes specified in the previous version of the class definition. Otherwise we get inconsistencies when we recompile class definitions from scratch with a Rucksack that already exists. - Write test case for slots with redefined indexes. This also tests the default method for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. * 2006-08-30 - FINALIZE-INHERITANCE: Compute slot diffs for obsolete schemas. - More work on UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. * 2006-08-29 - Partial implementation of UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS & friends. * 2006-08-29 - Example-1: indexing should still work after recompiling. - RUCKSACK-UPDATE-SLOT-INDEXES: Remove indexes for old slots that don't exist anymore. - Some work on schema updates. - Compute persistent slots at the right moment. * 2006-08-26 - Make sure that indexing works correctly with subclasses. - Fix some more indexing bugs. * 2006-08 - The class and slot indexes were normal hash tables, but they should be persistent objects like everything else: I replaced them by btrees. - Get process-lock and process-unlock working on SBCL (thanks to Geoff Cant). * 2006-08 - Save and load the index tables when closing/opening a rucksack. - Implement the :UNIQUE slot option. - Improve predefined slot index specs. * 2006-08 - Add a SERIAL-TRANSACTION-RUCKSACK class that allows for only one transaction at a time (by using a transaction lock). This allows for a fast track towards a working Rucksack implementation. Then parallel transactions can be added later. - Don't do any GC at all while a transaction is writing objects to disk. Instead we keep track of the amount of disk space allocated by the committing transaction. Then we do a (partial) GC immediately after committing the transaction. --- /project/rucksack/cvsroot/rucksack/notes.txt 2006/08/31 15:53:58 NONE +++ /project/rucksack/cvsroot/rucksack/notes.txt 2006/08/31 15:53:58 1.1 ;; $Id: notes.txt,v 1.1 2006/08/31 15:53:57 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Some random notes ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; * UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS & friends. What should we do when the class has been redefined more than once before an instance is loaded? Example: an instance of class PERSON (with schema version 0) was saved. Now PERSON is redefined twice, and the most recent schema for class PERSON has version number 2. Ideally, UPDATE-PERSISTENT-INSTANCE-... would be called twice. But that doesn't work in practice, because we can only allocate an instance corresponding to the most recent class definition. Suppose that version 0 of the PERSON class had an AGE slot, version 1 discards the AGE slot and adds a YEAR-OF-BIRTH slot, and version 2 discards the YEAR-OF-BIRTH slot and adds a BIRTH-DATE slot. Suppose also that there are PERSON instances corresponding to version 0, instances of version 1 and instances of version 2. When loading instances of version 2, we don't need to do anything special because version 2 is the most recent version. For instances of version 1, UPDATE-PERSISTENT-INSTANCE-... will be called with BIRTH-DATE as added slot, YEAR-OF-BIRTH as discarded slot and the property list (YEAR-OF-BIRTH ). For instances of version 0, UPDATE-PERSISTENT-INSTANCE-... will be called with BIRTH-DATE as added slot, AGE as discarded slot and the property list (AGE ). So UPDATE-PERSISTENT-INSTANCE-... will be called exactly once, and it needs to inspect the lists of added/discarded slots if it wants to handle multiple version changes. Whenever a schema becomes obsolete, we mark it as obsolete and register the names of the slots that were added and the slots that were discarded (by the most recent version, compared to this version). From alemmens at common-lisp.net Thu Aug 31 20:09:18 2006 From: alemmens at common-lisp.net (alemmens) Date: Thu, 31 Aug 2006 16:09:18 -0400 (EDT) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20060831200918.0D04D6A011@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv1363 Modified Files: do.txt done.txt mop.lisp rucksack.lisp test-index-1a.lisp Log Message: Get rid of the Lispworks specific PROCESS-A-CLASS-OPTION stuff and handle the :INDEX class option in a way that's compatible with the AMOP. --- /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 15:53:57 1.1 +++ /project/rucksack/cvsroot/rucksack/do.txt 2006/08/31 20:09:17 1.2 @@ -2,7 +2,7 @@ - Handle initargs in LOAD-OBJECT and UPDATE-PERSISTENT-... -- Initialize transient slots during LOAD-OBJECT. +- Initialize non-persistent slots during LOAD-OBJECT. - Figure out if there's a better way than (eval-when (:compile-toplevel :load-toplevel :execute) ...) @@ -25,9 +25,6 @@ of transient slots will be gone. 3. Forbid it and signal some kind of error. -- Get rid of the PROCESS-A-CLASS-OPTION stuff and handle the :INDEX class - option in a way that's compatible with AMOP. - - I'm not sure that :INCLUDE-SUBCLASSES NIL makes sense for RUCKSACK-MAP-SLOT. Think about this. --- /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 15:53:57 1.1 +++ /project/rucksack/cvsroot/rucksack/done.txt 2006/08/31 20:09:17 1.2 @@ -1,5 +1,8 @@ * 2006-08-31 +- Get rid of the Lispworks-specific PROCESS-A-CLASS-OPTION stuff and handle + the :INDEX class option in a way that's compatible with AMOP. + - Write test cases for schema updates and user defined methods for UPDATE-PERSISTENT-INSTANCE-FOR-REDEFINED-CLASS. --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/30 14:05:40 1.8 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2006/08/31 20:09:17 1.9 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.8 2006/08/30 14:05:40 alemmens Exp $ +;; $Id: mop.lisp,v 1.9 2006/08/31 20:09:17 alemmens Exp $ (in-package :rucksack) @@ -13,10 +13,20 @@ (defclass persistent-class (standard-class) ((persistent-slots :initform '() :accessor class-persistent-slots) - (index :initarg :index :initform nil :accessor class-index + (index :initarg :index :initform nil :documentation "Can be either NIL (for no class index) or T (for the standard class index). Default value is NIL."))) +(defmethod class-index ((class persistent-class)) + ;; According to the MOP, the INDEX slot is initialized with the + ;; list of items following the :INDEX option, but we're only + ;; interested in the first item of that list. + (first (slot-value class 'index))) + +;; +;; Persistent slot definitions +;; + (defclass persistent-slot-mixin () ((persistence :initarg :persistence :initform t @@ -115,14 +125,6 @@ (list* option value already-processed-options) (call-next-method))) -#+lispworks -(defmethod clos:process-a-class-option ((class persistent-class) - option-name - value) - (if (eql option-name :index) - (cons option-name value) - (call-next-method))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Initializing the persistent-class metaobjects ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -146,7 +148,7 @@ ;; slot-value-using-class. #+lispworks :optimize-slot-access #+lispworks nil args))) - (update-indexes class '()) + (update-indexes class) result)) @@ -154,17 +156,16 @@ &rest args &key direct-superclasses &allow-other-keys) - (let* ((old-slots (mapcar #'copy-slot-definition (class-direct-slots class))) - (result (apply #'call-next-method - class - :direct-superclasses (maybe-add-persistent-object-class - class - direct-superclasses) - ;; Tell Lispworks that it shouldn't bypass - ;; SLOT-VALUE-USING-CLASS. - #+lispworks :optimize-slot-access #+lispworks nil - args))) - (update-indexes class old-slots) + (let ((result (apply #'call-next-method + class + :direct-superclasses (maybe-add-persistent-object-class + class + direct-superclasses) + ;; Tell Lispworks that it shouldn't bypass + ;; SLOT-VALUE-USING-CLASS. + #+lispworks :optimize-slot-access #+lispworks nil + args))) + (update-indexes class) result)) @@ -182,7 +183,7 @@ direct-superclasses (cons root-class direct-superclasses)))) -(defun update-indexes (class old-slots) +(defun update-indexes (class) ;; Update class and slot indexes. (when (fboundp 'current-rucksack) ;; This function is also called during compilation of Rucksack @@ -192,7 +193,7 @@ (let ((rucksack (current-rucksack))) (when rucksack (rucksack-update-class-index rucksack class) - (rucksack-update-slot-indexes rucksack class old-slots))))) + (rucksack-update-slot-indexes rucksack class))))) (defmethod finalize-inheritance :after ((class persistent-class)) --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 15:47:58 1.15 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/31 20:09:18 1.16 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.15 2006/08/31 15:47:58 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.16 2006/08/31 20:09:18 alemmens Exp $ (in-package :rucksack) @@ -66,14 +66,13 @@ class index (i.e. a class index that's specified anymore in the class option) is removed, new class indexes are added.")) -(defgeneric rucksack-update-slot-indexes (rucksack class old-slots) +(defgeneric rucksack-update-slot-indexes (rucksack class) (:documentation "Compares the current slot indexes for CLASS to the slot indexes that are specified in the slot options for the direct slots of CLASS. Obsolete slot indexes (i.e. slot indexes that are not specified anymore in the slot options or indexes for slots that don't exist -anymore) are removed, new slot indexes are added. - OLD-SLOTS is a list with the previous slot definitions.")) +anymore) are removed, new slot indexes are added.")) (defgeneric rucksack-add-class-index (rucksack class-designator &key errorp)) @@ -553,8 +552,7 @@ (defmethod rucksack-update-slot-indexes ((rucksack standard-rucksack) - (class persistent-class) - old-slots) + (class persistent-class)) (let ((direct-slots (class-direct-slots class)) (indexed-slot-names (rucksack-indexed-slots-for-class rucksack class))) ;; Remove indexes for slots that don't exist anymore. @@ -686,8 +684,7 @@ (defmethod rucksack-make-class-index ((rucksack standard-rucksack) class - &key - (index-spec '(btree :key< < :value= p-eql))) + &key (index-spec '(btree :key< < :value= p-eql))) ;; A class index maps object ids to objects. (declare (ignore class)) (make-index index-spec t)) --- /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 15:50:27 1.1 +++ /project/rucksack/cvsroot/rucksack/test-index-1a.lisp 2006/08/31 20:09:18 1.2 @@ -1,4 +1,4 @@ -;; $Id: test-index-1a.lisp,v 1.1 2006/08/31 15:50:27 alemmens Exp $ +;; $Id: test-index-1a.lisp,v 1.2 2006/08/31 20:09:18 alemmens Exp $ (in-package :rucksack-test) @@ -23,7 +23,7 @@ (defparameter *hacker-rucksack* #p"/tmp/rucksack/hackers/") - (with-rucksack (*rucksack* *hacker-rucksack*) + (with-rucksack (*rucksack* *hacker-rucksack* :if-exists :supersede) (with-transaction () ;; We define some persistent classes with indexed slots.