[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Sat Jan 20 18:18:00 UTC 2007
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 of size 0 @ #x21eed772>
-QUEUE> (queue-add *q* "Hi")
-#<QUEUE of size 1 @ #x21eed772>
-QUEUE> (queue-peek *q*)
-"Hi"
-QUEUE> (queue-add *q* 123)
-#<QUEUE of size 2 @ #x21eed772>
-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 of size 1 @ #x21eed772>
-QUEUE> (queue-add *q* 123)
-#<QUEUE of size 2 @ #x21eed772>
-QUEUE> (queue-peek *q* 'integer)
-123
-QUEUE> (queue-size *q*)
-1
-QUEUE> (queue-add-at-front *q* "hi")
-#<QUEUE of size 2 @ #x21eed772>
-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 of size 0 @ #x21eed772>
+QUEUE> (queue-add *q* "Hi")
+#<QUEUE of size 1 @ #x21eed772>
+QUEUE> (queue-peek *q*)
+"Hi"
+QUEUE> (queue-add *q* 123)
+#<QUEUE of size 2 @ #x21eed772>
+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 of size 1 @ #x21eed772>
+QUEUE> (queue-add *q* 123)
+#<QUEUE of size 2 @ #x21eed772>
+QUEUE> (queue-peek *q* 'integer)
+123
+QUEUE> (queue-size *q*)
+1
+QUEUE> (queue-add-at-front *q* "hi")
+#<QUEUE of size 2 @ #x21eed772>
+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]
More information about the rucksack-cvs
mailing list