From charmon at common-lisp.net Tue Jan 16 08:31:49 2007 From: charmon at common-lisp.net (charmon) Date: Tue, 16 Jan 2007 03:31:49 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070116083149.48CC25600C@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv21121 Modified Files: mop.lisp rucksack.asd Log Message: rucksack 0.1.1 * propogate unique fropm the direct slot-definition(s) to the effective slot definition --- /project/rucksack/cvsroot/rucksack/mop.lisp 2006/09/04 12:34:34 1.11 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2007/01/16 08:31:49 1.12 @@ -1,4 +1,4 @@ -;; $Id: mop.lisp,v 1.11 2006/09/04 12:34:34 alemmens Exp $ +;; $Id: mop.lisp,v 1.12 2007/01/16 08:31:49 charmon Exp $ (in-package :rucksack) @@ -250,6 +250,17 @@ (setf (slot-value effective-slotdef 'index) (slot-index (car index-slotdefs)))))) + ;; If exactly one direct slot is unique, then the effective one is + ;; too. If more then one is unique, signal an error. + (let ((unique-slotdefs (remove-if-not #'slot-unique persistent-slotdefs))) + (cond ((cdr unique-slotdefs) + (error "Multiple uniques for slot ~S in ~S:~% ~{~S~^, ~}." + slot-name class + (mapcar #'slot-unique unique-slotdefs))) + (unique-slotdefs + (setf (slot-value effective-slotdef 'unique) + (slot-unique (car unique-slotdefs)))))) + ;; Return the effective slot definition. effective-slotdef)) --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2006/05/28 11:18:47 1.2 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:31:49 1.3 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.2 2006/05/28 11:18:47 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.3 2007/01/16 08:31:49 charmon Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1" + :version "0.1.1" :serial t :components ((:file "queue") (:file "package") From charmon at common-lisp.net Tue Jan 16 08:42:24 2007 From: charmon at common-lisp.net (charmon) Date: Tue, 16 Jan 2007 03:42:24 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070116084224.39A0B60036@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv23605 Modified Files: p-btrees.lisp rucksack.asd Log Message: rucksack 0.1.2 * btree-max-node-size now defaults to 32 instead of 100 --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2006/08/26 12:55:34 1.10 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/01/16 08:42:24 1.11 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.10 2006/08/26 12:55:34 alemmens Exp $ +;; $Id: p-btrees.lisp,v 1.11 2007/01/16 08:42:24 charmon Exp $ (in-package :rucksack) @@ -205,7 +205,7 @@ :initform 'btree-node) (max-node-size :initarg :max-node-size :reader btree-max-node-size - :initform 100 + :initform 32 :documentation "An integer specifying the preferred maximum number of keys per btree node.") (unique-keys-p :initarg :unique-keys-p --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:31:49 1.3 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:42:24 1.4 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.3 2007/01/16 08:31:49 charmon Exp $ +;;; $Id: rucksack.asd,v 1.4 2007/01/16 08:42:24 charmon Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.1" + :version "0.1.2" :serial t :components ((:file "queue") (:file "package") From charmon at common-lisp.net Tue Jan 16 08:47:36 2007 From: charmon at common-lisp.net (charmon) Date: Tue, 16 Jan 2007 03:47:36 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070116084736.8A8376B006@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv24119 Modified Files: p-btrees.lisp rucksack.asd Log Message: rucksack 0.1.3 * use binary search instead of linear search in find-subnode and find-binding-in-node --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/01/16 08:42:24 1.11 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/01/16 08:47:36 1.12 @@ -1,4 +1,4 @@ -;; $Id: p-btrees.lisp,v 1.11 2007/01/16 08:42:24 charmon Exp $ +;; $Id: p-btrees.lisp,v 1.12 2007/01/16 08:47:36 charmon Exp $ (in-package :rucksack) @@ -497,28 +497,45 @@ "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. - ;; 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.")) + (let ((btree-key< (btree-key< btree)) + (last (1- (btree-node-index-count node)))) + (labels ((binary-search (start end) + (let* ((mid (+ start (ash (- end start) -1)))) + (cond ((= start mid) + (let ((start-binding (node-binding node start))) + (if (funcall btree-key< (binding-key start-binding) key) + (binding-value (node-binding node end)) + (binding-value start-binding)))) + (t + (let ((mid-binding (node-binding node mid))) + (if (funcall btree-key< (binding-key mid-binding) key) + (binary-search mid end) + (binary-search start mid)))))))) + (if (funcall btree-key< (binding-key (node-binding node (1- last))) key) + (binding-value (node-binding node last)) + (binary-search 0 last))))) (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)))))) + (let ((btree-key< (btree-key< btree)) + (array (btree-node-index node)) + (index-count (btree-node-index-count node))) + (labels ((binary-search (start end) + (let* ((mid (+ start (ash (- end start) -1)))) + (cond ((= start mid) + (let ((start-binding (p-aref array start))) + (if (funcall btree-key< (binding-key start-binding) key) + (when (< end index-count) + (p-aref array end)) + start-binding))) + (t (let ((mid-binding (p-aref array mid))) + (if (funcall btree-key< (binding-key mid-binding) key) + (binary-search mid end) + (binary-search start mid)))))))) + (when (plusp index-count) + (let ((candidate (binary-search 0 index-count))) + (when (and candidate + (funcall (btree-key= btree) (binding-key candidate) key)) + candidate)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Insert --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:42:24 1.4 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:47:36 1.5 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.4 2007/01/16 08:42:24 charmon Exp $ +;;; $Id: rucksack.asd,v 1.5 2007/01/16 08:47:36 charmon Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.2" + :version "0.1.3" :serial t :components ((:file "queue") (:file "package") From charmon at common-lisp.net Tue Jan 16 08:57:44 2007 From: charmon at common-lisp.net (charmon) Date: Tue, 16 Jan 2007 03:57:44 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070116085744.1949215009@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv24724 Modified Files: garbage-collector.lisp rucksack.asd rucksack.lisp transactions.lisp Log Message: rucksack 0.1.4 * add new parameter *collect-garbage-on-commit* * add (:inhibit-gc nil) keyword arg to with-transaction * add without-rucksack-gcing macro * only collect garbage on transaction-commit when *collect-garbage-on-commit* is not nil --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/09/04 12:34:34 1.19 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2007/01/16 08:57:43 1.20 @@ -1,4 +1,4 @@ -;; $Id: garbage-collector.lisp,v 1.19 2006/09/04 12:34:34 alemmens Exp $ +;; $Id: garbage-collector.lisp,v 1.20 2007/01/16 08:57:43 charmon Exp $ (in-package :rucksack) @@ -446,6 +446,14 @@ work-done)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Parameters to control GC +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defparameter *collect-garbage-on-commit* t + "A flag to indicate whether or not transaction-commit collects garbage") + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; MAYBE LATER: MERGING DEAD BLOCKS. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:47:36 1.5 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:57:43 1.6 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.5 2007/01/16 08:47:36 charmon Exp $ +;;; $Id: rucksack.asd,v 1.6 2007/01/16 08:57:43 charmon Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.3" + :version "0.1.4" :serial t :components ((:file "queue") (:file "package") --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/11/30 10:45:34 1.17 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/01/16 08:57:43 1.18 @@ -1,4 +1,4 @@ -;; $Id: rucksack.lisp,v 1.17 2006/11/30 10:45:34 alemmens Exp $ +;; $Id: rucksack.lisp,v 1.18 2007/01/16 08:57:43 charmon Exp $ (in-package :rucksack) @@ -238,13 +238,18 @@ "The currently active transaction.") (defmacro with-transaction ((&rest args - &key (rucksack '(current-rucksack)) + &key + (rucksack '(current-rucksack)) + (inhibit-gc nil inhibit-gc-supplied-p) &allow-other-keys) &body body) (let ((committed (gensym "COMMITTED")) (transaction (gensym "TRANSACTION")) (result (gensym "RESULT"))) - `(let ((,transaction nil)) + `(let ((,transaction nil) + (*collect-garbage-on-commit* (if ,inhibit-gc-supplied-p + ,(not inhibit-gc) + *collect-garbage-on-commit*))) (loop named ,transaction do (with-simple-restart (retry "Retry ~S" ,transaction) (let ((,committed nil) --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/24 15:21:25 1.11 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2007/01/16 08:57:43 1.12 @@ -1,4 +1,4 @@ -;; $Id: transactions.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $ +;; $Id: transactions.lisp,v 1.12 2007/01/16 08:57:43 charmon Exp $ (in-package :rucksack) @@ -171,6 +171,13 @@ ;; Committing a transaction ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; use without-rucksack-gcing to locally set +;;; *collect-garbage-on-commit* to nil in order to supress rucksack +;;; garbage collection on commit +(defmacro without-rucksack-gcing (&body body) + `(let ((*collect-garbage-on-commit* nil)) + , at body)) + (defun transaction-commit (transaction &key (rucksack (current-rucksack))) "Call transaction-commit-1 to do the real work." (transaction-commit-1 transaction (rucksack-cache rucksack) rucksack)) @@ -216,8 +223,9 @@ (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)) + (when *collect-garbage-on-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))))) From alemmens at common-lisp.net Sat Jan 20 18:18:00 2007 From: alemmens at common-lisp.net (alemmens) Date: Sat, 20 Jan 2007 13:18:00 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070120181800.1CCB11A09B@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/home/alemmens/klad/rucksack Modified Files: btrees.lisp cache.lisp errors.lisp garbage-collector.lisp glossary.txt heap.lisp index.lisp make.lisp mop.lisp object-table.lisp objects.lisp p-btrees.lisp package.lisp queue.lisp rucksack.asd rucksack.lisp schema-table.lisp serialize.lisp talk-eclm2006.txt test.lisp transactions.lisp Log Message: Version 0.1.5: removed ^M line terminators from all source files (thanks to Attila Lendvai). --- /project/rucksack/cvsroot/rucksack/btrees.lisp 2006/05/16 21:16:34 1.1 +++ /project/rucksack/cvsroot/rucksack/btrees.lisp 2007/01/20 18:17:55 1.2 @@ -1,480 +1,480 @@ -;; This is an in-memory version of btrees. At the moment it's not used -;; by the rest of the system. - -(defpackage :btree - (:use :cl) - (:export - ;; Btrees - #:btree - #:btree-key< #:btree-key= #:btree-value= - #:btree-max-node-size #:btree-unique-keys-p - #:btree-key-type #:btree-value-type - #:btree-node-class - - ;; Nodes - #:btree-node - - ;; Functions - #:btree-search #:btree-insert #:map-btree - - ;; Conditions - #:btree-error #:btree-search-error #:btree-insertion-error - #:btree-key-already-present-error #:btree-type-error - #:btree-error-btree #:btree-error-key #:btree-error-value)) - -(in-package :btree) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; B-trees -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| -Basically, a B-tree is a balanced multi-way tree. - -The reason for using multi-way trees instead of binary trees is that the nodes -are expected to be on disk; it would be inefficient to have to execute -a disk operation for each tree node if it contains only 2 keys. - -The key property of B-trees is that each possible search path has the same -length, measured in terms of nodes. -|# - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Conditions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-condition btree-error (error) - ((btree :initarg :btree :reader btree-error-btree))) - -(define-condition btree-search-error (btree-error) - ((key :initarg :key :reader btree-error-key))) - -(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) - ()) - -(define-condition btree-type-error (btree-error type-error) - ()) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Classes -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass btree () - ((key< :initarg :key< :reader btree-key< :initform '<) - (key= :initarg :key= :reader btree-key= :initform 'eql) - (value= :initarg :value= :reader btree-value= :initform 'eql) - ;; - (node-class :initarg :node-class - :reader btree-node-class - :initform 'btree-node) - (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.") - (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.") - (key-type :initarg :key-type - :reader btree-key-type - :initform t - :documentation "The type of all keys.") - (value-type :initarg :value-type - :reader btree-value-type - :initform t - :documentation "The type of all values.") - (root :accessor btree-root))) - - - -;; -;; The next two classes are for internal use only, so we don't bother -;; with fancy long names. -;; - -(defclass btree-node () - ((index :initarg :index - :initform '() - :accessor btree-node-index - :documentation "A vector of key/value pairs. The keys are -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.") - (index-count :initform 0 - :accessor btree-node-index-count - :documentation "The number of key/value pairs in the index vector.") - (leaf-p :initarg :leaf-p :initform nil :reader btree-node-leaf-p))) - -(defun node-binding (node i) - (svref (btree-node-index node) i)) - -(defun (setf node-binding) (binding node i) - (setf (svref (btree-node-index node) i) - binding)) - -(defmethod initialize-instance :after ((node btree-node) &key btree &allow-other-keys) - (setf (btree-node-index node) (make-array (btree-max-node-size btree) - :initial-element nil) - (btree-node-index-count node) 0)) - - -(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)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; 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)) - (if (slot-boundp btree 'root) - (node-search btree (slot-value btree 'root) key errorp default-value) - (not-found btree key errorp default-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) - '())) - -;; -;; Node-search -;; - -(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 (find key (btree-node-index node) - :key #'car - :test (btree-key= btree) - :end (btree-node-index-count node)))) - (if binding - (cdr binding) - (not-found btree key errorp default-value))) - (let ((subnode (find-subnode btree node key))) - (node-search btree subnode key errorp default-value))))) - - -(defun find-subnode (btree node key) - "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) - for binding across (btree-node-index node) - do (cond ((= i (1- (btree-node-index-count node))) - ;; We're at the last binding. - (return-from find-subnode (cdr binding))) - ((funcall (btree-key< btree) key (car binding)) - (let ((next-binding (node-binding node (1+ i)))) - (if (funcall (btree-key= btree) key (car next-binding)) - (return-from find-subnode (cdr next-binding)) - (return-from find-subnode (cdr binding))))))) - (error "This shouldn't happen.")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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)) - (error 'btree-type-error - :btree btree - :datum key - :expected-type (btree-key-type btree))) - (unless (typep value (btree-key-type btree)) - (error 'btree-type-error - :btree btree - :datum value - :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) - ;; Create a root. - (let ((leaf (make-instance (btree-node-class btree) :btree btree :leaf-p t))) - (setf (node-binding leaf 0) (make-leaf-binding btree key value) - (btree-node-index-count leaf) 1) - (let* ((empty-leaf (make-instance (btree-node-class btree) :btree btree :leaf-p t)) - (root (make-root btree key empty-leaf 'key-irrelevant leaf))) - (setf (btree-root btree) root)))) - ;; Return the inserted value. - value) - -(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) - (error "Btree inconsistency between ~D and ~D" prev-key key))) - (setq prev-key key))))) - - -(defun make-root (btree left-key left-subnode right-key right-subnode) - (let* ((root (make-instance (btree-node-class btree) :btree btree))) - (setf (node-binding root 0) (make-binding left-key left-subnode) - (node-binding root 1) (make-binding right-key right-subnode) - (btree-node-index-count root) 2) - root)) - -(defun make-binding (key value) - (cons key value)) - -(defun make-leaf-binding (btree key value) - (cons key - (if (btree-unique-keys-p btree) value (list value)))) - -;; -;; Node insert -;; - -(defgeneric btree-node-insert (btree node parent 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)) - (t (let ((subnode (find-subnode btree node key))) - (btree-node-insert btree subnode node key value if-exists))))) - - -(defun smallest-key (node) - (if (btree-node-leaf-p node) - (car (node-binding node 0)) - (smallest-key (cdr (node-binding node 0))))) - -(defun biggest-key (node) - (if (btree-node-leaf-p node) - (car (node-binding node (1- (btree-node-index-count node)))) - (biggest-key (cdr (node-binding node (1- (btree-node-index-count node))))))) - - -(defun split-btree-node (btree node parent) - ;; 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. - (setf (subseq (btree-node-index left) 0) (subseq (btree-node-index node) 0 split-pos) - (btree-node-index-count left) split-pos - (subseq (btree-node-index right) 0) (subseq (btree-node-index node) 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 - (car parent-binding)))) - (if (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 (car parent-binding) left-key - (cdr parent-binding) left) - ;; Insert a new binding for the right node. - (insert-new-binding parent - (1+ node-pos) - (cons right-key right))))))) - -(defun parent-binding (node parent) - (node-binding parent (node-position node parent))) - -(defun node-position (node parent) - (position node (btree-node-index parent) - :key #'cdr - :end (btree-node-index-count parent))) - - -(defun insert-new-binding (node position new-binding) - (unless (>= position (btree-node-index-count node)) - ;; Make room by moving bindings to the right. - (setf (subseq (btree-node-index node) (1+ position) (1+ (btree-node-index-count node))) - (subseq (btree-node-index node) position (btree-node-index-count node)))) - ;; Insert new binding. - (setf (node-binding node position) new-binding) - (incf (btree-node-index-count node))) - - -(defun check-node (btree node) - (loop for i below (1- (btree-node-index-count node)) - for left-key = (car (node-binding node i)) - for right-key = (car (node-binding node (1+ i))) - do (unless (or (eql right-key 'key-irrelevant) - (funcall (btree-key< btree) left-key right-key)) - (error "Inconsistent node ~S" node)))) - - - -(defun leaf-insert (btree leaf key value if-exists) - (let ((binding (find key (btree-node-index leaf) - :key #'car - :test (btree-key= btree) - :end (btree-node-index-count leaf)))) - (if binding - ;; Key already exists. - (if (btree-unique-keys-p btree) - (ecase if-exists - (:overwrite - (setf (cdr binding) value)) - (:error - ;; Signal an error unless the old value happens to be - ;; the same as the new value. - (unless (funcall (btree-value= btree) (cdr binding) value) - (error 'btree-key-already-present-error - :btree btree - :key key - :value value)))) - ;; For non-unique keys, we ignore the :if-exists options and - ;; just add value to the list of values (unless value is already - ;; there). - (unless (find value (cdr binding) :test (btree-value= btree)) - (push value (cdr binding)))) - ;; The key doesn't exist yet. Create a new binding and add it to the - ;; leaf index in the right position. - (let ((new-binding (make-leaf-binding btree key value)) - (new-position (position key (btree-node-index leaf) - :test (btree-key< btree) - :key #'car - :end (btree-node-index-count leaf)))) - (insert-new-binding leaf - (or new-position (btree-node-index-count leaf)) - new-binding))))) - - - -(defun node-almost-full-p (btree node) - (>= (btree-node-index-count node) (1- (btree-max-node-size btree)))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Iterating -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgeneric map-btree (btree function - &key min max include-min include-max order) - (:documentation "Calls FUNCTION for all key/value pairs 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 list of [563 lines skipped] --- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/09/01 13:57:06 1.11 +++ /project/rucksack/cvsroot/rucksack/cache.lisp 2007/01/20 18:17:55 1.12 @@ -1,488 +1,488 @@ -;; $Id: cache.lisp,v 1.11 2006/09/01 13:57:06 alemmens Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Cache: API -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; (defun open-cache (directory -;; &key (class 'standard-cache) (if-exists :overwrite) -;; (if-does-not-exist :create) (size 10000) -;; &allow-other-keys) -;; -;; Creates or opens a cache in the given directory and returns that -;; cache. SIZE is the number of objects that may be kept in memory. - -(defgeneric close-cache (cache &key commit) - (:documentation "Closes the cache. If COMMIT is true (which is the -default), the objects in the cache will be written to disk before -closing the cache.")) - -(defgeneric cache-size (cache) - (:documentation "Returns the number of non-dirty objects that the -cache may keep in memory.")) - -(defgeneric cache-count (cache) - (:documentation "Returns the number of objects (both dirty and -non-dirty) in the cache.")) - -(defgeneric cache-create-object (object cache) - (:documentation "Adds a new object to the cache and returns an -object id that can be used to retrieve the object from the cache. -Don't use this function twice for the same object.")) - -(defgeneric cache-get-object (object-id cache) - (:documentation "Retrieves the object with the given id from the -cache and returns that object.")) - -(defgeneric cache-commit (cache) - (:documentation "Makes sure that all changes to the cache are -written to disk.")) - -(defgeneric cache-rollback (cache) - (:documentation "Undoes all cache changes that were made since the -last cache-commit.")) - -(defgeneric cache-recover (cache) - (:documentation "Undoes partially committed transactions to ensure -that the cache is in a consistent state.")) - - -(defgeneric open-transaction (cache transaction) - (:documentation "Adds a transaction to the set of open -transactions.")) - -(defgeneric close-transaction (cache transaction) - (:documentation "Removes a transaction from the set of open -transactions.")) - -(defgeneric map-transactions (cache function) - (:documentation "Applies a function to each open transaction in a -cache.")) - - -(defgeneric make-transaction-id (cache) - (:documentation "Returns a new transaction ID. The result is an -integer greater than all previous IDs.")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; The cache -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass cache () - ()) - -(defclass standard-cache (cache) - ;; The cache uses a heap to manage the object memory and a schema table to - ;; keep track of different class versions for objects in the heap. - ((heap :initarg :heap :reader heap) - (schema-table :initarg :schema-table :reader schema-table) - (rucksack :initarg :rucksack :reader rucksack - :documentation "Back pointer to the rucksack.") - ;; Clean objects - (objects :initarg :objects - :reader objects - :documentation "A hash-table (from id to object) -containing the youngest committed version of all objects that are -currently kept in memory but are not dirty. ('The youngest version' -means the version belonging to the youngest committed transaction.)") - (queue :initform (make-instance 'queue) :reader queue - :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.") - (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 -transactions. Contains only open transactions, i.e. transactions that -haven't been rolled back or committed.") - ;; - (size :initarg :size :accessor cache-size - :documentation "The maximum number of non-dirty objects that -will be kept in the cache memory.") - (shrink-ratio :initarg :shrink-ratio - :initform 0.7 - :accessor cache-shrink-ratio - :documentation "A number between 0 and 1. When the -cache is full, i.e. when there are at least SIZE (non-dirty) objects -in the queue, it will be shrunk by removing (1 - SHRINK-RATIO) * SIZE -objects."))) - - -(defmethod print-object ((cache standard-cache) stream) - (print-unreadable-object (cache stream :type t :identity nil) - (format stream "of size ~D, heap ~S and ~D objects in memory." - (cache-size cache) - (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 -;; - -(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) - (setq *cache* - (apply #'make-instance class :directory directory - (sans args :class)))) - - -(defmethod close-cache ((cache standard-cache) &key (commit t)) - (when commit - (cache-commit cache)) - (close-heap (heap cache)) - (close-schema-table (schema-table cache)) - 'ok) - -(defmacro with-cache ((cache directory &rest options) &body body) - `(let ((,cache (open-cache ,directory , at options))) - (unwind-protect (progn , at body) - (close-cache ,cache)))) - -(defmethod initialize-instance :after ((cache standard-cache) - &key - directory - (heap-class 'mark-and-sweep-heap) - (heap-options '()) - (if-exists :overwrite) - (if-does-not-exist :create) - (size 10000) - &allow-other-keys) - (ensure-directories-exist directory) - (let ((object-table (open-object-table (merge-pathnames "objects" directory) - :if-exists if-exists - :if-does-not-exist if-does-not-exist))) - (setf (cache-size cache) size) - (with-slots (heap schema-table objects) - cache - (setq heap (open-heap (merge-pathnames "heap" directory) - :class heap-class - :if-exists if-exists - :if-does-not-exist if-does-not-exist - :rucksack (rucksack cache) - :options (list* :object-table object-table - heap-options)) - schema-table (open-schema-table (merge-pathnames "schemas" directory) - :if-exists if-exists - :if-does-not-exist if-does-not-exist) - objects (make-hash-table :size size)) - (when (and (eql if-exists :overwrite) (probe-file (commit-filename cache))) - ;; We're trying to work with an existing cache but the - ;; commit file exists, so there may be a partially committed - ;; transaction that we need to undo. - (cache-recover cache))))) - - - -(defun commit-filename (cache) - (merge-pathnames "commit" - (pathname (heap-stream (heap cache))))) - - -;; -;; Cache info -;; - -(defmethod cache-count ((cache standard-cache)) - (+ (hash-table-count (objects cache)) - (loop for transaction being the hash-value of (transactions cache) - sum (transaction-nr-dirty-objects transaction)))) - -(defmethod cache-full-p ((cache cache)) - ;; Don't count dirty objects. - (>= (hash-table-count (objects cache)) (cache-size cache))) - -(defmethod cache-room ((cache cache)) - (- (cache-size cache) (cache-count cache))) - -;; -;; Create/get/touch -;; - -(defmethod cache-create-object (object (cache standard-cache)) - ;; 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) - id)) - - -(defmethod cache-touch-object (object (cache standard-cache)) - "Checks for transaction conflicts and signals a transaction conflict -if necessary. Change the object's status to dirty. If the object is -already dirty, nothing happens." - ;; This function is called by (SETF SLOT-VALUE-USING-CLASS), - ;; SLOT-MAKUNBOUND-USING-CLASS and P-DATA-WRITE. - (let ((object-id (object-id object)) - (transaction (current-transaction))) - ;; Check for transaction conflict. - (let ((old-transaction - (find-conflicting-transaction object-id cache transaction))) - (when old-transaction - (rucksack-error 'transaction-conflict - :object-id object-id - :new-transaction transaction - :old-transaction old-transaction))) - ;; - (unless (transaction-changed-object transaction object-id) ; already dirty - ;; Remove object from the 'clean objects' hash table. - ;; It would be nice to remove the object from the 'clean' queue too, - ;; but that's too expensive. We'll let MAKE-ROOM-IN-CACHE take care - ;; of that. - (remhash object-id (objects cache)) - ;; Let the transaction keep track of the dirty object. - (transaction-touch-object transaction object object-id)))) - - - -(defmethod cache-get-object (object-id (cache standard-cache)) - (let* ((transaction (current-transaction)) - (result - (or - ;; Unmodified, already loaded and compatible with the - ;; current transaction? Fine, let's use it. - (let ((object (gethash object-id (objects cache)))) - (and object - (or (null transaction) - (<= (transaction-id object) (transaction-id transaction))) - object)) - ;; Modified by an open transaction? Try to find the - ;; 'compatible' version. - (find-object-version object-id transaction cache) - ;; Not in memory at all? Then load the compatible version - ;; from disk. - (multiple-value-bind (object most-recent-p) - (load-object object-id transaction cache) - (when most-recent-p - ;; Add to in-memory cache if the loaded object is - ;; the most recent version of the object. - (when (cache-full-p cache) - (make-room-in-cache cache)) - (setf (gethash object-id (objects cache)) object)) - object)))) - ;; Put it (back) in front of the queue, so we know which - ;; objects were recently used when we need to make room - ;; in the cache. - ;; DO: If this object was already in the queue, we should remove it - ;; from the old position. But that's too expensive: so we actually - ;; need a better data structure than a simple queue. - (add-to-queue object-id cache) - result)) - - -(defun find-object-version (object-id current-transaction cache) - "Returns the object version for OBJECT-ID that's compatible with -CURRENT-TRANSACTION, or NIL if there's no such version in the cache -memory." - ;; The compatible object version for a transaction T is the version that - ;; was modified by the youngest open transaction that's older than or - ;; equal to T; if there is no such transaction, the compatible object - ;; version is the most recent (committed) version on disk. - ;; 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... - (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)))) - - - -;; -;; Queue operations -;; - -(defmethod make-room-in-cache ((cache standard-cache)) - ;; We need to remove some objects from the in-memory cache (both - ;; from the hash table and from the queue). - ;; We do this by removing the objects that have been used least - ;; recently. We don't do anything with dirty objects, because - ;; they contain changes that must still be committed to disk. - (let ((queue (queue cache)) - (nr-objects-to-remove (* (- 1.0 (cache-shrink-ratio cache)) - (cache-size cache))) - (nr-objects-removed 0)) - (loop until (or (= nr-objects-removed nr-objects-to-remove) - (queue-empty-p queue)) - do (let ((id (queue-remove queue))) - (when (remhash id (objects cache)) - (incf nr-objects-removed)))))) - - -(defun add-to-queue (object-id cache) - ;; Add an object to the end of the queue. - (let ((queue (queue cache))) - (when (cache-full-p cache) - (queue-remove queue)) - (queue-add queue object-id))) - -;; -;; Open/close/map transactions -;; - -(defmethod open-transaction ((cache standard-cache) transaction) - ;; Add to open transactions. - (setf (gethash (transaction-id transaction) (transactions cache)) - transaction)) - -(defmethod close-transaction ((cache standard-cache) transaction) - (remhash (transaction-id transaction) (transactions cache))) - -(defmethod map-transactions ((cache standard-cache) function) - ;; 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 -;; - -(defmethod cache-rollback ((cache standard-cache)) [579 lines skipped] --- /project/rucksack/cvsroot/rucksack/errors.lisp 2006/05/16 22:01:27 1.2 +++ /project/rucksack/cvsroot/rucksack/errors.lisp 2007/01/20 18:17:55 1.3 @@ -1,104 +1,104 @@ -;; $Id: errors.lisp,v 1.2 2006/05/16 22:01:27 alemmens Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Rucksack errors -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-condition rucksack-error (error) - ((rucksack :initarg :rucksack :initform (current-rucksack) - :reader rucksack))) - -(defmethod print-object ((error rucksack-error) stream) - (format stream "Rucksack error in ~A." (rucksack error))) - -(defun rucksack-error (class &rest args) - (apply #'error class - :rucksack (current-rucksack) - args)) - -;; -;; Transaction conflict -;; - -(define-condition transaction-conflict (rucksack-error) - ((transaction :initarg :transaction :initform (current-transaction) - :reader transaction) - (old-transaction :initarg :old-transaction - :initform (error "OLD-TRANSACTION initarg required -for transaction-conflict.") - :reader old-transaction) - (object-id :initarg :object-id - :initform (error "OBJECT-ID initarg required for -transaction-conflict.") - :reader object-id))) - -(defmethod print-object :after ((error transaction-conflict) stream) - (format stream "~&~A can't modify object #~D, because ~A already -modified it and hasn't committed yet." - (transaction error) - (object-id error) - (old-transaction error))) - -;; -;; Simple rucksack error -;; - -(define-condition simple-rucksack-error (rucksack-error simple-error) - ()) - -(defmethod print-object :after ((error simple-rucksack-error) stream) - (format stream "~&~A~%" - (apply #'format nil (simple-condition-format-control error) - (simple-condition-format-arguments error)))) - -(defun simple-rucksack-error (format-string &rest format-args) - (rucksack-error 'simple-rucksack-error - :format-control format-string - :format-arguments format-args)) - - -;; -;; Internal rucksack errors -;; - -(define-condition internal-rucksack-error (rucksack-error simple-error) - ()) - -(defmethod print-object :after ((error internal-rucksack-error) stream) - (format stream "~&Internal error: ~A~%" - (apply #'format nil (simple-condition-format-control error) - (simple-condition-format-arguments error)))) - -(defun internal-rucksack-error (format-string &rest format-args) - (rucksack-error 'internal-rucksack-error - :format-control format-string - :format-arguments format-args)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-condition slot-error (rucksack-error) - ;; Q: Maybe this should inherit from CELL-ERROR?? - ((object :initarg :object :reader slot-error-object) - (slot-name :initarg :slot-name :reader slot-error-name) - (value :initarg :value :reader slot-error-value))) - -(define-condition duplicate-slot-value (slot-error) - ((other-object :initarg :other-object - :reader slot-error-other-object))) - -(defmethod print-object :after ((error duplicate-slot-value) stream) - (format stream - "Attempt to assign the value ~S to the unique slot ~S of ~S. ~ -The value is already present in ~S." - (slot-error-value error) - (slot-error-name error) - (slot-error-object error) - (slot-error-other-object error))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun not-implemented (operator) - (error "~S not implemented for ~A" operator (lisp-implementation-type))) +;; $Id: errors.lisp,v 1.3 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :rucksack) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Rucksack errors +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-condition rucksack-error (error) + ((rucksack :initarg :rucksack :initform (current-rucksack) + :reader rucksack))) + +(defmethod print-object ((error rucksack-error) stream) + (format stream "Rucksack error in ~A." (rucksack error))) + +(defun rucksack-error (class &rest args) + (apply #'error class + :rucksack (current-rucksack) + args)) + +;; +;; Transaction conflict +;; + +(define-condition transaction-conflict (rucksack-error) + ((transaction :initarg :transaction :initform (current-transaction) + :reader transaction) + (old-transaction :initarg :old-transaction + :initform (error "OLD-TRANSACTION initarg required +for transaction-conflict.") + :reader old-transaction) + (object-id :initarg :object-id + :initform (error "OBJECT-ID initarg required for +transaction-conflict.") + :reader object-id))) + +(defmethod print-object :after ((error transaction-conflict) stream) + (format stream "~&~A can't modify object #~D, because ~A already +modified it and hasn't committed yet." + (transaction error) + (object-id error) + (old-transaction error))) + +;; +;; Simple rucksack error +;; + +(define-condition simple-rucksack-error (rucksack-error simple-error) + ()) + +(defmethod print-object :after ((error simple-rucksack-error) stream) + (format stream "~&~A~%" + (apply #'format nil (simple-condition-format-control error) + (simple-condition-format-arguments error)))) + +(defun simple-rucksack-error (format-string &rest format-args) + (rucksack-error 'simple-rucksack-error + :format-control format-string + :format-arguments format-args)) + + +;; +;; Internal rucksack errors +;; + +(define-condition internal-rucksack-error (rucksack-error simple-error) + ()) + +(defmethod print-object :after ((error internal-rucksack-error) stream) + (format stream "~&Internal error: ~A~%" + (apply #'format nil (simple-condition-format-control error) + (simple-condition-format-arguments error)))) + +(defun internal-rucksack-error (format-string &rest format-args) + (rucksack-error 'internal-rucksack-error + :format-control format-string + :format-arguments format-args)) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(define-condition slot-error (rucksack-error) + ;; Q: Maybe this should inherit from CELL-ERROR?? + ((object :initarg :object :reader slot-error-object) + (slot-name :initarg :slot-name :reader slot-error-name) + (value :initarg :value :reader slot-error-value))) + +(define-condition duplicate-slot-value (slot-error) + ((other-object :initarg :other-object + :reader slot-error-other-object))) + +(defmethod print-object :after ((error duplicate-slot-value) stream) + (format stream + "Attempt to assign the value ~S to the unique slot ~S of ~S. ~ +The value is already present in ~S." + (slot-error-value error) + (slot-error-name error) + (slot-error-object error) + (slot-error-other-object error))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defun not-implemented (operator) + (error "~S not implemented for ~A" operator (lisp-implementation-type))) --- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2007/01/16 08:57:43 1.20 +++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2007/01/20 18:17:55 1.21 @@ -1,580 +1,580 @@ -;; $Id: garbage-collector.lisp,v 1.20 2007/01/16 08:57:43 charmon Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Garbage collector -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass garbage-collector () - ((object-table :initarg :object-table :reader object-table) - (buffer :initform (make-instance 'serialization-buffer) - :reader serialization-buffer) - (rucksack :initarg :rucksack :reader rucksack) - ;; Some state used for incremental garbage collection. - (roots :initarg :roots :initform '() :accessor roots - :documentation "A list of object-ids of roots that must be kept alive.") - (state :initform :ready - :type (member :starting - :finishing - :ready - ;; For copying collector - :copying - ;; For mark-and-sweep collector - :marking-object-table - :scanning - :sweeping-heap - :sweeping-object-table) - :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."))) - - -(defgeneric scan (buffer garbage-collector) - (:documentation "Scans the object in the serialization buffer, marking or -evacuating (depending on garbage collector type) any child objects.")) - -(defmethod scan (buffer (gc garbage-collector)) - ;; Read serialize marker and dispatch. - (let ((marker (read-next-marker buffer))) - (unless marker - (cerror "Ignore the error and continue." - "Garbage collection error: can't find next scan marker.") - (return-from scan)) - ;; Most of the SCAN-CONTENTS methods are in serialize.lisp. - (scan-contents marker buffer gc))) - - - -(defmethod gc-work-for-size ((heap heap) size) - ;; The garbage collector needs to be ready when there's no more free space - ;; left in the heap. So when SIZE octets are allocated, the garbage collector - ;; needs to collect a proportional amount of bytes: - ;; - ;; Size / Free = Work / WorkLeft - ;; - ;; or: Work = (Size / Free) * WorkLeft - ;; - (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 heap)) - ;; Returns an estimate of the number of octets that can be - ;; allocated until the heap is full (i.e. heap-end >= heap-max-end). - ;; For a copying collector, this number is very close to the truth. - ;; But for mark-and-sweep collectorsestimate it is a very conservative - ;; estimate, because we only count the heap space that hasn't been - ;; reserved by one of the free lists (because you can't be sure that - ;; a free list block can actually be used to allocate an arbitrary-sized - ;; block). - (- (max-heap-end heap) (heap-end heap))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Mark and sweep collector -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass mark-and-sweep-heap (garbage-collector free-list-heap serializer) - (;; 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) - (nr-heap-bytes-scanned :initform 0 :accessor nr-heap-bytes-scanned) - (nr-heap-bytes-sweeped :initform 0 :accessor nr-heap-bytes-sweeped) - (nr-object-bytes-sweeped :initform 0 :accessor nr-object-bytes-sweeped) - ;; Heap growth related slots. - (max-heap-end :accessor max-heap-end - :documentation "The maximum acceptable value for heap-end -during the current garbage collection.") - (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.)"))) - - -(defparameter *initial-heap-size* (* 1024 1024) - "The default initial heap size is 1 MB. ") - -(defmethod initialize-instance :after ((heap mark-and-sweep-heap) - &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)) - (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)) - - -(defmethod close-heap :after ((heap mark-and-sweep-heap)) - (close-heap (object-table heap))) - -(defmethod initialize-block (block block-size (heap mark-and-sweep-heap)) - ;; This is called by a free list heap while creating free blocks. - ;; Write the block size (as a negative number) in the start of the - ;; block (just behind the header) to indicate that this is a free - ;; block. This is necessary for the sweep phase of a mark-and-sweep - ;; collector to distinguish it from a block that contains an object. - (file-position (heap-stream heap) (+ block (block-header-size heap))) - (serialize (- block-size) (heap-stream heap))) - - -(defmethod handle-written-object (object-id block (heap mark-and-sweep-heap)) - ;; (This is called just after a (version of an) object has been - ;; written to the heap.) Mark the object entry dead if the collector - ;; is in the marking-object-table or scanning phase, and live otherwise. - (setf (object-info (object-table heap) object-id) - (case (state heap) - ((:starting :marking-object-table :scanning) - :dead-object) - (otherwise - :live-object))) - ;; In the scanning phase, the object id must be added to the root set to - ;; guarantee that it will be marked and scanned. - (when (eql (state heap) :scanning) - (push object-id (roots heap)))) - -;; -;; Hooking into free list methods -;; - - - - -(defmethod expand-heap :after ((heap mark-and-sweep-heap) block-size) - ;; If the GC is ready but the heap must be expanded because the free - ;; list manager can't find a free block, we know that we should start - ;; collecting garbage. - (when (eql (state heap) :ready) - (setf (state heap) :starting))) - - -;; -;; Counting work -;; - -(defmethod work-left ((heap mark-and-sweep-heap)) - "Returns the amount of work that needs to be done (i.e. octets that must be -'collected') before the current garbage collection has finished." - (- (max-work heap) (work-done heap))) - -(defmethod work-done ((heap mark-and-sweep-heap)) - (+ (nr-object-bytes-marked heap) - (nr-heap-bytes-scanned heap) - (nr-heap-bytes-sweeped heap) - (nr-object-bytes-sweeped heap))) - -(defmethod max-work ((heap mark-and-sweep-heap)) - "Returns the maximum possible amount of work that the garbage -collector needs to do for one complete garbage collection." - (+ - ;; Mark and sweep the object table - (* 2 (nr-object-bytes heap)) - ;; Mark and sweep the heap - (* 2 (nr-heap-bytes heap)))) - -(defmethod nr-object-bytes ((heap mark-and-sweep-heap)) - "Returns the number of object bytes that must be handled by the garbage -collector." - (* (object-table-size (object-table heap)) - (min-block-size (object-table heap)))) - -(defmethod nr-heap-bytes ((heap mark-and-sweep-heap)) - "Returns the number of heap bytes that must be handled by the garbage -collector." - (heap-size heap)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Collect some garbage -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod collect-garbage ((heap mark-and-sweep-heap)) - ;; A simple test of COLLECT-SOME-GARBAGE: keep collecting 1024 bytes of - ;; garbage until the garbage collector is ready. - (setf (state heap) :starting) - (loop until (eql (state heap) :ready) - do (collect-some-garbage heap 1024))) - -(defmethod finish-garbage-collection ((heap mark-and-sweep-heap)) - ;; Make sure that the garbage collector is in the :ready state. - (loop until (eql (state heap) :ready) - do (collect-some-garbage heap (* 512 1024)))) - -(defmethod collect-some-garbage ((heap mark-and-sweep-heap) amount) - ;; Collect at least the specified amount of garbage - ;; (i.e. mark or sweep at least the specified amount of octets). - ;; DO: We probably need a heap lock here? - (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 - (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))) - (: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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod mark-some-objects-in-table ((heap mark-and-sweep-heap) amount) - ;; Mark all 'live' objects in the object table as dead (temporarily). - ;; Returns the amount of work done. - (let* ((object-table (object-table heap)) - (object-block-size (min-block-size object-table)) - (first-object-id (floor (nr-object-bytes-marked heap) - object-block-size)) - (work-done 0)) - (loop for object-id from first-object-id - while (and (< object-id (object-table-size object-table)) - (< work-done amount)) - do (progn - (when (eql (object-info object-table object-id) :live-object) - ;; Don't touch free or reserved blocks. - (setf (object-info object-table object-id) :dead-object)) - (incf (nr-object-bytes-marked heap) object-block-size) - (incf work-done object-block-size))) - (when (>= (nr-object-bytes-marked heap) (nr-object-bytes heap)) - ;; We've finished this stage. Move to the next step. - (setf (state heap) :scanning)) - ;; Return the amount of work done. - work-done)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Marking roots -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod mark-some-roots ((heap mark-and-sweep-heap) amount) - ;; Mark some roots and their descendants as alive. - ;; (This may add new roots.) - (let ((work-done 0)) - (loop while (and (roots heap) (< work-done amount)) - do (let ((root (pop (roots heap)))) - (incf work-done (mark-root heap root)))) - (when (null (roots heap)) - ;; We've finished marking roots. Move to the next step. - (setf (state heap) :sweeping-heap)) - ;; Return the amount of work done. - work-done)) - - -(defmethod mark-root ((heap mark-and-sweep-heap) (object-id integer)) - ;; Returns the number of octets scanned. - (let ((object-table (object-table heap))) - (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. 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))) - (setf (object-info object-table object-id) :live-object) - (scan-object object-id buffer heap) - ;; Keep track of statistics. - (let ((block-size (block-size block heap))) - (incf (nr-heap-bytes-scanned heap) block-size) - ;; Return the amount of work done. - block-size))))) - - -(defmethod load-block ((heap mark-and-sweep-heap) block - &key (buffer (serialization-buffer heap)) - (skip-header nil)) - ;; Loads the block at the specified position into the - ;; serialization buffer. If SKIP-HEADER is T, the block - ;; header is not included. Returns the buffer. - (load-buffer buffer - (heap-stream heap) - (block-size block heap) - :eof-error-p nil - :file-position (if skip-header - (+ block (block-header-size heap)) - block))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Sweeping the heap -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defmethod sweep-some-heap-blocks ((heap mark-and-sweep-heap) - (amount integer)) - (let* ((object-table (object-table heap)) - (block (+ (heap-start heap) (nr-heap-bytes-sweeped heap))) - (work-done 0)) - ;; Sweep across the heap, looking for dead blocks. - (loop - while (and (< work-done amount) - (< block (heap-end heap))) - do (multiple-value-bind (block-header block-start) - (read-block-start heap block) - ;; For non-free blocks, the block start contains a previous-pointer, - ;; which can be either nil or a positive integer. - ;; A negative block-start means the block already belongs to - ;; a free list. In that case, the block size is the abs of - ;; the block start. - ;; A non-negative (or nil) block-start means the block is occupied. - ;; In that case, the block size is in the header. - (let* ((free-p (and (integerp block-start) (minusp block-start))) - (block-size (if free-p (- block-start) block-header))) - ;; Reclaim dead blocks. - (when (and (not free-p) ; only non-free blocks - (not (block-alive-p object-table - ;; read object ID - (let ((heap-stream (heap-stream heap))) - (deserialize heap-stream) - (deserialize heap-stream)) - block))) - ;; The block is dead (either because the object is dead - ;; or because the block contains an old version): return - ;; the block to its free list. - (deallocate-block block heap)) - ;; - (incf work-done block-size) - ;; Move to next block (if there is one). - (incf block block-size)))) - ;; - (incf (nr-heap-bytes-sweeped heap) work-done) - (when (>= block (heap-end heap)) - ;; We've finished sweeping the heap: move to the next state. - (setf (state heap) :sweeping-object-table)) - ;; Return the amount of work done. - work-done)) - -(defmethod block-alive-p ((object-table object-table) object-id block) - "Returns true iff the object in the block is alive." - ;; DO: Some versions of this object may not be reachable anymore. - ;; Those should be considered dead. - (member (object-info object-table object-id) '(:reserved :live-object))) [763 lines skipped] --- /project/rucksack/cvsroot/rucksack/glossary.txt 2006/08/11 12:44:21 1.3 +++ /project/rucksack/cvsroot/rucksack/glossary.txt 2007/01/20 18:17:55 1.4 @@ -1,76 +1,76 @@ -;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.3 2006/08/11 12:44:21 alemmens Exp $ - -* block - -A free list block on disk. Each block has a fixed size header -(currently 8 octets). The header is followed by a serialized integer: -if this integer is positive, it is the id of the object whose contents -are serialized in this block. If the integer is negative, the block -belongs to a free list and is not in use; the integer's absolute value -is the size of the block (the sweep phase of the garbage collector -needs this block size). - -Also used as an abbreviation for a block's heap position. - - -* class designator - -Either a class name (i.e. a symbol) or a class. See the CLHS glossary. - - -* compatible object version - -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 - -The list with committed object versions. The list is ordered by -transaction timestamp of the transaction that created/modified the -object. The ordering is most recent transaction first. - - -* open transaction - -A transaction that hasn't rolled back or committed yet. - - -* partial transaction - -This is shorthand for 'partially committed transaction', i.e. a -transaction that has started a commit operation but hasn't finished it -yet. - -* root object - -An object that's part of the root set. - -* root set - -The root set for a garbage collector is the set of objects from which -all other live objects can be reached. Any object that can not be -reached from a root object is considered dead: its disk space may be -reused by another object if necessary. - - -* slot designator - -Either a symbol (a slot name) or a slot-definition metaobject. - +;; $Header: /project/rucksack/cvsroot/rucksack/glossary.txt,v 1.4 2007/01/20 18:17:55 alemmens Exp $ + +* block + +A free list block on disk. Each block has a fixed size header +(currently 8 octets). The header is followed by a serialized integer: +if this integer is positive, it is the id of the object whose contents +are serialized in this block. If the integer is negative, the block +belongs to a free list and is not in use; the integer's absolute value +is the size of the block (the sweep phase of the garbage collector +needs this block size). + +Also used as an abbreviation for a block's heap position. + + +* class designator + +Either a class name (i.e. a symbol) or a class. See the CLHS glossary. + + +* compatible object version + +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 + +The list with committed object versions. The list is ordered by +transaction timestamp of the transaction that created/modified the +object. The ordering is most recent transaction first. + + +* open transaction + +A transaction that hasn't rolled back or committed yet. + + +* partial transaction + +This is shorthand for 'partially committed transaction', i.e. a +transaction that has started a commit operation but hasn't finished it +yet. + +* root object + +An object that's part of the root set. + +* root set + +The root set for a garbage collector is the set of objects from which +all other live objects can be reached. Any object that can not be +reached from a root object is considered dead: its disk space may be +reused by another object if necessary. + + +* slot designator + +Either a symbol (a slot name) or a slot-definition metaobject. + --- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/09/04 12:34:34 1.12 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2007/01/20 18:17:55 1.13 @@ -1,597 +1,597 @@ -;; $Id: heap.lisp,v 1.12 2006/09/04 12:34:34 alemmens Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Heaps: API -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| -* heap [Class] - -* open-heap [Function] - -* close-heap [Function] -|# - - -(defgeneric heap-stream (heap) - (:documentation "Returns the heap's stream.")) - -(defgeneric heap-start (heap) - (:documentation "Returns the position of the first block in the heap.")) - -(defgeneric heap-end (heap) - (:documentation "Returns the end of the heap.")) - -(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. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Heap -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconstant +pointer-size+ 8 - "The number of octets for a heap pointer. A heap pointer is a number that -must be able to span the entire heap. It is used for block sizes, pointers -to other blocks, object ids and object heap positions.") - -(defclass heap () - ((stream :initarg :stream :accessor heap-stream) - (cell-buffer :initform (make-array +pointer-size+ - :element-type '(unsigned-byte 8)) - ;; Just a buffer for 1 cell. - :reader cell-buffer) - (end :accessor heap-end - :documentation "The end of the heap. For free-list heaps, this number -is stored in the first heap cell. For appending heaps, it's stored in the -end of the file.") - (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.") - (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."))) - - - -;; -;; Open/close/initialize -;; - -(defun open-heap (pathname - &key (class 'heap) rucksack (options '()) - (if-exists :overwrite) (if-does-not-exist :create)) - (let ((stream (open pathname - :element-type '(unsigned-byte 8) - :direction :io - :if-exists if-exists - :if-does-not-exist if-does-not-exist))) - (apply #'make-instance - class - :stream stream - :rucksack rucksack - options))) - - -(defmethod close-heap ((heap heap)) - (close (heap-stream heap))) - -(defmethod finish-heap-output ((heap heap)) - (finish-output (heap-stream heap))) - - -(defmethod heap-size ((heap heap)) - (- (heap-end heap) (heap-start heap))) - -;; -;; Pointers -;; - -(defun pointer-value (pointer heap) - (file-position (heap-stream heap) pointer) - (read-unsigned-bytes (cell-buffer heap) (heap-stream heap) - +pointer-size+)) - -(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+) - value) - -;; -;; Expanding the heap -;; - -(defmethod expand-heap ((heap heap) block-size) - ;; Creates (and initializes) a block of the specified size by expanding - ;; the heap. The block is not hooked into the free list yet. Returns - ;; the new block (but signals a continuable error if expanding the heap - ;; would make it exceed its maximum size. - (let ((new-block (heap-end heap)) - (max-size (max-heap-size heap))) - (when (and max-size (> (+ new-block block-size) max-size)) - (cerror "Ignore the maximum heap size and expand the heap anyway." - (format nil - "Can't expand the heap with ~D octets: it would grow beyond -the specified maximum heap size of ~D octets." - block-size - max-size))) - ;; - (incf (heap-end heap) block-size) - ;; Initialize and return the new block. - (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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass free-list-heap (heap) - ((nr-free-lists :initarg :nr-free-lists :initform 32 :reader nr-free-lists) - (starts :documentation "An array with the starts of each free-list. This -is an in-memory version of the array that's in the beginning of the heap.") - (min-block-size :initarg :min-block-size - :initform 16 :reader min-block-size - :documentation "The size of the smallest blocks. This must -be a power of 2.") - (expansion-size :initarg :expansion-size - :initform (* 32 1024) :reader expansion-size - :documentation "The minimum number of bytes that will be -used to expand a free-list.")) - - (:documentation "This heap uses a 'segregated free list' system: the -first list contains 16-octet blocks (including the header), the second -list contains 32-octet blocks, the third has 64-octet blocks, etc. When -there are N free lists, the last is for blocks of 16*2^(N-1) octets. - -Each block starts with an 8-octet header. If a block is in use, the -header contains the block's size. If a block is still free, the header -contains a pointer to the next block on the same free list.")) - - -(defmethod initialize-instance :after ((heap free-list-heap) - &key &allow-other-keys) - ;; Initialize the heap end. - (if (zerop (file-length (heap-stream heap))) - (setf (heap-end heap) +pointer-size+) - (setf (slot-value heap 'end) (pointer-value 0 heap))) - ;; Load or create the array of free list pointers. - (setf (slot-value heap 'starts) - (make-array (nr-free-lists heap))) - (cond ((< (heap-end heap) (heap-start heap)) - ;; The free list array doesn't exist yet: create free lists. - ;; Initialize the free list array by letting the free-list pointers - ;; point to themselves (meaning that the free list is empty). - (loop for size-class below (nr-free-lists heap) - do (setf (free-list-start heap size-class) - (free-list-pointer size-class))) - ;; Set heap-end just after the free list array. - (setf (heap-end heap) (heap-start heap))) - (t - ;; Heap exists: load free lists. - (let ((array (slot-value heap 'starts))) - (loop for size-class below (nr-free-lists heap) - do (setf (aref array size-class) - (pointer-value (free-list-pointer size-class) - heap))))))) - -(defun free-list-pointer (size-class) - "Returns a pointer to the cell containing the free list start." - (+ +pointer-size+ ; skip heap end cell - (* size-class +pointer-size+))) - - -(defmethod heap-start ((heap free-list-heap)) - ;; A free-list-heap starts with an array of pointers to the first element - ;; of each free list; the heap blocks start after that array. - (free-list-pointer (nr-free-lists heap))) - -(defmethod (setf heap-end) :after (end (heap free-list-heap)) - ;; Store the heap end in the file. - (setf (pointer-value 0 heap) end)) - -;; -;; - -(defmethod size-class (size (heap free-list-heap)) - "Returns the (zero-indexed) number of a free-list that has blocks -with sizes at least as big as the specified size." - ;; Assuming a min-block-size of 16, we want: - ;; - class 0 for blocks of 1..16 - ;; - class 1 for blocks of 17..32 - ;; - class 2 for blocks of 33..64 - ;; - etc. - ;; So we subtract 1, shift right by 3 and then look at the most - ;; significant 1 bit. - (integer-length (ash (1- size) - (- 1 (integer-length (min-block-size heap)))))) - -(defmethod size-class-block-size (size-class (heap free-list-heap)) - (* (min-block-size heap) (ash 1 size-class))) - -;; -;; - -(defmethod free-list-start ((heap free-list-heap) &optional (size-class 0)) - "Returns the first block on the free list of the specified size class." - (aref (slot-value heap 'starts) size-class)) - -(defmethod (setf free-list-start) (pointer (heap free-list-heap) - &optional (size-class 0)) - (setf (pointer-value (free-list-pointer size-class) heap) pointer - ;; Keep copy in memory - (aref (slot-value heap 'starts) size-class) pointer)) - -(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)))) - -;; -;; - -(defmethod block-header-size ((heap free-list-heap)) - +pointer-size+) - -(defmethod block-header (block (heap free-list-heap)) - (pointer-value block heap)) - -(defmethod (setf block-header) (value block (heap free-list-heap)) - (setf (pointer-value block heap) value)) - -(defmethod (setf block-size) (size block (heap free-list-heap)) - (setf (block-header block heap) size)) - -(defgeneric block-size (block heap) - (:documentation "Returns the size of the block starting at the -specified position. This includes the size of the block header.")) - -(defmethod block-size (block (heap free-list-heap)) - ;; Actually, the header only contains the block size when - ;; the block is occupied. - (block-header block heap)) - - -;; -;; Allocating and deallocating blocks -;; - -(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. - ;; Each block will be at least half full anyway (otherwise a block - ;; from another free list would have been allocated). On average, - ;; I suppose each block will be 75% full. It would be possible to - ;; give the remaining 25% to a free list of a lower size class, but - ;; 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 empty. - (when (free-list-empty-p size-class heap) - (if expand - (setq block (expand-free-list size-class heap)) - (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). - (let ((next-block (block-header block heap))) - (setf (free-list-start heap size-class) next-block)) - ;; Put block size (including the size of header and unused part) - ;; into header. - (setf (block-size block heap) (size-class-block-size size-class heap)) - ;; Return the block. - (values block size))) - - -(defmethod deallocate-block (block (heap free-list-heap)) - ;; 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-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) - ;; Normal case: let free list start point to the block, - ;; the block to the old block that the free list start pointed to. - (let ((old-first-block (free-list-start heap size-class))) - (setf (block-header block heap) old-first-block - (free-list-start heap size-class) block))) - ;; - (initialize-block block size heap))) - - -;; -;; Expanding free lists -;; - -(defmethod expand-free-list (size-class (heap free-list-heap)) - ;; Try to find a block that's at least EXPANSION-SIZE big on - ;; one of the bigger free lists. If there is such a block, - ;; carve it up. If there isn't, expand the heap if possible. - (let ((min-size - (if (< (1+ size-class) (nr-free-lists heap)) - (max (expansion-size heap) - ;; Make sure we only try bigger free lists than - ;; the current one. - (size-class-block-size (1+ size-class) heap)) - (expansion-size heap)))) - (multiple-value-bind (block size) - (find-block min-size heap) - (unless block - (setq size (max (expansion-size heap) - (size-class-block-size size-class heap)) - block (expand-heap heap size))) - (carve-up-block-for-free-list size-class block size heap) - ;; Return the first new block. - block))) - -(defmethod find-block (min-size (heap free-list-heap)) - ;; Tries to find a block of a size that's at least the specified - ;; minimum size. If there is such a block, the block and the - ;; block's size are returned. Otherwise it returns nil. - (let ((size-class (size-class min-size heap))) - (loop for size-class from size-class below (nr-free-lists heap) - do (let ((block (allocate-block heap :size min-size :expand nil))) - (when block - (return (values block - (size-class-block-size size-class heap)))))))) - - -(defmethod carve-up-block-for-free-list (size-class block size - (heap free-list-heap)) - "Carves up a block of the given size to build a free list for the -specified size-class. Returns the first block of the created free -list." - (let* ((sub-block-size (size-class-block-size size-class heap)) - (nr-sub-blocks (floor size sub-block-size))) - ;; Create sub-blocks, each pointing to the next. - (loop for i below (1- nr-sub-blocks) - for sub-block from block by sub-block-size - do (let ((next-sub-block (+ sub-block sub-block-size))) - ;; Let the sub-block point to its neighbour. - (setf (block-header sub-block heap) next-sub-block) - (initialize-block sub-block sub-block-size heap))) - ;; Let the last sub-block point to the start of the free list. - (let ((last-block (+ block (* sub-block-size (1- nr-sub-blocks))))) - (setf (block-header last-block heap) (free-list-pointer size-class)) [797 lines skipped] --- /project/rucksack/cvsroot/rucksack/index.lisp 2006/11/30 10:45:34 1.8 +++ /project/rucksack/cvsroot/rucksack/index.lisp 2007/01/20 18:17:55 1.9 @@ -1,212 +1,212 @@ -;; $Id: index.lisp,v 1.8 2006/11/30 10:45:34 alemmens Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Indexing: API -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgeneric map-index (index function - &key equal min max include-min include-max order) - (:documentation "Calls FUNCTION for all key/value pairs in the btree -where key is in the specified interval. FUNCTION must be a binary -function; the first argument is the index key, the second argument is -the index value (or list of values, for indexes with non-unique keys). - -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 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 -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 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.")) - -(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.")) - -;; make-index (index-spec unique-keys-p) [Function] - -;; index-spec-equal (index-spec-1 index-spec-2) [Function] - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Index class -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(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) - (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))) - (unless (p-eql value index) - (if (btree-unique-keys-p index) - ;; We have a single value: call FUNCTION directly. - (funcall function equal value) - ;; We have a persistent list of values: call FUNCTION for - ;; each element of that list. - (p-mapc (lambda (elt) (funcall function equal elt)) - value)))) - (apply #'map-btree index function :order order args))) - - -(defmethod index-data-insert ((index btree) key value - &key (if-exists :overwrite)) - (btree-insert index key value :if-exists if-exists)) - -(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 index-spec-equal (index-spec-1 index-spec-2) - "Returns T iff two index specs are equal." - (flet ((plist-subset-p (plist-1 plist-2) - (loop for (key value) on plist-1 by #'cddr - always (equal (getf plist-2 key) value)))) - (or (eql index-spec-1 index-spec-2) - (and (listp index-spec-1) - (listp index-spec-2) - (eql (first index-spec-1) - (first index-spec-2)) - (plist-subset-p (rest index-spec-1) (rest index-spec-2)) - (plist-subset-p (rest index-spec-2) (rest index-spec-1)))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Defining index specs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(eval-when (:compile-toplevel :load-toplevel :execute) - - ;; - ;; 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))))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Predefined index specs -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun trim-whitespace (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))) +;; $Id: index.lisp,v 1.9 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :rucksack) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Indexing: API +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(defgeneric map-index (index function + &key equal min max include-min include-max order) + (:documentation "Calls FUNCTION for all key/value pairs in the btree +where key is in the specified interval. FUNCTION must be a binary +function; the first argument is the index key, the second argument is +the index value (or list of values, for indexes with non-unique keys). + +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 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 +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 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.")) + +(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.")) + +;; make-index (index-spec unique-keys-p) [Function] + +;; index-spec-equal (index-spec-1 index-spec-2) [Function] + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Index class +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(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) + (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))) + (unless (p-eql value index) + (if (btree-unique-keys-p index) + ;; We have a single value: call FUNCTION directly. + (funcall function equal value) + ;; We have a persistent list of values: call FUNCTION for + ;; each element of that list. + (p-mapc (lambda (elt) (funcall function equal elt)) + value)))) + (apply #'map-btree index function :order order args))) + + +(defmethod index-data-insert ((index btree) key value + &key (if-exists :overwrite)) + (btree-insert index key value :if-exists if-exists)) + +(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 index-spec-equal (index-spec-1 index-spec-2) + "Returns T iff two index specs are equal." + (flet ((plist-subset-p (plist-1 plist-2) + (loop for (key value) on plist-1 by #'cddr + always (equal (getf plist-2 key) value)))) + (or (eql index-spec-1 index-spec-2) + (and (listp index-spec-1) + (listp index-spec-2) + (eql (first index-spec-1) + (first index-spec-2)) + (plist-subset-p (rest index-spec-1) (rest index-spec-2)) + (plist-subset-p (rest index-spec-2) (rest index-spec-1)))))) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; Defining index specs +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(eval-when (:compile-toplevel :load-toplevel :execute) + + ;; + ;; 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))))) + [27 lines skipped] --- /project/rucksack/cvsroot/rucksack/make.lisp 2006/08/24 15:45:02 1.5 +++ /project/rucksack/cvsroot/rucksack/make.lisp 2007/01/20 18:17:55 1.6 @@ -1,44 +1,44 @@ -;; $Id: make.lisp,v 1.5 2006/08/24 15:45:02 alemmens Exp $ - -(in-package :cl-user) - -(eval-when (:load-toplevel :compile-toplevel :execute) - (defparameter *rucksack-directory* *load-pathname*)) - -(defun make (&key (debug t)) - (when debug - (proclaim '(optimize (debug 3) (speed 0) (space 0)))) - (loop for file in '("queue" - "package" - "errors" - "mop" - "serialize" - "heap" - "object-table" - "schema-table" - "garbage-collector" - "cache" - "objects" - "p-btrees" - "index" - "rucksack" - "transactions" - "test") - do (tagbody - :retry - (let ((lisp (make-pathname :name file - :type "lisp" - :defaults *rucksack-directory*))) - (multiple-value-bind (fasl warnings failure) - (compile-file lisp) - (declare (ignore warnings)) - (when failure - (restart-case - (error "COMPILE-FILE reported failure on ~A" lisp) - (retry () - :report "Retry compilation" - (go :retry)) - (continue () - :report "Load resulting fasl anyway" - nil))) - (load fasl)))))) +;; $Id: make.lisp,v 1.6 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :cl-user) + +(eval-when (:load-toplevel :compile-toplevel :execute) + (defparameter *rucksack-directory* *load-pathname*)) + +(defun make (&key (debug t)) + (when debug + (proclaim '(optimize (debug 3) (speed 0) (space 0)))) + (loop for file in '("queue" + "package" + "errors" + "mop" + "serialize" + "heap" + "object-table" + "schema-table" + "garbage-collector" + "cache" + "objects" + "p-btrees" + "index" + "rucksack" + "transactions" + "test") + do (tagbody + :retry + (let ((lisp (make-pathname :name file + :type "lisp" + :defaults *rucksack-directory*))) + (multiple-value-bind (fasl warnings failure) + (compile-file lisp) + (declare (ignore warnings)) + (when failure + (restart-case + (error "COMPILE-FILE reported failure on ~A" lisp) + (retry () + :report "Retry compilation" + (go :retry)) + (continue () + :report "Load resulting fasl anyway" + nil))) + (load fasl)))))) --- /project/rucksack/cvsroot/rucksack/mop.lisp 2007/01/16 08:31:49 1.12 +++ /project/rucksack/cvsroot/rucksack/mop.lisp 2007/01/20 18:17:55 1.13 @@ -1,266 +1,266 @@ -;; $Id: mop.lisp,v 1.12 2007/01/16 08:31:49 charmon Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; MOP Magic -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; -;;; Metaclass PERSISTENT-CLASS -;;; - -(defclass persistent-class (standard-class) - ((persistent-slots :initform '() - :accessor class-persistent-slots) - (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.") - (changed-p :initform nil :accessor class-changed-p - :documentation "True iff the class definition was changed -but the schemas haven't been updated yet. This flag is necessary because -some MOP implementations don't call FINALIZE-INHERITANCE when a class -was redefined and a new instance of the redefined class is created."))) - - -(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 - :reader slot-persistence - :documentation "T for persistent slots, NIL for -transient slots. Default value is T.") - (index :initarg :index - :initform nil - :reader slot-index - :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 - :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) - ()) - -(defclass persistent-effective-slot-definition - (persistent-slot-mixin standard-effective-slot-definition) - ()) - - -;; -;; 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) - (superclass persistent-class)) - t) - - -(defmethod validate-superclass ((class persistent-class) - (superclass standard-class)) - t) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Initializing the persistent-class metaobjects -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; -;; The (RE)INITIALIZE-INSTANCE methods below get called whenever a class with -;; metaclass PERSISTENT-CLASS is (re-)defined. When that happens, we: -;; - make sure that the class inherits from persistent-object -;; - create or update schemas. - -(defmethod initialize-instance :around ((class persistent-class) - &rest args - &key direct-superclasses - &allow-other-keys) - ;; Make sure the class inherits from persistent-object. - (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)) - - -(defmethod reinitialize-instance :around ((class persistent-class) - &rest args - &key direct-superclasses - &allow-other-keys) - (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))) - (setf (class-changed-p class) t) - (update-indexes class) - result)) - - - -(defun maybe-add-persistent-object-class (class direct-superclasses) - ;; Add PERSISTENT-OBJECT to the superclass list if necessary. - (let ((root-class (find-class 'persistent-object nil)) - (persistent-class (find-class 'persistent-class))) - (if (or (null root-class) - (eql class root-class) - (find-if (lambda (direct-superclass) - (member persistent-class - (compute-class-precedence-list - (class-of direct-superclass)))) - direct-superclasses)) - direct-superclasses - (cons root-class direct-superclasses)))) - -(defun update-indexes (class) - ;; Update class and slot indexes. - (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))))) - - -(defmethod finalize-inheritance :after ((class persistent-class)) - (update-slot-info class)) - -(defun update-slot-info (class) - ;; Register all (effective) persistent slots. - (setf (class-persistent-slots class) - (remove-if-not #'slot-persistence (class-slots class))) - ;; Update schemas if necessary. - (when (fboundp 'current-rucksack) ; see comment for UPDATE-INDEXES - (let ((rucksack (current-rucksack))) - (when rucksack - (maybe-update-schemas (schema-table (rucksack-cache rucksack)) - class)))) - ;; - (setf (class-changed-p class) nil)) - -(defun maybe-update-slot-info (class) - (when (class-changed-p class) - (update-slot-info class))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Computing slot definitions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod direct-slot-definition-class ((class persistent-class) - &rest initargs) - (declare (ignore initargs)) - (find-class 'persistent-direct-slot-definition)) - -(defmethod effective-slot-definition-class ((class persistent-class) - &rest initargs) - (declare (ignore initargs)) - (find-class 'persistent-effective-slot-definition)) - - - -(defmethod compute-effective-slot-definition ((class persistent-class) - slot-name - direct-slot-definitions) - (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-slotdef 'persistence) - (some #'slot-persistence persistent-slotdefs)) - - ;; If exactly one direct slot is indexed, then the effective one is - ;; too. If more then one is indexed, signal an error. - (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-slotdefs))) - (index-slotdefs - (setf (slot-value effective-slotdef 'index) - (slot-index (car index-slotdefs)))))) - - ;; If exactly one direct slot is unique, then the effective one is - ;; too. If more then one is unique, signal an error. - (let ((unique-slotdefs (remove-if-not #'slot-unique persistent-slotdefs))) - (cond ((cdr unique-slotdefs) - (error "Multiple uniques for slot ~S in ~S:~% ~{~S~^, ~}." - slot-name class - (mapcar #'slot-unique unique-slotdefs))) - (unique-slotdefs - (setf (slot-value effective-slotdef 'unique) - (slot-unique (car unique-slotdefs)))))) - - ;; Return the effective slot definition. - effective-slotdef)) - +;; $Id: mop.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :rucksack) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; MOP Magic +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; +;;; Metaclass PERSISTENT-CLASS +;;; + +(defclass persistent-class (standard-class) + ((persistent-slots :initform '() + :accessor class-persistent-slots) + (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.") + (changed-p :initform nil :accessor class-changed-p + :documentation "True iff the class definition was changed +but the schemas haven't been updated yet. This flag is necessary because +some MOP implementations don't call FINALIZE-INHERITANCE when a class +was redefined and a new instance of the redefined class is created."))) + + +(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 + :reader slot-persistence + :documentation "T for persistent slots, NIL for +transient slots. Default value is T.") + (index :initarg :index + :initform nil + :reader slot-index + :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 + :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) + ()) + +(defclass persistent-effective-slot-definition + (persistent-slot-mixin standard-effective-slot-definition) + ()) + + +;; +;; 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) + (superclass persistent-class)) + t) + + +(defmethod validate-superclass ((class persistent-class) + (superclass standard-class)) + t) + + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Initializing the persistent-class metaobjects +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;; +;; The (RE)INITIALIZE-INSTANCE methods below get called whenever a class with +;; metaclass PERSISTENT-CLASS is (re-)defined. When that happens, we: +;; - make sure that the class inherits from persistent-object +;; - create or update schemas. + +(defmethod initialize-instance :around ((class persistent-class) + &rest args + &key direct-superclasses [135 lines skipped] --- /project/rucksack/cvsroot/rucksack/object-table.lisp 2006/08/03 11:39:39 1.3 +++ /project/rucksack/cvsroot/rucksack/object-table.lisp 2007/01/20 18:17:55 1.4 @@ -1,132 +1,132 @@ -;; $Id: object-table.lisp,v 1.3 2006/08/03 11:39:39 alemmens Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Object table -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; The object table maps object-ids to their (file) positions in the heap. -;;; It's implemented as a simple-free-list-heap, with blocks of 16 octets -;; (including the header that's used by the free list). -;;; Each block contains the object's heap position, plus an extra octet -;;; for stuff like garbage collection info (e.g. a mark bit). - - -(defclass object-table (simple-free-list-heap) - () - (:documentation "A file mapping object identifiers to their file-positions in -the 'real' heap.")) - -(defmethod initialize-block (block block-size (object-table object-table)) - ;; Initialize a free block. - ;; Put a marker in the start of the block to show that the block belongs - ;; to the free list. - (declare (ignore block-size)) - (setf (object-info object-table (block-to-object-id block object-table)) - :free-block)) - -(defun open-object-table (pathname &key (if-exists :overwrite) - (if-does-not-exist :create)) - (open-heap pathname - :class 'object-table - :if-exists if-exists - :if-does-not-exist if-does-not-exist)) - - -(defun close-object-table (object-table) - (close-heap object-table)) - -;; -;; Mappings blocks to/from object ids. -;; - -(defun block-to-object-id (block object-table) - (floor (- block (heap-start object-table)) - (min-block-size object-table))) - -(defun object-id-to-block (id object-table) - (+ (heap-start object-table) - (* id (min-block-size object-table)))) - -;; -;; Creating/deleting object ids. -;; - -(defun new-object-id (object-table) - "Returns an OBJECT-ID that is not in use." - (let* ((block (allocate-block object-table :expand t)) - (id (block-to-object-id block object-table))) - (setf (object-info object-table id) :reserved) - (block-to-object-id block object-table))) - -(defun delete-object-id (object-table object-id) - "Returns object-id's cell to the free-list." - (deallocate-block (object-id-to-block object-id object-table) - object-table)) - -;; -;; Heap-position and object-info -;; - -;; The heap-position is in the least significant octets of an object-table cell. -;; The other object-info is in the most significant octet(s). - -(defconstant +nr-object-info-octets+ 1) -(defconstant +nr-object-position-octets+ - ;; We have 7 octets for the serialized heap position. - ;; The first of those octets will be an integer marker (for the - ;; serializer); that leaves 6 octets for the actual heap position. - ;; So the max heap size is 2^48 = 256 terabytes. - (- +pointer-size+ +nr-object-info-octets+)) - -(defun (setf object-heap-position) (position object-table id) - (let ((stream (heap-stream object-table))) - (file-position stream - (+ (block-header-size object-table) - +nr-object-info-octets+ - (object-id-to-block id object-table))) - (serialize position stream)) - position) - -(defun object-heap-position (object-table id) - (let ((stream (heap-stream object-table))) - (file-position stream - (+ (block-header-size object-table) - +nr-object-info-octets+ - (object-id-to-block id object-table))) - (deserialize stream))) - - -(defun object-info (object-table id) - "Returns either :free-block, :dead-object, :live-object or :reserved." - (let ((stream (heap-stream object-table))) - (file-position stream - (+ (block-header-size object-table) - (object-id-to-block id object-table))) - (deserialize stream))) - - -(defun (setf object-info) (info object-table id) - (let ((stream (heap-stream object-table))) - (file-position stream - (+ (block-header-size object-table) - (object-id-to-block id object-table))) - (let ((marker (ecase info - (:free-block +free-block+) - (:dead-object +dead-object+) - (:live-object +live-object+) - (:reserved +reserved-object+)))) - (serialize-marker marker stream))) - info) - - -;; -;; Size of object table. -;; - -(defun object-table-size (object-table) - "Returns the potential number of objects in an object-table. -The first potential object-id is number 0." - (floor (heap-size object-table) (min-block-size object-table))) - +;; $Id: object-table.lisp,v 1.4 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :rucksack) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Object table +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; The object table maps object-ids to their (file) positions in the heap. +;;; It's implemented as a simple-free-list-heap, with blocks of 16 octets +;; (including the header that's used by the free list). +;;; Each block contains the object's heap position, plus an extra octet +;;; for stuff like garbage collection info (e.g. a mark bit). + + +(defclass object-table (simple-free-list-heap) + () + (:documentation "A file mapping object identifiers to their file-positions in +the 'real' heap.")) + +(defmethod initialize-block (block block-size (object-table object-table)) + ;; Initialize a free block. + ;; Put a marker in the start of the block to show that the block belongs + ;; to the free list. + (declare (ignore block-size)) + (setf (object-info object-table (block-to-object-id block object-table)) + :free-block)) + +(defun open-object-table (pathname &key (if-exists :overwrite) + (if-does-not-exist :create)) + (open-heap pathname + :class 'object-table + :if-exists if-exists + :if-does-not-exist if-does-not-exist)) + + +(defun close-object-table (object-table) + (close-heap object-table)) + +;; +;; Mappings blocks to/from object ids. +;; + +(defun block-to-object-id (block object-table) + (floor (- block (heap-start object-table)) + (min-block-size object-table))) + +(defun object-id-to-block (id object-table) + (+ (heap-start object-table) + (* id (min-block-size object-table)))) + +;; +;; Creating/deleting object ids. +;; + +(defun new-object-id (object-table) + "Returns an OBJECT-ID that is not in use." + (let* ((block (allocate-block object-table :expand t)) + (id (block-to-object-id block object-table))) + (setf (object-info object-table id) :reserved) + (block-to-object-id block object-table))) + +(defun delete-object-id (object-table object-id) + "Returns object-id's cell to the free-list." + (deallocate-block (object-id-to-block object-id object-table) + object-table)) + +;; +;; Heap-position and object-info +;; + +;; The heap-position is in the least significant octets of an object-table cell. +;; The other object-info is in the most significant octet(s). + +(defconstant +nr-object-info-octets+ 1) +(defconstant +nr-object-position-octets+ + ;; We have 7 octets for the serialized heap position. + ;; The first of those octets will be an integer marker (for the + ;; serializer); that leaves 6 octets for the actual heap position. + ;; So the max heap size is 2^48 = 256 terabytes. + (- +pointer-size+ +nr-object-info-octets+)) + +(defun (setf object-heap-position) (position object-table id) + (let ((stream (heap-stream object-table))) + (file-position stream + (+ (block-header-size object-table) + +nr-object-info-octets+ + (object-id-to-block id object-table))) + (serialize position stream)) + position) + +(defun object-heap-position (object-table id) + (let ((stream (heap-stream object-table))) + (file-position stream + (+ (block-header-size object-table) + +nr-object-info-octets+ + (object-id-to-block id object-table))) + (deserialize stream))) + + +(defun object-info (object-table id) + "Returns either :free-block, :dead-object, :live-object or :reserved." + (let ((stream (heap-stream object-table))) + (file-position stream + (+ (block-header-size object-table) + (object-id-to-block id object-table))) + (deserialize stream))) + + +(defun (setf object-info) (info object-table id) + (let ((stream (heap-stream object-table))) + (file-position stream + (+ (block-header-size object-table) + (object-id-to-block id object-table))) + (let ((marker (ecase info + (:free-block +free-block+) + (:dead-object +dead-object+) + (:live-object +live-object+) + (:reserved +reserved-object+)))) + (serialize-marker marker stream))) + info) + + +;; +;; Size of object table. +;; + +(defun object-table-size (object-table) + "Returns the potential number of objects in an object-table. +The first potential object-id is number 0." + (floor (heap-size object-table) (min-block-size object-table))) + --- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/09/04 12:34:34 1.17 +++ /project/rucksack/cvsroot/rucksack/objects.lisp 2007/01/20 18:17:55 1.18 @@ -1,819 +1,819 @@ -;; $Id: objects.lisp,v 1.17 2006/09/04 12:34:34 alemmens Exp $ - -(in-package :rucksack) - -(defvar *rucksack* nil - "The current rucksack (NIL if there is no open rucksack).") - -(defun current-rucksack () - *rucksack*) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Persistent objects API -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; Conventions: -;; Persistent equivalents of CL functions always have a "p-" prefix. - -(defgeneric object-id (object) - (:documentation "Returns the object id of a persistent-object or -persistent-data.")) - -(defgeneric p-eql (x y) - (:documentation "The persistent equivalent of EQL.")) - -#| -persistent-object -persistent-data - persistent-cons - persistent-array - -p-cons -p-car -p-cdr -(setf p-car) -(setf p-cdr) -p-list - -p-make-array -p-aref -(setf p-aref) -p-array-dimensions - -p-length -p-find -p-replace -p-position -|# - - - -(defmethod p-eql (a b) - ;; Default method. - (eql a b)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Proxy -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass proxy () - ((object-id :initarg :object-id :reader object-id) - (rucksack :initform (current-rucksack) :initarg :rucksack :reader rucksack)) - (:documentation "Proxies are some kind of in-memory forwarding pointer -to data in the cache. They are never saved on disk.")) - -(defparameter *dont-dereference-proxies* nil) - -(defmethod maybe-dereference-proxy ((proxy proxy)) - (if *dont-dereference-proxies* - proxy - (cache-get-object (object-id proxy) (cache proxy)))) - -(defmethod maybe-dereference-proxy (object) - ;; Default: just return the object. - object) - -(defun cache (object) - (and (slot-boundp object 'rucksack) - (rucksack object) - (rucksack-cache (rucksack object)))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Low level persistent data structures. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass persistent-data () - ((object-id :initarg :object-id :reader object-id) - (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.")) - -(defmethod print-object ((object persistent-data) stream) - (print-unreadable-object (object stream :type t :identity nil) - (format stream "#~D~@[ in ~A~]" - (slot-value object 'object-id) - (cache object)))) - -(defmethod compute-persistent-slot-names ((class standard-class) - (object persistent-data)) - ;; Tell the schema table that instances of persistent-data have - ;; one persistent slot: the CONTENTS slot. - '(contents)) - - -(defmethod p-eql ((a persistent-data) (b persistent-data)) - (= (object-id a) (object-id b))) - -(defmethod persistent-data-read (function (data persistent-data) &rest args) - (let ((value (apply function (contents data) args))) - (if (typep value 'proxy) - (maybe-dereference-proxy value) - value))) - -(defmethod persistent-data-write (function (data persistent-data) value - &rest args) - (apply function value (contents data) args) - (cache-touch-object data (cache data))) - -(defun make-persistent-data (class contents - &optional (rucksack (current-rucksack))) - (let ((object (make-instance class - :contents contents - :rucksack rucksack)) - (cache (and rucksack (rucksack-cache rucksack)))) - (when cache - (let ((object-id (cache-create-object object cache))) - ;; Q: What about the transaction-id slot? - ;; Do we need to set that too? - (setf (slot-value object 'object-id) object-id))) - object)) - - - -;; -;; Array -;; - -(defclass persistent-array (persistent-data) - ()) - -(defun p-make-array (dimensions &rest options &key &allow-other-keys) - (let ((contents (apply #'make-array dimensions options))) - (make-persistent-data 'persistent-array contents))) - -(defmethod p-aref ((array persistent-array) &rest indices) - (apply #'persistent-data-read #'aref array indices)) - -(defmethod (setf p-aref) (new-value (array persistent-array) &rest indices) - (persistent-data-write (lambda (new-value contents) - (setf (apply #'aref contents indices) new-value)) - array - new-value)) - -(defmethod p-array-dimensions ((array persistent-array)) - (persistent-data-read #'array-dimensions array)) - -;; DO: Other array functions - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Conses -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; Basics -;; - -(defclass persistent-cons (persistent-data) - ()) - -(defun p-cons (car cdr) - (make-persistent-data 'persistent-cons (cons car cdr))) - -(defmethod p-car ((cons persistent-cons)) - (persistent-data-read #'car cons)) - -(defmethod (setf p-car) (value (cons persistent-cons)) - (persistent-data-write (lambda (new-value contents) - (setf (car contents) new-value)) - cons - value)) - -(defmethod p-cdr ((cons persistent-cons)) - (persistent-data-read #'cdr cons)) - -(defmethod (setf p-cdr) (value (cons persistent-cons)) - (persistent-data-write (lambda (new-value contents) - (setf (cdr contents) new-value)) - cons - value)) - -(defun p-list (&rest objects) - (if (endp objects) - objects - (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))) - (error "~S expected a persistent vector instead of ~S." - function-name - persistent-array))) - -(defmethod p-length ((vector persistent-array)) - (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)) - (check-p-vector vector 'p-find) - (loop for i from start below (or end (p-length vector)) - do (let ((elt (funcall key (p-aref vector i)))) - (when (funcall test value elt) - (return-from p-find (p-aref vector i))))) - ;; Return nil if not found - nil) - -(defmethod p-find (value (list persistent-cons) - &key (key #'identity) (test #'p-eql) - (start 0) (end nil)) - ;; Move list to start position. - (loop repeat start - do (setq list (p-cdr list))) - ;; The real work. - (loop for i from start do - (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) - (return-from p-find (p-car list)) - (setq list (p-cdr list)))))) - ;; Return nil if not found. - nil) - -(defmethod p-find (value (list (eql nil)) &key &allow-other-keys) - nil) - -(defmethod p-position (value (vector persistent-array) - &key (key #'identity) (test #'p-eql) - (start 0) (end nil)) - (check-p-vector vector 'p-position) - (loop for i from start below (or end (p-length vector)) - do (let ((elt (funcall key (p-aref vector i)))) - (when (funcall test value elt) - (return-from p-position i)))) - ;; Return nil if not found - nil) - -(defmethod p-replace ((vector-1 persistent-array) - (vector-2 persistent-array) - &key (start1 0) end1 (start2 0) end2) - ;; We don't need to look at the cached sequence elements, - ;; so we can just use CL:REPLACE on the vector contents and bypass - ;; the p-aref calls. - (replace (contents vector-1) (contents vector-2) - :start1 start1 - :end1 end1 - :start2 start2 - :end2 end2) - ;; Touch the vector because it has changed. - (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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass persistent-object () - ((object-id :initarg :object-id :reader object-id - :persistence nil :index nil) - (transaction-id :reader transaction-id :persistence nil :index nil) - (rucksack :initarg :rucksack :reader rucksack :persistence nil :index nil)) - (:default-initargs [1241 lines skipped] --- /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/01/16 08:47:36 1.12 +++ /project/rucksack/cvsroot/rucksack/p-btrees.lisp 2007/01/20 18:17:55 1.13 @@ -1,1074 +1,1074 @@ -;; $Id: p-btrees.lisp,v 1.12 2007/01/16 08:47:36 charmon 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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| - ;; Btrees - #:btree - #: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-nr-keys #:btree-nr-values - - ;; Nodes - #:btree-node - - ;; Functions - #: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 - #: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.")) - - -(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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| - -This is a modified version of the in-memory btrees. We use p-arrays, -p-conses and persistent-objects. - -Basically, a B-tree is a balanced multi-way tree. - -The reason for using multi-way trees instead of binary trees is that the nodes -are expected to be on disk; it would be inefficient to have to execute -a disk operation for each tree node if it contains only 2 keys. - -The key property of B-trees is that each possible search path has the same -length, measured in terms of nodes. -|# - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Conditions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(define-condition btree-error (error) - ((btree :initarg :btree :reader btree-error-btree))) - -(define-condition btree-search-error (btree-error) - ((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) - ()) - -(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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass btree () - ((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 - :initform 'btree-node) - (max-node-size :initarg :max-node-size - :reader btree-max-node-size - :initform 32 - :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.") - (key-type :initarg :key-type - :reader btree-key-type - :initform t - :documentation "The type of all keys.") - (value-type :initarg :value-type - :reader btree-value-type - :initform t - :documentation "The type of all values.") - (root :accessor btree-root)) - (:metaclass persistent-class)) - - -(defmethod initialize-instance :around ((btree btree) - &rest initargs - &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 or RUCKSACK packages. - (declare (ignore initargs)) - (if (and (symbolp key<) (symbolp value=) - (symbolp key-key) (symbolp value-key)) - (call-next-method) - (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< (slot-value btree 'key<)) - (key-key (btree-key-key btree))) - (lambda (key1 key2) - (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< (slot-value btree 'key<)) - (key-key (btree-key-key btree))) - (lambda (key1 key2) - (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< (slot-value btree 'key<)) - (key-key (btree-key-key btree))) - (lambda (key1 key2) - (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. -;; - -(defclass btree-node () - ((index :initarg :index - :initform '() - :accessor btree-node-index - :documentation "A vector of key/value pairs. The keys are -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.") - (index-count :initform 0 - :accessor btree-node-index-count - :documentation "The number of key/value pairs in the index vector.") - (leaf-p :initarg :leaf-p :initform nil :reader btree-node-leaf-p)) - (: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 -;; - -(defun node-binding (node i) - (let ((index (btree-node-index node))) - (p-aref index i))) - -(defun (setf node-binding) (binding node i) - (setf (p-aref (btree-node-index node) i) - binding)) - - -(defun make-binding (key value) - (p-cons key value)) - -(defun binding-key (binding) - (p-car binding)) - -(defun (setf binding-key) (key binding) - (setf (p-car binding) key)) - -(defun (setf binding-value) (value binding) - (setf (p-cdr binding) value)) - -(defun binding-value (binding) - (p-cdr binding)) - - -(defun make-leaf-value (btree value) - (if (btree-unique-keys-p btree) - value - (p-cons value '()))) - -;; -;; - -(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) - (btree-node-index-count node) 0)) - - -(defmethod print-object ((node btree-node) stream) - (print-unreadable-object (node stream :type t :identity t) - (format stream "with ~D bindings" (btree-node-index-count node)))) - -;; -;; Debugging -;; - -(defun display-node (node) [1751 lines skipped] --- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/30 14:05:40 1.10 +++ /project/rucksack/cvsroot/rucksack/package.lisp 2007/01/20 18:17:55 1.11 @@ -1,111 +1,111 @@ -;; $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)) - -(defpackage :rucksack - (:nicknames :rs) - - (:use :queue :cl - #+allegro :mop - #+lispworks :clos - #+sbcl :sb-mop - #+openmcl :openmcl-mop) - - (:export - - ;; Cache - #:cache #:standard-cache - #:open-cache #:close-cache #:with-cache - #:cache-size #:cache-count - #:cache-create-object #:cache-get-object #:cache-touch-object - #:cache-commit #:cache-rollback #:cache-recover - #:open-transaction #:close-transaction #:map-transactions - - ;; MOP related - #:persistent-class - #:update-persistent-instance-for-redefined-class - - ;; Objects - #:persistent-object - #:persistent-data #:persistent-array #:persistent-cons - #:object-id - #: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-delete-if #:p-position - - ;; Heaps - #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap - #:open-heap #:close-heap - #:heap-stream #:heap-end - - ;; Rucksacks - #:*rucksack* - #:open-rucksack #:close-rucksack #:with-rucksack #:current-rucksack - #:rucksack #:standard-rucksack - #:rucksack-cache - #:rucksack-directory - #:rucksack-commit #:rucksack-rollback - #:add-rucksack-root #:map-rucksack-roots #:rucksack-roots - #:commit #:rollback - - ;; Class and slot indexing - #:add-class-index #:add-slot-index - #:remove-class-index #:remove-slot-index - #:map-class-indexes #:map-slot-indexes - #:rucksack-add-class-index #:rucksack-add-slot-index - #:rucksack-make-class-index - #:rucksack-remove-class-index #:rucksack-remove-slot-index - #:rucksack-class-index #:rucksack-slot-index - #:rucksack-map-class-indexes #:rucksack-map-slot-indexes - #:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object - #:rucksack-map-class #:rucksack-map-slot - - ;; Transactions - #:current-transaction - #:transaction-start #:transaction-commit #:transaction-rollback - #:with-transaction #:*transaction* - #:transaction #:standard-transaction - #:transaction-start-1 #:transaction-commit-1 - #:transaction-id - - ;; 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 - #:define-index-spec #:find-index-spec - - ;; Btrees - #:btree - #: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 - #:btree-nr-keys #:btree-nr-values - ;; Functions - #: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 - #:btree-error-btree #:btree-error-key #:btree-error-value -)) - - - -(defpackage :rucksack-test - (:nicknames :rs-test) - (:use :common-lisp :rucksack)) - -(defpackage :rucksack-test-schema-update - (:nicknames :rs-tsu) +;; $Id: package.lisp,v 1.11 2007/01/20 18:17:55 alemmens Exp $ + +#-(or allegro lispworks sbcl openmcl) + (error "Unsupported implementation: ~A" (lisp-implementation-type)) + +(defpackage :rucksack + (:nicknames :rs) + + (:use :queue :cl + #+allegro :mop + #+lispworks :clos + #+sbcl :sb-mop + #+openmcl :openmcl-mop) + + (:export + + ;; Cache + #:cache #:standard-cache + #:open-cache #:close-cache #:with-cache + #:cache-size #:cache-count + #:cache-create-object #:cache-get-object #:cache-touch-object + #:cache-commit #:cache-rollback #:cache-recover + #:open-transaction #:close-transaction #:map-transactions + + ;; MOP related + #:persistent-class + #:update-persistent-instance-for-redefined-class + + ;; Objects + #:persistent-object + #:persistent-data #:persistent-array #:persistent-cons + #:object-id + #: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-delete-if #:p-position + + ;; Heaps + #:heap #:free-list-heap #:mark-and-sweep-heap #:simple-free-list-heap + #:open-heap #:close-heap + #:heap-stream #:heap-end + + ;; Rucksacks + #:*rucksack* + #:open-rucksack #:close-rucksack #:with-rucksack #:current-rucksack + #:rucksack #:standard-rucksack + #:rucksack-cache + #:rucksack-directory + #:rucksack-commit #:rucksack-rollback + #:add-rucksack-root #:map-rucksack-roots #:rucksack-roots + #:commit #:rollback + + ;; Class and slot indexing + #:add-class-index #:add-slot-index + #:remove-class-index #:remove-slot-index + #:map-class-indexes #:map-slot-indexes + #:rucksack-add-class-index #:rucksack-add-slot-index + #:rucksack-make-class-index + #:rucksack-remove-class-index #:rucksack-remove-slot-index + #:rucksack-class-index #:rucksack-slot-index + #:rucksack-map-class-indexes #:rucksack-map-slot-indexes + #:rucksack-maybe-index-changed-slot #:rucksack-maybe-index-new-object + #:rucksack-map-class #:rucksack-map-slot + + ;; Transactions + #:current-transaction + #:transaction-start #:transaction-commit #:transaction-rollback + #:with-transaction #:*transaction* + #:transaction #:standard-transaction + #:transaction-start-1 #:transaction-commit-1 + #:transaction-id + + ;; 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 + #:define-index-spec #:find-index-spec + + ;; Btrees + #:btree + #: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 + #:btree-nr-keys #:btree-nr-values + ;; Functions + #: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 + #:btree-error-btree #:btree-error-key #:btree-error-value +)) + + + +(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/queue.lisp 2006/05/18 22:09:40 1.3 +++ /project/rucksack/cvsroot/rucksack/queue.lisp 2007/01/20 18:17:55 1.4 @@ -1,157 +1,157 @@ -;; $Id: queue.lisp,v 1.3 2006/05/18 22:09:40 alemmens Exp $ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Queues -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| -Usage: - -- Create a queue with (make-instance 'queue) - -- The rest should be obvious. -|# - -(defpackage :queue - (:use :common-lisp) - (:export - #:queue - #:queue-size - #:queue-add #:queue-add-at-front - #:queue-empty-p #:queue-peek - #:queue-remove #:queue-clear - #:empty-queue-error)) - -(in-package :queue) - -;;; -;;; QUEUE -;;; - -(defclass queue () - ((end :initform nil) - (contents :initform '()) - (size :initform 0 :reader queue-size))) - -(define-condition empty-queue-error (error) - ((queue :initarg :queue)) - (:report (lambda (error stream) - (with-slots (queue) - error - (format stream "Queue ~A is empty." queue))))) - - -(defmethod print-object ((queue queue) stream) - (print-unreadable-object (queue stream :type t :identity t) - (format stream "of size ~D" (queue-size queue)))) - - -(defun queue-add (queue object) - "Adds an object to the end of the queue." - (with-slots (end contents size) - queue - (cond ((null end) - (setf contents (list object)) - (setf end contents)) - (t - (setf (cdr end) (list object)) - (setf end (cdr end)))) - (incf size)) - queue) - -(defun queue-add-at-front (queue object) - (with-slots (end contents size) - queue - (cond ((null end) - (setf contents (list object)) - (setf end contents)) - (t (push object contents))) - (incf size)) - queue) - -(defun queue-remove (queue &key errorp) - "Returns the first (i.e. least recently added) element of the queue. -If the queue is empty, it returns nil (when :ERRORP is nil) or signals -an empty-queue-error (when :ERRORP is true)." - (with-slots (end contents size) - queue - (if (null contents) - (and errorp - (error 'empty-queue-error :queue queue)) - (prog1 - (pop contents) - (when (null contents) - (setq end nil)) - (decf size))))) - - -(defun queue-empty-p (queue) - "Returns true if the queue is empty, otherwise nil." - (with-slots (contents) - queue - (null contents))) - -(defun queue-peek (queue &optional (type 't)) - "Returns the first object in the queue that has the given type (and removes -all objects from the queue before it). Returns NIL (and clears the entire queue) -if there is no such object." - (with-slots (contents size end) - queue - (loop while (and contents - (not (typep (first contents) type))) - do (decf size) - (pop contents)) - (when (null contents) - (setq end nil)) - (first contents))) - - -(defun queue-clear (queue) - "Removes all elements from the queue (and returns the empty queue)." - (with-slots (end contents size) - queue - (setf end nil - contents '() - size 0)) - queue) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Sample session -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| - -QUEUE> (setq *q* (make-instance 'queue)) -# -QUEUE> (queue-add *q* "Hi") -# -QUEUE> (queue-peek *q*) -"Hi" -QUEUE> (queue-add *q* 123) -# -QUEUE> (queue-size *q*) -2 -QUEUE> (queue-peek *q*) -"Hi" -QUEUE> (queue-remove *q*) -"Hi" -QUEUE> (queue-remove *q*) -123 -QUEUE> (queue-remove *q*) -NIL -QUEUE> (queue-remove *q* :errorp t) -; Evaluation aborted -QUEUE> (queue-add *q* "Hi") -# -QUEUE> (queue-add *q* 123) -# -QUEUE> (queue-peek *q* 'integer) -123 -QUEUE> (queue-size *q*) -1 -QUEUE> (queue-add-at-front *q* "hi") -# -QUEUE> (queue-peek *q*) -"hi" - -|# +;; $Id: queue.lisp,v 1.4 2007/01/20 18:17:55 alemmens Exp $ + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Queues +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| +Usage: + +- Create a queue with (make-instance 'queue) + +- The rest should be obvious. +|# + +(defpackage :queue + (:use :common-lisp) + (:export + #:queue + #:queue-size + #:queue-add #:queue-add-at-front + #:queue-empty-p #:queue-peek + #:queue-remove #:queue-clear + #:empty-queue-error)) + +(in-package :queue) + +;;; +;;; QUEUE +;;; + +(defclass queue () + ((end :initform nil) + (contents :initform '()) + (size :initform 0 :reader queue-size))) + +(define-condition empty-queue-error (error) + ((queue :initarg :queue)) + (:report (lambda (error stream) + (with-slots (queue) + error + (format stream "Queue ~A is empty." queue))))) + + +(defmethod print-object ((queue queue) stream) + (print-unreadable-object (queue stream :type t :identity t) + (format stream "of size ~D" (queue-size queue)))) + + +(defun queue-add (queue object) + "Adds an object to the end of the queue." + (with-slots (end contents size) + queue + (cond ((null end) + (setf contents (list object)) + (setf end contents)) + (t + (setf (cdr end) (list object)) + (setf end (cdr end)))) + (incf size)) + queue) + +(defun queue-add-at-front (queue object) + (with-slots (end contents size) + queue + (cond ((null end) + (setf contents (list object)) + (setf end contents)) + (t (push object contents))) + (incf size)) + queue) + +(defun queue-remove (queue &key errorp) + "Returns the first (i.e. least recently added) element of the queue. +If the queue is empty, it returns nil (when :ERRORP is nil) or signals +an empty-queue-error (when :ERRORP is true)." + (with-slots (end contents size) + queue + (if (null contents) + (and errorp + (error 'empty-queue-error :queue queue)) + (prog1 + (pop contents) + (when (null contents) + (setq end nil)) + (decf size))))) + + +(defun queue-empty-p (queue) + "Returns true if the queue is empty, otherwise nil." + (with-slots (contents) + queue + (null contents))) + +(defun queue-peek (queue &optional (type 't)) + "Returns the first object in the queue that has the given type (and removes +all objects from the queue before it). Returns NIL (and clears the entire queue) +if there is no such object." + (with-slots (contents size end) + queue + (loop while (and contents + (not (typep (first contents) type))) + do (decf size) + (pop contents)) + (when (null contents) + (setq end nil)) + (first contents))) + + +(defun queue-clear (queue) + "Removes all elements from the queue (and returns the empty queue)." + (with-slots (end contents size) + queue + (setf end nil + contents '() + size 0)) + queue) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Sample session +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +#| + +QUEUE> (setq *q* (make-instance 'queue)) +# +QUEUE> (queue-add *q* "Hi") +# +QUEUE> (queue-peek *q*) +"Hi" +QUEUE> (queue-add *q* 123) +# +QUEUE> (queue-size *q*) +2 +QUEUE> (queue-peek *q*) +"Hi" +QUEUE> (queue-remove *q*) +"Hi" +QUEUE> (queue-remove *q*) +123 +QUEUE> (queue-remove *q*) +NIL +QUEUE> (queue-remove *q* :errorp t) +; Evaluation aborted +QUEUE> (queue-add *q* "Hi") +# +QUEUE> (queue-add *q* 123) +# +QUEUE> (queue-peek *q* 'integer) +123 +QUEUE> (queue-size *q*) +1 +QUEUE> (queue-add-at-front *q* "hi") +# +QUEUE> (queue-peek *q*) +"hi" + +|# --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/16 08:57:43 1.6 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/20 18:17:55 1.7 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.6 2007/01/16 08:57:43 charmon Exp $ +;;; $Id: rucksack.asd,v 1.7 2007/01/20 18:17:55 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.4" + :version "0.1.5" :serial t :components ((:file "queue") (:file "package") --- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/01/16 08:57:43 1.18 +++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2007/01/20 18:17:55 1.19 @@ -1,964 +1,964 @@ -;; $Id: rucksack.lisp,v 1.18 2007/01/16 08:57:43 charmon Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Rucksacks: API -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; open-rucksack [Function] -;; close-rucksack [Function] -;; with-rucksack [Macro] -;; current-rucksack [Function] - -;; commit [Function] -;; rollback [Function] - -(defgeneric add-rucksack-root (object rucksack) - (:documentation - "Adds an object to the root set of a rucksack.")) - -(defgeneric delete-rucksack-root (object rucksack) - (:documentation - "Delete an object from the root set of a rucksack.")) - -(defgeneric map-rucksack-roots (function rucksack) - (:documentation - "Applies a function to all objects in the root set of a rucksack.")) - -(defgeneric rucksack-roots (rucksack) - (:documentation - "Returns a list with all objects in the root set of a rucksack. You -shouldn't modify this list.")) - -(defgeneric rucksack-cache (rucksack) - (:documentation "Returns the cache for a rucksack.")) - -(defgeneric rucksack-directory (rucksack) - (:documentation - "Returns a pathname for the directory that contains all files of a -rucksack.")) - -(defgeneric rucksack-commit (rucksack) - (:documentation - "Ensures that all in-memory data is saved to disk.")) - -(defgeneric rucksack-rollback (rucksack) - ;; DO: What does rollback mean exactly here? - (:documentation "....")) - -;; -;; Class and slot indexing -;; - -;; add-class-index (class-designator &key errorp) [Function] -;; add-slot-index (class-designator slot index-spec &key errorp) [Function] -;; remove-class-index (class-designator &key errorp) [Function] -;; remove-slot-index (class-designator slot &key errorp) [Function] -;; map-class-indexes (function) [Function] -;; map-slot-indexes (function &key class include-subclasses) [Function] - - -(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 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) - (: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.")) - -(defgeneric rucksack-add-class-index (rucksack class-designator &key errorp)) - -(defgeneric rucksack-remove-class-index (rucksack class-designator - &key errorp)) - -(defgeneric rucksack-class-index (rucksack class-designator &key errorp) - (:documentation "Returns the class index for a class designator.")) - -(defgeneric rucksack-map-class-indexes (rucksack function) - (:documentation - "FUNCTION must take two arguments: a class name and a class index. -It is called for all class indexes in the specified rucksack.")) - -(defgeneric rucksack-make-class-index (rucksack class &key index-spec) - (:documentation - "Creates a new class index and returns that index. INDEX-SPEC -specifies the kind of index that must be created (if not supplied, the -rucksack's default class index spec will be used.")) - - -(defgeneric rucksack-add-slot-index (rucksack class-designator slot index-spec - 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 already is an index for the designated slot.")) - -(defgeneric rucksack-remove-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.")) - - -(defgeneric rucksack-map-slot-indexes (rucksack function - &key class include-subclasses) - (:documentation - "FUNCTION must take three arguments: a class name, a slot name and -a slot index. It is called for all slot indexes in the specified -rucksack. - CLASS defaults to T, meaning all classes. - INCLUDE-SUBCLASSES defaults to T.")) - -(defgeneric rucksack-maybe-index-changed-slot (rucksack - class object slot - old-value new-value - old-boundp new-boundp) - (:documentation - "This function is called after a slot has changed. OLD-VALUE is the -slot's value before the change, NEW-VALUE is the current value. -OLD-BOUNDP is true iff the slot was bound before the change, -NEW-BOUNDP is true iff the slot is currently bound.")) - -(defgeneric rucksack-maybe-index-new-object (rucksack class-designator object) - (:documentation - "Adds the object id of OBJECT to the class index for the class -designated by CLASS-DESIGNATOR. If there is no such class index, it -does nothing.")) - -(defgeneric rucksack-map-class (rucksack class function - &key id-only include-subclasses) - (:documentation - " FUNCTION is a unary function that gets called for all instances of -the specified class. Unindexed classes (i.e. classes for which the -:indexed class option is nil) will be skipped. - 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. - INCLUDE-SUBCLASSES defaults to T.")) - -(defgeneric rucksack-map-slot (rucksack class slot function - &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 -the specified class that have a slot value matching the EQUAL, MIN, -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. - INCLUDE-SUBCLASSES defaults to T.")) - - -#+later -(defgeneric rucksack-map-objects (rucksack class-designator function - slots filter order) - (:documentation - " Applies FUNCTION to all instances of the class designated by -CLASS-DESIGNATOR for which the criteria specified by SLOTS and -CRITERIA hold. - SLOTS is a list of slot names. FILTER is a filter expression that can -refer to the slot names. - Example of a filter expression: (and (= age 20) (string= city \"Hamburg\")) -")) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Locks -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun make-lock (&key (name "lock")) - #+allegro - (mp:make-process-lock :name name) - #+lispworks - (mp:make-lock :name name) - #+sbcl - (sb-thread:make-mutex :name name) - #+openmcl - (ccl:make-lock name) - #-(or allegro lispworks sbcl openmcl) - (not-implemented 'make-lock)) - - -(defmacro with-lock ((lock) &body body) - #+allegro - `(mp:with-process-lock (,lock) , at body) - #+lispworks - `(mp:with-lock (,lock) , at body) - #+sbcl - `(sb-thread:with-mutex (,lock) , at body) - #+openmcl - `(ccl:with-lock-grabbed (,lock) , at body) - #-(or allegro lispworks sbcl openmcl) - (not-implemented 'with-lock)) - -(defun process-lock (lock) - #+lispworks - (mp:process-lock lock) - #+sbcl - (sb-thread:get-mutex lock) - #-(or sbcl lispworks) - (not-implemented 'process-lock)) - - -(defun process-unlock (lock) - #+lispworks - (mp:process-unlock lock) - #+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)) - (inhibit-gc nil inhibit-gc-supplied-p) - &allow-other-keys) - &body body) - (let ((committed (gensym "COMMITTED")) - (transaction (gensym "TRANSACTION")) - (result (gensym "RESULT"))) - `(let ((,transaction nil) - (*collect-garbage-on-commit* (if ,inhibit-gc-supplied-p - ,(not inhibit-gc) - *collect-garbage-on-commit*))) - (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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -(defclass rucksack () - ()) - -(defclass standard-rucksack (rucksack) - ((cache :reader rucksack-cache) - (directory :initarg :directory :reader rucksack-directory) - (roots :initform '() - :documentation - "A list with the object ids of all root objects, i.e. the objects -from which the garbage collector can reach all live objects.") - (roots-changed-p :initform nil :accessor roots-changed-p) - ;; Indexes - (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) - (print-unreadable-object (rucksack stream :type t :identity t) - (format stream "in ~S with ~D root~:P" - (rucksack-directory rucksack) - (length (slot-value rucksack 'roots))))) - -(defmethod rucksack-roots-pathname ((rucksack standard-rucksack)) - (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 - :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) - (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 - :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)))) - (if (current-transaction) - (do-it) - (with-transaction (:rucksack rucksack) - (do-it))))) - - -(defmethod initialize-instance :after ((rucksack standard-rucksack) - &key - (cache-class 'standard-cache) - (cache-args '()) - &allow-other-keys) - ;; Open cache. - (setf (slot-value rucksack 'cache) - (apply #'open-cache (rucksack-directory rucksack) - :class cache-class - :rucksack rucksack - cache-args)) - (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. - (let ((roots-file (rucksack-roots-pathname rucksack))) - (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) - rucksack - (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) - (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)) - -(defun save-roots-if-necessary (rucksack) - (when (roots-changed-p rucksack) - (save-roots rucksack))) [1531 lines skipped] --- /project/rucksack/cvsroot/rucksack/schema-table.lisp 2006/08/30 14:05:40 1.6 +++ /project/rucksack/cvsroot/rucksack/schema-table.lisp 2007/01/20 18:17:55 1.7 @@ -1,215 +1,215 @@ -;; $Id: schema-table.lisp,v 1.6 2006/08/30 14:05: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 - :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 - :documentation "The combination of class-name and version number -also uniquely identifies a schema.") - (obsolete-p :initform nil :accessor schema-obsolete-p) - ;; Slot info (computed during FINALIZE-INHERITANCE). - (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."))) - -(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) - (by-name :initform (make-hash-table) - :documentation "A mapping from class names to a list (most -recent version first) of schemas." - :reader schema-table-by-name) - (by-id :initform (make-hash-table) - :documentation "A mapping from a schema id to a schema." - :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 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 - ;; 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 (class-of object))) - (or (find-schema-for-class table class) - ;; There is no schema yet. Create it. - (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))) - (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))) - - -(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) '())) - (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) - (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. - (if (probe-file pathname) - (ecase if-exists - (:error (error "Schema table file ~S already exists." pathname)) - (:supersede - ;; Create an empty schema table, save it and return it. - (let ((table (make-instance 'schema-table :pathname pathname))) - (save-schema-table table) - table)) - (:overwrite - ;; Normal case - (let ((table (first (load-objects pathname)))) - (when (not (equal pathname (schema-table-pathname table))) - ;; The table was moved; update the pathname info. - (setf (schema-table-pathname table) pathname) - (save-schema-table table)) - table))) - (ecase if-does-not-exist - (:error (error "Schema table file ~S does not exist." pathname)) - (:create - ;; Create an empty schema table, save it and return it. - (let ((table (make-instance 'schema-table :pathname pathname))) - (save-schema-table table) - table))))) - - -(defun close-schema-table (table &key (commit t)) - (when (and commit (dirty-p table)) - (save-schema-table table))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Schema updates -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(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 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 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)))))))) +;; $Id: schema-table.lisp,v 1.7 2007/01/20 18:17:55 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 + :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 + :documentation "The combination of class-name and version number +also uniquely identifies a schema.") + (obsolete-p :initform nil :accessor schema-obsolete-p) + ;; Slot info (computed during FINALIZE-INHERITANCE). + (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."))) + +(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) + (by-name :initform (make-hash-table) + :documentation "A mapping from class names to a list (most +recent version first) of schemas." + :reader schema-table-by-name) + (by-id :initform (make-hash-table) + :documentation "A mapping from a schema id to a schema." + :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 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 + ;; 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 (class-of object))) + (or (find-schema-for-class table class) + ;; There is no schema yet. Create it. + (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))) + (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))) + + +(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) '())) + (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) + (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. + (if (probe-file pathname) + (ecase if-exists + (:error (error "Schema table file ~S already exists." pathname)) + (:supersede + ;; Create an empty schema table, save it and return it. + (let ((table (make-instance 'schema-table :pathname pathname))) + (save-schema-table table) + table)) + (:overwrite + ;; Normal case + (let ((table (first (load-objects pathname)))) + (when (not (equal pathname (schema-table-pathname table))) + ;; The table was moved; update the pathname info. + (setf (schema-table-pathname table) pathname) + (save-schema-table table)) + table))) + (ecase if-does-not-exist + (:error (error "Schema table file ~S does not exist." pathname)) + (:create + ;; Create an empty schema table, save it and return it. + (let ((table (make-instance 'schema-table :pathname pathname))) + (save-schema-table table) [33 lines skipped] --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/29 11:41:40 1.8 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2007/01/20 18:17:55 1.9 @@ -1,1312 +1,1312 @@ -;; $Id: serialize.lisp,v 1.8 2006/08/29 11:41:40 alemmens Exp $ - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Serialize -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -#| -This is a modified version of my stand-alone serialization library. -The most important modification is that we don't keep track of any -shared objects (like CLOS objects, symbols, struct classes) anymore. -That's supposed to be handled by the database library on top of this. - -This file also contains the garbage collection code for scanning objects, -because that's very similar to deserializing them. - -What do we do when we serialize an object and it turns out to contain -other objects? There are a few options: -1. Don't allow it: this should be dealt with at a higher level -2. Automatically add the child object to the cache: that means it - will be saved and we'll get an object-id for the child. But what if - the child was already in the cache? We have no way of knowing that - and we'll probably create a mess. -3. Just serialize the contents. This basically assumes that this is the - only reference to this objects; or, if it isn't, that it doesn't matter - if we create more than one copy of this object when we deserialize - it (and that object identity is irrelevant). -I think I'll go for option 3. -|# - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgeneric save-slots (object serializer)) -(defgeneric load-slots (object serializer)) - -(defmethod saved-slots (object) - ;; Default: use the MOP to return a list of the names all effective slots. - (mapcar #'slot-definition-name - #+lispworks(clos:class-effective-slots (class-of object)) - #-lispworks(class-slots (class-of object)))) - - -(defun save-objects (objects pathname) - "Saves a list with objects to a file, creating the file if necessary. -If the file exists, it will be superseded." - (ensure-directories-exist pathname) - (with-open-file (stream pathname - :element-type '(unsigned-byte 8) - :direction :output - :if-exists :supersede - :if-does-not-exist :create) - (let ((serializer (make-instance 'serializer :stream stream))) - (serialize-list objects serializer)))) - -(defun load-objects (pathname) - "Returns a list of objects from a file created by SAVE-OBJECTS." - (with-open-file (stream pathname - :element-type '(unsigned-byte 8) - :direction :input) - (let ((serializer (make-instance 'serializer :stream stream))) - (deserialize-list serializer)))) - - -(defun open-serializer (stream) - "Creates and returns a serializer for a stream. The stream must have -element-type (UNSIGNED-BYTE 8))." - (make-instance 'serializer :stream stream)) - -(defun close-serializer (serializer &key abort) - (close (serializer-stream serializer) :abort abort)) - -(defun force-serializer-output (serializer) - (force-output (serializer-stream serializer))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Markers -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defconstant +illegal-marker+ 0 - "This should never be read as a marker.") - -(defconstant +ignore+ 1 - "This marker is automatically skipped when read. Handy if you need -fixed width fields.") - -;; Booleans - -(defconstant +nil+ 2) -(defconstant +t+ 3) - -;; Integers - -(defconstant +minus-one+ #x09) -(defconstant +zero+ #x0A) -(defconstant +one+ #x0B) -(defconstant +two+ #x0C) - - -(defconstant +positive-byte-8+ #x10) -(defconstant +negative-byte-8+ #x11) -(defconstant +positive-byte-16+ #x12) -(defconstant +negative-byte-16+ #x13) -(defconstant +positive-byte-24+ #x14) -(defconstant +negative-byte-24+ #x15) -(defconstant +positive-byte-32+ #x16) -(defconstant +negative-byte-32+ #x17) -(defconstant +positive-byte-48+ #x18) -(defconstant +negative-byte-48+ #x19) -(defconstant +positive-byte-64+ #x1A) -(defconstant +negative-byte-64+ #x1B) -(defconstant +positive-integer+ #x1C) -(defconstant +negative-integer+ #x1D) - - -;; Other numbers - -(defconstant +rational+ #x20) -(defconstant +float+ #x21) -(defconstant +short-float+ #x22) -(defconstant +single-float+ #x23) -(defconstant +double-float+ #x24) -(defconstant +long-float+ #x25) -(defconstant +complex+ #x26) - -;; Strings and characters - -(defconstant +character+ #x30) ; also used as element-type marker for strings -(defconstant +character-8+ #x31) -(defconstant +character-16+ #x32) -(defconstant +character-24+ #x33) -(defconstant +character-32+ #x34) - -(defconstant +base-char+ #x35) ; used as element-type marker for strings -(defconstant +extended-char+ #x36) ; used as element-type marker for strings - -(defconstant +string+ #x40) -(defconstant +string-8+ #x41) -(defconstant +string-16+ #x42) -(defconstant +string-24+ #x43) -(defconstant +string-32+ #x44) -(defconstant +simple-string+ #x45) -(defconstant +simple-string-8+ #x46) -(defconstant +simple-string-16+ #x47) -(defconstant +simple-string-24+ #x48) -(defconstant +simple-string-32+ #x49) - -;; Symbols and packages - -(defconstant +symbol+ #x50) -(defconstant +keyword+ #x51) -(defconstant +uninterned-symbol+ #x52) -(defconstant +symbol-reference+ #x53) -(defconstant +package+ #x54) - - -;; Lists, conses, structures - -(defconstant +cons+ #x60) -(defconstant +proper-list+ #x61) -(defconstant +struct+ #x62) -(defconstant +struct-definition+ #x63) -(defconstant +dotted-list+ #x64) - -;; Objects and slots - -(defconstant +object+ #x70) -(defconstant +unbound-slot+ #x71) -(defconstant +shared-object-definition+ #x72) -(defconstant +shared-object-reference+ #x73) - -;; Rest - -(defconstant +hash-table+ #x80) -(defconstant +pathname+ #x90) -(defconstant +array+ #xA0) - -;; Garbage collector marks -(defconstant +free-block+ #xB0) -(defconstant +live-object+ #xB1) -(defconstant +dead-object+ #xB2) -(defconstant +reserved-object+ #xB3 - "Used for entries in the object table that belong to objects that haven't -been committed to disk yet.") - -(defconstant +extension-0+ #xC0) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Serializer -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass serializer () - ((stream :initarg :stream :reader serializer-stream - :documentation "An (unsigned-byte 8) stream."))) - -(defgeneric serialize-byte (byte serializer) - (:documentation "Writes an unsigned-byte to a serializer.") - (:method ((byte integer) (serializer serializer)) - (write-byte byte (serializer-stream serializer))) - (:method ((byte integer) (stream stream)) - (write-byte byte stream))) - -(defgeneric deserialize-byte (serializer &optional eof-error-p) - (:documentation "Reads an unsigned-byte from a serializer. EOF-ERROR-P -defaults to T.") - (:method ((serializer serializer) &optional (eof-error-p t)) - (read-byte (serializer-stream serializer) eof-error-p nil)) - (: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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defgeneric serialize (object serializer) - (:documentation "Writes a serialized version of an object to the -stream in a serializer.")) - -(defgeneric scan-contents (marker serializer garbage-collector)) - -(defmethod scan-contents (marker serializer gc) - ;; Default: just deserialize the contents but don't evacuate anything. - (declare (ignore gc)) - (deserialize-contents marker serializer)) - - -(defun serialize-marker (marker serializer) - (serialize-byte marker serializer)) - -(defun read-next-marker (serializer) - "Returns the next marker (or NIL if we're at the end of the -serializer stream)." - (loop (let ((marker (deserialize-byte serializer nil))) - (if (null marker) - (return nil) - (unless (eql marker +ignore+) - (return marker)))))) - - -(defun deserialize (serializer &optional (eof-error-p t) (eof-value nil)) - "Reads the next object from the serializer stream. Signals an end-of-file -error or returns EOF-VALUE when the end of the stream is reached." - (let ((marker (read-next-marker serializer))) - (if marker - (deserialize-contents marker serializer) - ;; End of file - (if eof-error-p - (error 'end-of-file :stream serializer) - eof-value)))) - -(defun serialize-list (list stream &optional (length (length list))) - "Serializes a proper list by first serializing its length and then all the -elements of the list." - (serialize length stream) - (dolist (elt list) - (serialize elt stream))) - -(defun deserialize-list (stream) - (let ((length (deserialize stream))) - (loop repeat length - collect (deserialize stream)))) - - -(defun serialize-dotted-list (list stream &optional (length (length list))) - "Serializes a dotted list by first serializing its length and then all the -elements of the list." - (serialize length stream) - (loop for elt on list do - (serialize (car elt) stream) - (when (atom (cdr elt)) - ;; The last element - (serialize (cdr elt) stream)))) - -(defun deserialize-dotted-list (stream) - "Serializes a dotted list by first serializing its length and then all the -elements of the list." - ;; EFFICIENCY: This walks the list one more time to add the final element. - ;; That should be optimized. - (let* ((length (deserialize stream)) - (list (loop repeat (1- length) - collect (deserialize stream))) - (final-elt (deserialize stream))) - (setf (cdr (last list)) final-elt) - list)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Illegal marker -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod deserialize-contents ((marker (eql +illegal-marker+)) stream) - (cerror "Ignore the marker and continue." - "There's an illegal marker in stream ~A." - stream)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Booleans -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defmethod serialize ((object (eql nil)) stream) - (serialize-marker +nil+ stream)) - -(defmethod serialize ((object (eql t)) stream) - (serialize-marker +t+ stream)) - -(defmethod deserialize-contents ((marker (eql +nil+)) stream) - (declare (ignore stream)) - nil) - -(defmethod deserialize-contents ((marker (eql +t+)) stream) - (declare (ignore stream)) - t) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; 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)) - -(defun serialize-byte-24 (integer stream) - (serialize-byte (ldb (byte 8 0) integer) stream) - (serialize-byte (ldb (byte 8 8) integer) stream) - (serialize-byte (ldb (byte 8 16) integer) stream)) - -(defun serialize-byte-32 (integer stream) - (serialize-byte (ldb (byte 8 0) integer) stream) - (serialize-byte (ldb (byte 8 8) integer) stream) - (serialize-byte (ldb (byte 8 16) integer) stream) - (serialize-byte (ldb (byte 8 24) integer) stream)) - -(defun serialize-byte-48 (integer stream) - (multiple-value-bind (most-significant least-significant) - (floor integer #x1000000) - (serialize-byte-24 least-significant stream) - (serialize-byte-24 most-significant stream))) - -(defun serialize-byte-64 (integer stream) - (multiple-value-bind (most-significant least-significant) - (floor integer #x100000000) - (serialize-byte-32 least-significant stream) - (serialize-byte-32 most-significant stream))) - - -;; -;; Deserializing multiple bytes -;; - -(defun deserialize-byte-16 (stream) - (+ (deserialize-byte stream) - (* (deserialize-byte stream) 256))) - -(defun deserialize-byte-24 (stream) - (+ (deserialize-byte stream) - (* (deserialize-byte stream) #x100) - (* (deserialize-byte stream) #x10000))) - -(defun deserialize-byte-32 (stream) - (+ (deserialize-byte stream) - (* (deserialize-byte stream) #x100) - (* (deserialize-byte stream) #x10000) - (* (deserialize-byte stream) #x1000000))) - -(defun deserialize-byte-48 (stream) - (+ (deserialize-byte-24 stream) - (* (deserialize-byte-24 stream) #x1000000))) - -(defun deserialize-byte-64 (stream) - (+ (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) [2227 lines skipped] --- /project/rucksack/cvsroot/rucksack/talk-eclm2006.txt 2006/05/16 21:16:35 1.1 +++ /project/rucksack/cvsroot/rucksack/talk-eclm2006.txt 2007/01/20 18:17:55 1.2 @@ -1,1191 +1,1191 @@ -* Rucksack: a flexible, light weight, open source persistence library - -* Arthur Lemmens, alemmens at xs4all.nl, 2006-04-30 -* (talk given at the ECLM 2006 in Hamburg) - -1. Introduction -2. Serialization -3. Object table/cache -4. Garbage collection -5. Transactions -6. Recovery -7. Indexing -8. Schemas -9. Questions - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -1. Introduction - -* EXPERTISE - -Maybe I should start by saying that I don't consider myself an expert -on any of the subjects that I'm going to talk about today (except -maybe Lisp programming). But I've been wanting a Lisp persistence -library for years, and nobody else was writing it for me (or, if they -were writing them, they lacked features that I considered essential). -So I finally decided to ignore the fact that I didn't know anything -about things like database implementation, transactions or garbage -collectors and just do it. - -So here we are... - - -* FEATURES - -Rucksack is a persistence library for Common Lisp. It's a bit similar -to systems like AllegroCache or PLOB, but it's also different in some -important respects. Here are some of its features: - -PICTURE - - Common Lisp only - - 99% portable - - persistent conses, vectors, CLOS objects, ... - - object cache - - parallel transactions - - incremental garbage collector - - schema evolution - - use MOP to automatically deal with slot changes - - btree indexing for class instances and slot values - - flexible architecture - - not finished -END - - - it's all written in Common Lisp - - it's almost all portable, except for process locks and some MOP magic - (I write and test it with Lispworks) - - it tries to provide persistent equivalents of Lisp's classical - data structures, including persistent conses, persistent vectors - and persistent CLOS instances. - - it has an object based cache; changes to persistent objects are - written to disk (serialized) during a transaction-commit - - it supports parallel transactions - - it has an incremental garbage collector - - it support schema evolution, in the sense that it can deal with - changes to persistent class definitions in a way that's similar - to what CL provides with update-instance-for-redefined-class - - it uses the MOP to automatically deal with slot changes - - it provides indexing for instances and slot values - Btrees are included, user defined indexes are also possible. - - I try hard to keep it flexible and readable, so it should be - relatively easy to adapt to your own needs. - - it's not finished yet - I've written code for almost everything mentioned above, but there - are still quite a few loose ends and it needs some heavy testing. - - -* THIS TALK - -PICTURE - - - serialization - How do I get it on disk? - - object ids - How do I know where I put it? - - cache - D?j? vu. - - garbage collection - How do I get rid of this mess? - - parallel transactions - Have my cake and eat it too. - - failure recovery - What if somebody pulls the plug? - - automatic slot and class indexing - How do I find it back? - - schema evolution - What if my class definition changes? - -END - -I'm going to present Rucksack in about the same order as I developed -it. This means we'll start at the bottom, with things like -serialization, object ids, cacheing and garbage collection. Then -we'll move on to headache stuff like parallel transactions, recovering -from failure, using the MOP for automatic slot and class indexing, and -schema evolution. - -* THE JUNGLE - -Writing a persistence library is like hacking your way through a -jungle. At each point there are difficult decisions to make, and -making the best decision is almost impossible. In fact, what's best -will often depend on the application. - -Garbage collection is a nice example. One week I thought I should -write a mark-and-sweep collector, the next week I thought that a -copying collector would be better. Or maybe some kind of mixture? I -ended up writing half a copying collector, then changed my mind and -wrote a mark and sweep collector. Now I'm having doubts again. - -But this is nothing new for most Common Lisp programmers. We're used -to the fact that there is no single best programming paradigm, no -single best answer. Instead, Common Lisp provides a flexible -programming framework that you can adapt to the problem at hand. I -try to do the same for Rucksack. - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -2. Objects on disk: serialization - -* INTRO - -The serializer is the low level layer that takes care of writing -objects to disk and reading them back again. - -* SHARED OBJECTS - -One of the things that can complicate serialization is that the -serializer must deal with shared objects in such a way that they can -be reconstructed correctly by the 'deserializer'. This can have quite -a large effect on the memory usage of a serializer (there's a reason -why Common Lisp has the *print-circle* flag). - -Fortunately, we don't need to worry about shared objects when we're -serializing in Rucksack: Rucksack only respects the object identity of -objects that are explicitly declared to be persistent objects. (Erm, -well, that's not entirely true: there are some corner cases like -symbols and packages, but I'm not going to go into that now.) - - -* WHY NOT WRITE AND READ - -If you know that you don't need to worry about shared objects, -serializing objects to disk is easy. In principle, you could just use -Common Lisp's WRITE function to write the object to disk. Then you -can use READ to deserialize the object when you need it again. - -This is possible, but it would be slow. Lisp's syntax for -representing data was designed to be writable and readable by humans. -The serializer doesn't have to worry about human readability, so it -can make decisions that allow for smaller representations and much -faster reading. In my experience, the speed difference can easily be -one or two orders of magnitude. - -Two examples: - -- 'Container objects' like vectors and lists are prefixed by the - number of elements they contain. This means that the deserializer - can pre-allocate a container of exactly the right size. - -- The serializer prefixes every object by its type. This is not - necessarily equivalent to a Common Lisp type, but gives enough - information to the deserializer so that it can prepare itself for - what's coming. - - -* MARKERS - -CODE - -(defconstant +minus-one+ #x09) -(defconstant +zero+ #x0A) -(defconstant +one+ #x0B) -(defconstant +two+ #x0C - -(defconstant +object+ #x70) -(defconstant +unbound-slot+ #x71) -(defconstant +shared-object-definition+ #x72) -(defconstant +shared-object-reference+ #x73) - -(defconstant +hash-table+ #x80) -(defconstant +pathname+ #x90) -(defconstant +array+ #xA0) - -END - -The markers above are hard wired constants and I define them -explicitly. This may look a bit un-lispy; I've seen other -serialization libraries where the marker numbers automatically roll -out of some macro. I don't do that. I do it the old-fashioned way -because I want a well defined file format for Rucksack; there should -not be any implementation or platform dependencies in Rucksack's file -format. - - - -CODE FRAGMENT: DESERIALIZE - -(defun deserialize (serializer &optional (eof-error-p t) (eof-value nil)) - "Reads the next object from the serializer stream. Signals an end-of-file -error or returns EOF-VALUE when the end of the stream is reached." - (let ((marker (read-next-marker serializer))) - (if marker - (deserialize-contents marker serializer) - ;; End of file - (if eof-error-p - (error 'end-of-file :stream serializer) - eof-value)))) - -END - -The top-level DESERIALIZE function just reads a marker and then calls -the generic function DESERIALIZE-CONTENTS. DESERIALIZE-CONTENTS has -a different method for each marker. - -For example: - - -* SERIALIZING A HASH TABLE - -(defmethod serialize ((hash-table hash-table) stream) - (serialize-marker +hash-table+ stream) - ;; Hash-table-test is guaranteed to return a symbol (for the - ;; standardized hash-table test functions), so that's nicely - ;; portable. - (serialize (hash-table-test hash-table) stream) - (serialize (hash-table-size hash-table) stream) - (serialize (hash-table-rehash-size hash-table) stream) - (serialize (hash-table-rehash-threshold hash-table) stream) - (serialize (hash-table-count hash-table) stream) - (maphash (lambda (key value) - (serialize key stream) - (serialize value stream)) - hash-table)) - - -* DESERIALIZING IT AGAIN - -CODE - -(defmethod deserialize-contents ((marker (eql +hash-table+)) stream) - (let* ((test (deserialize stream)) - (size (deserialize stream)) - (rehash-size (deserialize stream)) - (rehash-threshold (deserialize stream)) - (count (deserialize stream))) - (let ((table (make-hash-table :test test - :size size - :rehash-size rehash-size - :rehash-threshold rehash-threshold))) - (loop repeat count - do (let* ((key (deserialize stream)) - (value (deserialize stream))) - (setf (gethash key table) value))) - table))) - -END - - - -* OBJECTS THAT CAN'T BE SERIALIZED - -Some Lisp objects can't be serialized portably: structs and function -objects are the most obvious examples. I think that not serializing -those is a small price to pay for portability, but I suppose there are -exceptions. - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - - -3. FINDING/UPDATING OBJECTS: OBJECT TABLE, CACHE - -* INTRO - -That was easy. - -So now we're able to save normal Lisp objects to disk. And we can -even load them back later. This means we're doing fine for settings -where we can dump the entire world from time to time, and load it back -when we need it. - -For many applications, this is all that's needed. And a good -serializer can be orders of magnitude faster than using WRITE/READ or -writing MAKE-LOAD-FORM methods, so we're already ahead of the game. - -* SERIALIZING PERSISTENT OBJECTS - -Things get more interesting when we need to serialize persistent -objects. For persistent objects we must make sure that we respect -object identity, for example. And we must save some kind of -representation of the object's class, so we can recreate it correctly. -And we must save all slot values, so we need some simple MOP magic to -find all slots. - - -* OBJECT IDENTITY - -Let's look at object identity first: - -Suppose we have a simple persistent family: - -CODE - -(let* ((jane (make-instance 'person :name "Jane")) - (dick (make-instance 'person :name "Dick" :child jane)) - (mary (make-instance 'person :name "Mary" :child jane))) - (make-instance 'family - ;; Try to be politically correct. - :parent-1 dick - :parent-2 mary)) - -END CODE - -Now JANE is a 'shared object': it is (or 'she is') referenced twice. -But we don't want to save her *twice*. When serializing either DICK -or MARY, we just save a *reference* to JANE. - -When we *deserialize* DICK (or MARY) at a later point, we don't deserialize -JANE either. Instead we fill the CHILD slot of DICK with a *proxy*. Only -when the application tries to read DICK'S CHILD slot will the JANE object -be loaded into memory by the deserializer. - - -* SLOT-VALUE-USING-CLASS - -We use the MetaObject Protocol to detect whenever a persistent slot is -being accessed. Here's the method that makes sure that proxies are -automatically dereferenced at the right moment: - -CODE -(defmethod slot-value-using-class :around ((class persistent-class) - object - slot) - ;; Automatically dereference proxies. - (declare (ignore class slot)) - (maybe-dereference-proxy (call-next-method))) -END - -We have similar methods on (SETF SLOT-VALUE-USING-CLASS) to hook into -slot *writes* and on INITIALIZE-INSTANCE to do the right thing when a -new persistent object is created in memory. - - -* PROXIES - -Here's the definition of a proxy in Rucksack: - -CODE - -(defclass proxy () - ((object-id :initarg :object-id :reader object-id) - (rucksack :initform (current-rucksack) - :initarg :rucksack :reader rucksack)) - (:documentation "Proxies are some kind of in-memory forwarding pointer -to data in the cache. They are never saved on disk.")) - -END - -Instead of a class like this, we could also have used plain object ids -(no-nonsense raw integers) to represent the objects. This would be -more efficient, but it has two problems: - -1. It would become quite difficult to work with more than one rucksack - at a time, because you'd need to keep track of which object id - belongs to which rucksack in your application code. - -2. You lose 'type information': you can't distinguish an object id - from a proxy, because they both look like integers from the - outside. This means that the application programmer will have to - dereference proxies by hand instead of having it done automatically - by the compiler (unless you force a static distinction between - slots that always contain proxies and slots that contain other - value; but such a rigid distinction wouldn't really fit with Lisp's - dynamic programming style). - - - -* UPDATING PERSISTENT OBJECTS - -One question that I had to answer for Rucksack is: how are slot values -of persistent objects updated on disk? I've made a big choice that -has a strong influence on rest of Rucksack: objects on disk are never -overwritten (as long as they can be referenced). Instead of -serializing a new version of an object into the same disk space as an -old version, the new version is serialized into some new, freshly -allocated space on disk. - [1985 lines skipped] --- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/30 14:05:40 1.13 +++ /project/rucksack/cvsroot/rucksack/test.lisp 2007/01/20 18:17:55 1.14 @@ -1,434 +1,434 @@ -;; $Id: test.lisp,v 1.13 2006/08/30 14:05:40 alemmens Exp $ - -(in-package :rucksack-test) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; A few quick tests to make sure the basics work. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defparameter *test-suite* #p"/tmp/rucksack-test-suite/") - -(defmacro p-test (form test) - `(progn - (with-rucksack (in *test-suite* :if-exists :supersede) - (with-transaction () - (add-rucksack-root ,form in))) - (with-rucksack (out *test-suite* :if-exists :overwrite) - (with-transaction () - (let ((all (rucksack-roots out))) - (assert (= 1 (length all))) - (let ((it (car all))) - (assert ,test))))))) - -(defmacro test (form) - `(assert ,form)) - -(defclass p-thing-1 () - () - (:metaclass persistent-class)) - -(defclass p-thing-2 () - ((x :initarg :x :reader x-of :persistence t)) - (:metaclass persistent-class)) - -(defun test-basics () - ;; - ;; Serializing/deserializing pathnames. - ;; - - (let ((store (merge-pathnames *test-suite* "store"))) - (rucksack::save-objects (list store) store) - (test (equal (list store) (rucksack::load-objects store)))) - - (test (not (current-rucksack))) - - ;; - ;; P-CONS, P-CAR, P-CDR, P-LIST, P-MAKE-ARRAY, P-AREF - ;; - - (p-test (p-cons 1 2) - (and (= 1 (p-car it)) (= 2 (p-cdr it)))) - - (test (not (current-rucksack))) ; WITH-RUCKSACK should not leave one around - - (p-test (p-list 1 2 3) - (equal '(1 2 3) - (list (p-car it) (p-car (p-cdr it)) (p-car (p-cdr (p-cdr it)))))) - - (p-test (p-make-array 2 :initial-contents '(a b)) - (equal '(a b) - (list (p-aref it 0) (p-aref it 1)))) - - - ;; - ;; Persistent-objects - ;; - - (p-test (make-instance 'p-thing-1) - (eq (find-class 'p-thing-1) (class-of it))) - - (p-test (make-instance 'p-thing-2 :x "-x-") - (equal (x-of it) "-x-")) - - ;; - ;; Btree basics - ;; - - (p-test (let ((btree (make-instance 'btree))) - (btree-insert btree 0 'zero) - (btree-insert btree 15 'fifteen) - (btree-insert btree 10 'ten) - btree) - (equal (list (btree-search it 0) - (btree-search it 10) - (btree-search it 15) - (btree-search it 42 :errorp nil)) - '(zero ten fifteen nil))) - - (test (not (current-rucksack))) - (write-line "basic tests ok")) - -(eval-when (:load-toplevel) - (test-basics)) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Test 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. -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defparameter *names* '("David" "Jim" "Peter" "Thomas" - "Arthur" "Jans" "Klaus" "James" "Martin")) - -(defclass person () - ((name :initform (elt *names* (random (length *names*))) - :accessor name) - (age :initform (random 100) :accessor age)) - (:metaclass persistent-class)) - -(defmethod print-object ((person person) stream) - (print-unreadable-object (person stream :type t) - (format stream "called ~S of age ~D" - (name person) - (age person)))) - -(defun test-create (&key (nr-objects 100000)) - "Test creating a rucksack with many persons." - (with-rucksack (rucksack *test-suite* :if-exists :supersede) - (with-transaction () - (loop for i below nr-objects - do (let ((person (make-instance 'person))) - (when (zerop (mod i 1000)) - (format t "~D " i)) - (add-rucksack-root person rucksack)))))) - - -(defun test-update (&key (new-age 27)) - "Test updating all persons by changing their age." - (with-rucksack (rucksack *test-suite*) - (with-transaction () - (map-rucksack-roots (lambda (person) - (setf (age person) new-age)) - rucksack)))) - -(defun test-load () - "Test loading all persons by computing their average age." - (with-rucksack (rucksack *test-suite*) - (with-transaction () - (let ((nr-persons 0) - (total-age 0)) - (map-rucksack-roots (lambda (person) - (incf nr-persons) - (incf total-age (age person))) - rucksack) - ;; Return the average age as a float. - ;; (An average age of 1200/75 doesn't seem right.) - (coerce (/ total-age nr-persons) 'float))))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Btrees -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;; -;; 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 - 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 (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 and balance~%") - (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 (first *format-strings*) 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) 100)) - (format t "~D " (1+ i))) - (btree-delete-key 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) - -;; -;; 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 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 - ;; 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 10 :delete 1500))) - -(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 () - (let ((btree (first (rucksack-roots rucksack)))) - (map-btree btree - (lambda (key value) - (when display - (format t "~&~D -> ~A~%" key value))) - :min min - :include-min include-min [471 lines skipped] --- /project/rucksack/cvsroot/rucksack/transactions.lisp 2007/01/16 08:57:43 1.12 +++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2007/01/20 18:17:55 1.13 @@ -1,378 +1,378 @@ -;; $Id: transactions.lisp,v 1.12 2007/01/16 08:57:43 charmon Exp $ - -(in-package :rucksack) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Transactions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; User API: -;;; transaction-start -;;; transaction-commit -;;; transaction-rollback -;;; with-transaction -;;; current-transaction -;;; -;;; Internal API: -;;; transaction standard-transaction -;;; transaction-start-1 -;;; - -(defgeneric transaction-start-1 (cache rucksack &key &allow-other-keys) - (:documentation "Creates and returns a new transaction.")) - -(defgeneric transaction-commit-1 (transaction cache rucksack) - (:documentation "Save all modified objects to disk.")) - -(defgeneric transaction-rollback-1 (transaction cache rucksack)) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Transactions -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defclass transaction () - ()) - -(defclass standard-transaction (transaction) - ((id :initarg :id :reader transaction-id) - ;; Dirty objects - (dirty-objects :initarg :dirty-objects - :initform (make-hash-table) - :reader dirty-objects - :documentation "A hash-table (from id to object) -containing all objects of which the slot changes have not been written -to disk yet.") - (dirty-queue :initarg :dirty-queue - :initform (make-instance 'queue) - :reader dirty-queue - :documentation "A queue with the ids of all objects -that have been created or modified since the last commit. The queue -is in least-recently-dirtied-first order. During a commit, the -objects are written to disk in the same order (this is necessary to -guarantee that the garbage collector never sees an id of an object -that doesn't exist on disk yet."))) - -(defmethod print-object ((transaction transaction) stream) - (print-unreadable-object (transaction stream :type t :identity nil) - (format stream "#~D with ~D dirty object~:P" - (transaction-id transaction) - (hash-table-count (dirty-objects transaction))))) - - -(defun current-transaction () - *transaction*) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Modifying objects and checking for conflicts -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(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.")) - -(defgeneric transaction-older-p (a 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.")) - -(defmethod transaction-nr-dirty-objects ((transaction standard-transaction)) - (hash-table-count (dirty-objects transaction))) - -(defmethod transaction-touch-object ((transaction standard-transaction) - object - object-id) - (setf (gethash object-id (dirty-objects transaction)) object) - (queue-add (dirty-queue transaction) object-id)) - - -(defmethod transaction-changed-object ((transaction standard-transaction) - object-id) - (gethash object-id (dirty-objects transaction))) - - -(defmethod find-conflicting-transaction - (object-id - (cache standard-cache) - (current-transaction standard-transaction)) - ;; EFFICIENCY: We need to consider all transactions, because the - ;; transactions are in a hash-table. If we use a container that's - ;; ordered by creation time (like a btree), we only need to consider - ;; transactions that are younger than the given transaction. - (loop for transaction being the hash-value of (transactions cache) - thereis (and (not (eql transaction current-transaction)) - (transaction-older-p transaction current-transaction) - (transaction-changed-object transaction object-id) - transaction))) - - -(defmethod transaction-older-p ((a standard-transaction) - (b standard-transaction)) - (< (transaction-id a) (transaction-id b))) - - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;; Starting a new transaction -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun transaction-start (&rest args - &key (rucksack (current-rucksack)) - &allow-other-keys) - (apply #'transaction-start-1 (rucksack-cache rucksack) rucksack args)) - - -(defmethod transaction-start-1 ((cache standard-cache) - (rucksack standard-rucksack) - &key &allow-other-keys) - ;; Create new transaction. - (let* ((id (make-transaction-id cache)) - (transaction (make-instance 'standard-transaction :id id))) - ;; Add to open transactions. - (open-transaction cache transaction) - ;; 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 -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -;;; use without-rucksack-gcing to locally set -;;; *collect-garbage-on-commit* to nil in order to supress rucksack -;;; garbage collection on commit -(defmacro without-rucksack-gcing (&body body) - `(let ((*collect-garbage-on-commit* nil)) - , at body)) - -(defun transaction-commit (transaction &key (rucksack (current-rucksack))) - "Call transaction-commit-1 to do the real work." - (transaction-commit-1 transaction (rucksack-cache rucksack) rucksack)) - -(defmethod transaction-commit-1 ((transaction standard-transaction) - (cache standard-cache) - (rucksack standard-rucksack)) - ;; Save all dirty objects to disk. - (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. - (when *collect-garbage-on-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))) - (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)))) - - -;; -;; Commit file -;; - -(defun create-commit-file (transaction cache) - "Write object ids of all dirty objects to the commit file, so -recovery can do its job if this transaction never completes." - (with-open-file (stream (commit-filename cache) - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :element-type '(unsigned-byte 8)) - (serialize (transaction-id transaction) stream) - (serialize (hash-table-count (dirty-objects transaction)) stream) - (loop for object-id being the hash-key of (dirty-objects transaction) - do (serialize object-id stream)))) - -(defun delete-commit-file (transaction cache) - (declare (ignore transaction)) - (delete-file (commit-filename cache))) - -(defun load-commit-file (cache) - "Returns two values: a transaction id and a list of object ids -(of objects that may be partially committed)." - (with-open-file (stream (commit-filename cache) - :direction :output - :if-exists :supersede - :if-does-not-exist :create - :element-type '(unsigned-byte 8)) - (let* ((transaction-id (deserialize stream)) - (nr-objects (deserialize stream)) - (objects (loop repeat nr-objects - collect (deserialize stream)))) - (values transaction-id objects)))) - -;; -;; Saving objects -;; - -(defmethod save-dirty-object (object - (cache standard-cache) - (transaction standard-transaction) - object-id &key schema) - (let* ((transaction-id (transaction-id transaction)) - (heap (heap cache)) - (object-table (object-table heap)) - (version-list - ;; If the object-table entry is not marked :reserved, there - ;; is an object version list. Get the start of that list. - (and (not (eql :reserved (object-info object-table object-id))) - (object-heap-position object-table object-id)))) - (multiple-value-bind (younger-version older-version) - ;; Determine the correct position in the version list. - (version-list-position transaction-id object-id version-list heap) - ;; Write the object to a fresh block on the heap. - (let ((block (save-object object object-id cache - transaction-id older-version - :schema schema))) - ;; Hook the block into the version list. - (if younger-version - ;; Let younger version point to this version. - (setf (object-version-list younger-version heap) block) - ;; There is no younger version, so this version becomes - ;; the start of the version list. - (setf (object-heap-position object-table object-id) - block))))) - object-id) - -(defun version-list-position (current-transaction-id obj-id version-list heap) - "Returns the correct position for a transaction-id in a version-list. -To be more precise, it returns: - 1. the block of the object version with the oldest transaction that's -younger than the given transaction-id (nil if there is no such version). - 2. the block of the first object version in the version list that has -a transaction id older than the given transaction-id (nil if there is no -such version). - VERSION-LIST is either nil or the heap position of the first object -version in the version list." - (and version-list - (let ((younger nil) - (block version-list)) - (loop - (let ((buffer (load-block heap block :skip-header t))) - (multiple-value-bind (id nr-slots schema transaction-id previous) - (load-object-fields buffer obj-id) - ;; DO: Don't load id, nr-slots, schema at all! - (declare (ignore id nr-slots schema)) - (cond ((< transaction-id current-transaction-id) - ;; The version we're examining is older than the - ;; current-transaction-id, so we found the right - ;; place for the current version. - (return-from version-list-position - (values younger block))) - ((null previous) - ;; There is no version that's older than the current - ;; transaction. This can happen, because transaction - ;; commits do not necessarily happen in transaction - ;; creation order. - (return-from version-list-position - (values younger nil))) - (t - ;; Keep trying older versions. - (setq younger block - block previous))))))))) - -(defun (setf object-version-list) (old-block young-block heap) - "Let the (previous pointer of the) object in YOUNG-BLOCK point to -OLD-BLOCK." - (let ((stream (heap-stream heap))) - (file-position stream (+ young-block (block-header-size heap))) - (serialize-previous-version-pointer old-block stream)) - old-block) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; Rolling back -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; - -(defun transaction-rollback (transaction &key (rucksack (current-rucksack))) - (transaction-rollback-1 transaction - (rucksack-cache rucksack) - rucksack)) - -(defmethod transaction-rollback-1 ((transaction standard-transaction) - (cache standard-cache) - (rucksack standard-rucksack)) - (clrhash (dirty-objects transaction)) - (queue-clear (dirty-queue transaction)) - (close-transaction cache transaction)) - - - - - - - +;; $Id: transactions.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $ + +(in-package :rucksack) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; Transactions +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +;;; User API: +;;; transaction-start +;;; transaction-commit +;;; transaction-rollback +;;; with-transaction +;;; current-transaction +;;; +;;; Internal API: +;;; transaction standard-transaction +;;; transaction-start-1 +;;; [359 lines skipped] From alemmens at common-lisp.net Mon Jan 22 10:23:14 2007 From: alemmens at common-lisp.net (alemmens) Date: Mon, 22 Jan 2007 05:23:14 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070122102314.D0FC331035@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv24110 Modified Files: do.txt done.txt rucksack.asd serialize.lisp Log Message: Version 0.1.6 - Added serializing/deserializing of structures. Only works on SBCL. (Thanks to Levente M?sz?ros.) --- /project/rucksack/cvsroot/rucksack/do.txt 2006/09/04 12:34:34 1.5 +++ /project/rucksack/cvsroot/rucksack/do.txt 2007/01/22 10:23:14 1.6 @@ -1,14 +1,10 @@ DO: -- In SBCL, FINALIZE-INHERITANCE is not called when a class was redefined - and a new instance of the redefined class is created. (In Lispworks, - it *is* called then.) - -- Make Rucksack crash proof. (Use a copying GC?) - - There's still a btree bug that's detected (very rarely) by the stress test. Fix it. +- Make Rucksack crash proof. (Use a copying GC?) + - Check that btrees actually signal an error for duplicate keys. Handle those errors correctly for slot indexes. --- /project/rucksack/cvsroot/rucksack/done.txt 2006/11/30 10:45:34 1.6 +++ /project/rucksack/cvsroot/rucksack/done.txt 2007/01/22 10:23:14 1.7 @@ -1,3 +1,9 @@ +* 2007-01-21 - version 0.1.6 + +- Added serializing/deserializing of structures. Only works on SBCL. + (Thanks to Levente M?sz?ros.) + + * 2006-11-30 - FLET MAP-INDEXES should be LABELS MAP-INDEXES (thanks to Cyrus Harmon) --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/20 18:17:55 1.7 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/22 10:23:14 1.8 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.7 2007/01/20 18:17:55 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.8 2007/01/22 10:23:14 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.5" + :version "0.1.6" :serial t :components ((:file "queue") (:file "package") --- /project/rucksack/cvsroot/rucksack/serialize.lisp 2007/01/20 18:17:55 1.9 +++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2007/01/22 10:23:14 1.10 @@ -1,4 +1,4 @@ -;; $Id: serialize.lisp,v 1.9 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: serialize.lisp,v 1.10 2007/01/22 10:23:14 alemmens Exp $ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Serialize @@ -170,6 +170,7 @@ (defconstant +unbound-slot+ #x71) (defconstant +shared-object-definition+ #x72) (defconstant +shared-object-reference+ #x73) +(defconstant +structure-object+ #x77) ;; Rest @@ -1133,9 +1134,57 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Structures ;;; -;;; Can't be serialized portably. Let's forget about them here. +;;; Can't be serialized portably. The version below works for SBCL at the +;;; moment, but using structures in Rucksack is risky: if a structure +;;; definition changes, Rucksack won't know about it and you'll probably +;;; run into big problems. ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +#+sbcl +(defmethod serialize ((object structure-object) serializer) + (serialize-structure-object object serializer)) + +(defun serialize-structure-object (object serializer) + ;; A structure object is serialized as: + ;; - structure name + ;; - number of slots + ;; - slot values + (serialize-marker +structure-object+ serializer) + (serialize (class-name (class-of object)) serializer) + (save-slots object serializer)) + +(defmethod save-slots ((object structure-object) serializer) + (let ((slots (saved-slots object))) + (serialize (length slots) serializer) + (loop for slot-name in (saved-slots object) + do (serialize (slot-value object slot-name) serializer)))) + +#+sbcl +(defmethod deserialize-contents ((marker (eql +structure-object+)) serializer) + (let* ((class-name (deserialize serializer)) + (object (allocate-instance (find-class class-name)))) + (load-slots object serializer))) + +(defmethod load-slots ((object structure-object) stream) + (let ((nr-slots (deserialize stream)) + (slots (saved-slots object))) + (unless (= nr-slots (length slots)) + (error "Slot mismatch while deserializing a structure object of class ~S." + (class-of object))) + (loop for slot-name in (saved-slots object) + do (let ((marker (read-next-marker stream))) + (setf (slot-value object slot-name) + (deserialize-contents marker stream)))) + object)) + +(defmethod scan-contents ((marker (eql +structure-object+)) serializer gc) + ;; Skip class name + (scan serializer gc) + ;; Scan all slots + (let ((nr-slots (deserialize serializer))) + (loop repeat nr-slots + do (scan serializer gc)))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; Arrays ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; From alemmens at common-lisp.net Mon Jan 22 10:55:46 2007 From: alemmens at common-lisp.net (alemmens) Date: Mon, 22 Jan 2007 05:55:46 -0500 (EST) Subject: [rucksack-cvs] CVS rucksack Message-ID: <20070122105546.4759633002@common-lisp.net> Update of /project/rucksack/cvsroot/rucksack In directory clnet:/tmp/cvs-serv28037 Modified Files: done.txt heap.lisp rucksack.asd Log Message: Version 0.1.7 - Get rid of two SBCL compiler warnings. (Reported by Cyrus Harmon.) --- /project/rucksack/cvsroot/rucksack/done.txt 2007/01/22 10:23:14 1.7 +++ /project/rucksack/cvsroot/rucksack/done.txt 2007/01/22 10:55:45 1.8 @@ -1,3 +1,8 @@ +* 2007-01-22 - version 0.1.7 + +- Get rid of two SBCL compiler warnings. (Reported by Cyrus Harmon.) + + * 2007-01-21 - version 0.1.6 - Added serializing/deserializing of structures. Only works on SBCL. @@ -6,7 +11,7 @@ * 2006-11-30 -- FLET MAP-INDEXES should be LABELS MAP-INDEXES (thanks to Cyrus Harmon) +- FLET MAP-INDEXES should be LABELS MAP-INDEXES (thanks to Cyrus Harmon). - The :EQUAL parameter for MAP-INDEX-DATA wasn't handled correctly for indexes with non-unique keys (reported by Cyrus Harmon). --- /project/rucksack/cvsroot/rucksack/heap.lisp 2007/01/20 18:17:55 1.13 +++ /project/rucksack/cvsroot/rucksack/heap.lisp 2007/01/22 10:55:46 1.14 @@ -1,4 +1,4 @@ -;; $Id: heap.lisp,v 1.13 2007/01/20 18:17:55 alemmens Exp $ +;; $Id: heap.lisp,v 1.14 2007/01/22 10:55:46 alemmens Exp $ (in-package :rucksack) @@ -405,7 +405,7 @@ ;; the block that distinguishes free blocks from occupied blocks. (:method (block block-size (heap free-list-heap)) ;; Default: do nothing - (declare (ignore block block-size)) + (declare (ignore block-size)) block)) ;; @@ -420,7 +420,7 @@ 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)))) + sum (or (getf plist :nr-free-octets) 0)))) (values total info))) --- /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/22 10:23:14 1.8 +++ /project/rucksack/cvsroot/rucksack/rucksack.asd 2007/01/22 10:55:46 1.9 @@ -1,9 +1,9 @@ -;;; $Id: rucksack.asd,v 1.8 2007/01/22 10:23:14 alemmens Exp $ +;;; $Id: rucksack.asd,v 1.9 2007/01/22 10:55:46 alemmens Exp $ (in-package :cl-user) (asdf:defsystem :rucksack - :version "0.1.6" + :version "0.1.7" :serial t :components ((:file "queue") (:file "package")