[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Wed Aug 9 13:23:18 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv3042
Modified Files:
garbage-collector.lisp heap.lisp objects.lisp rucksack.lisp
test.lisp transactions.lisp
Log Message:
Add a SERIAL-TRANSACTION-RUCKSACK-CLASS that allows for only one transaction
at a time (by using a transaction lock).
Don't do any GC at all while a transaction is writing objects to disk.
Instead we keep track of the amount of disk space allocated by the committing
transaction. Then we do a (partial) GC immediately after committing the
transaction.
--- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/08 15:48:24 1.16
+++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/09 13:23:18 1.17
@@ -1,4 +1,4 @@
-;; $Id: garbage-collector.lisp,v 1.16 2006/08/08 15:48:24 alemmens Exp $
+;; $Id: garbage-collector.lisp,v 1.17 2006/08/09 13:23:18 alemmens Exp $
(in-package :rucksack)
@@ -46,6 +46,8 @@
:ready)
:accessor state)
(doing-work :initform nil :accessor gc-doing-work
+ ;; NOTE: This flag is probably not necessary anymore and
+ ;; should probably be removed.
:documentation
"A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.")
;; Some counters that keep track of the amount of work done by
@@ -129,11 +131,13 @@
;;
;; or: Work = (Size / Free) * WorkLeft
;;
- (let* ((free (free-space heap))
- (work-left (work-left heap)))
- (if (>= size free)
- work-left
- (floor (* size work-left) free))))
+ (if (zerop size)
+ 0
+ (let* ((free (free-space heap))
+ (work-left (work-left heap)))
+ (if (>= size free)
+ work-left
+ (floor (* size work-left) free)))))
(defmethod free-space ((heap mark-and-sweep-heap))
--- /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/04 10:26:23 1.9
+++ /project/rucksack/cvsroot/rucksack/heap.lisp 2006/08/09 13:23:18 1.10
@@ -1,4 +1,4 @@
-;; $Id: heap.lisp,v 1.9 2006/08/04 10:26:23 alemmens Exp $
+;; $Id: heap.lisp,v 1.10 2006/08/09 13:23:18 alemmens Exp $
(in-package :rucksack)
@@ -24,6 +24,16 @@
(defgeneric (setf heap-end) (value heap)
(:documentation "Modifies the end of the heap."))
+(defgeneric allocate-block (heap &key size expand)
+ (:documentation "Allocates a block of the requested size and returns
+the heap position of that block. If the free list is full and EXPAND
+is true, the system will try to expand the free list; otherwise it
+returns nil.
+ As a second value, ALLOCATE-BLOCK returns the number of octets that
+were allocated.
+Note: both the requested size and the returned heap position include
+the block's header."))
+
;; DO: Many more generic functions.
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -47,7 +57,13 @@
(max-size :initarg :max-size
:initform nil :accessor max-heap-size
:documentation "The maximum size (in octets) for the heap.
-If nil, the heap is allowed to expand indefinitely.")))
+If nil, the heap is allowed to expand indefinitely.")
+ (nr-allocated-octets :initform 0
+ :accessor nr-allocated-octets
+ :documentation "The number of octets that have been
+allocated by ALLOCATE-BLOCK since the last time that RESET-ALLOCATION-COUNTER
+was called.")))
+
;;
@@ -134,6 +150,29 @@
(initialize-block new-block block-size heap)
new-block))
+;;
+;; Keeping track of allocations
+;;
+
+(defmethod allocate-block :around ((heap heap) &key &allow-other-keys)
+ (multiple-value-bind (block nr-octets)
+ (call-next-method)
+ (incf (nr-allocated-octets heap) nr-octets)
+ (values block nr-octets)))
+
+(defmethod reset-allocation-counter ((heap heap))
+ ;; Resets the allocation counter (and returns the old value of the counter).
+ (let ((old-value (nr-allocated-octets heap)))
+ (setf (nr-allocated-octets heap) 0)
+ old-value))
+
+(defmacro with-allocation-counter ((heap) &body body)
+ (let ((heap-var (gensym "HEAP"))
+ (old-counter (gensym "COUNTER")))
+ `(let* ((,heap-var ,heap)
+ (,old-counter (reset-allocation-counter ,heap-var)))
+ (unwind-protect (progn , at body)
+ (setf (nr-allocated-octets ,heap-var) ,old-counter)))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Free list heap
@@ -266,14 +305,6 @@
;; Allocating and deallocating blocks
;;
-(defgeneric allocate-block (heap &key size expand)
- (:documentation "Allocates a block of the requested size and returns
-the heap position of that block. If the free list is full and EXPAND
-is true, the system will try to expand the free list; otherwise it
-returns nil.
-Note: both the requested size and the returned heap position include
-the block's header."))
-
(defmethod allocate-block ((heap free-list-heap)
&key (size (min-block-size heap)) (expand t))
;; We don't bother to do something with the unused part of the block.
@@ -288,7 +319,8 @@
(when (free-list-empty-p size-class heap)
(if expand
(setq block (expand-free-list size-class heap))
- (return-from allocate-block nil)))
+ (return-from allocate-block
+ (values nil 0))))
;; Unhook the block from the free list
;; (the block header of an unused block contains a pointer to the
;; next unused block).
@@ -298,7 +330,7 @@
;; into header.
(setf (block-size block heap) (size-class-block-size size-class heap))
;; Return the block.
- block))
+ (values block size)))
(defmethod deallocate-block (block (heap free-list-heap))
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/08 13:35:18 1.6
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/09 13:23:18 1.7
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.6 2006/08/08 13:35:18 alemmens Exp $
+;; $Id: objects.lisp,v 1.7 2006/08/09 13:23:18 alemmens Exp $
(in-package :rucksack)
@@ -611,11 +611,6 @@
;; Save the serialized buffer in the block.
(save-buffer buffer (heap-stream heap)
:file-position (+ block (block-header-size heap)))
- ;; Let the garbage collector do its thing after an object is
- ;; written to the heap. (Not earlier, otherwise the GC may
- ;; see objects that are neither free nor completely saved and
- ;; it doesn't know how to deal with those.)
- (collect-some-garbage heap (gc-work-for-size heap size))
(handle-written-object object-id block heap)
;; Return the block.
block)))
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/05/28 11:22:54 1.7
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/09 13:23:18 1.8
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.7 2006/05/28 11:22:54 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $
(in-package :rucksack)
@@ -206,6 +206,17 @@
#-(or allegro lispworks sbcl openmcl)
(not-implemented 'with-lock))
+(defun process-lock (lock)
+ #+lispworks
+ (mp:process-lock lock)
+ #-lispworks
+ (not-implemented 'process-lock))
+
+(defun process-unlock (lock)
+ #+lispworks
+ (mp:process-unlock lock)
+ #-lispworks
+ (not-implemented 'process-unlock))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Rucksacks
@@ -299,7 +310,6 @@
;; We don't need to nreverse the list, because the order isn't specified.
result))
-
;;
;; Opening
;;
@@ -310,7 +320,7 @@
(defun open-rucksack (directory-designator
&rest args
&key
- (class 'standard-rucksack)
+ (class 'serial-transaction-rucksack)
(if-exists :overwrite) (if-does-not-exist :create)
(cache-class 'standard-cache) (cache-args '())
&allow-other-keys)
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/08 15:48:24 1.7
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/09 13:23:18 1.8
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.7 2006/08/08 15:48:24 alemmens Exp $
+;; $Id: test.lisp,v 1.8 2006/08/09 13:23:18 alemmens Exp $
(in-package :test-rucksack)
@@ -187,7 +187,7 @@
(defparameter *format-strings*
;; Different ways of printing integers.
- '("~R" "~:R" "~@R" "~D"))
+ '("~R" "~:R" "... ~R" "~D"))
(defun shuffle (array)
(loop with n = (array-dimension array 0)
@@ -241,10 +241,7 @@
when (zerop (mod i 1000))
do (format t "~D " i)
do (btree-insert btree key
- (format nil (first *format-strings*) key))
- do (unless unique-keys
- (loop for format-string in (rest *format-strings*)
- do (btree-insert btree key (format nil format-string key)))))
+ (format nil (first *format-strings*) key)))
(add-rucksack-root btree rucksack))))
(with-rucksack (rucksack *test-suite*)
(with-transaction ()
@@ -301,7 +298,7 @@
strings key value))))))
-(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 8))
+(defun test-non-unique-btree (&key (n 20000) (node-size 100) (delete (floor n 10))
check-contents)
;; Create a rucksack with a btree of size N (N must be a multiple of 4) that
;; maps random integers to four different equivalent strings (in Roman and
@@ -407,6 +404,7 @@
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
(defun check-gc (n)
+ ;; This used to fail for large values of N (e.g. 10,000).
(with-rucksack (rucksack *test-suite* :if-exists :supersede)
(with-transaction ()
;; after this, INNER can be reached directly from the root
--- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/08 13:35:18 1.8
+++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/09 13:23:18 1.9
@@ -1,4 +1,4 @@
-;; $Id: transactions.lisp,v 1.8 2006/08/08 13:35:18 alemmens Exp $
+;; $Id: transactions.lisp,v 1.9 2006/08/09 13:23:18 alemmens Exp $
(in-package :rucksack)
@@ -142,6 +142,32 @@
;; And return the new transaction.
transaction))
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;;; Rucksacks with serial transactions
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+(defclass serial-transaction-rucksack (standard-rucksack)
+ ((transaction-lock :initform (make-lock :name "Rucksack transaction lock")
+ :reader rucksack-transaction-lock))
+ (:documentation
+ "A serial transaction rucksack allows only one active transaction
+at a time."))
+
+(defmethod transaction-start-1 :before ((cache standard-cache)
+ (rucksack serial-transaction-rucksack)
+ &key &allow-other-keys)
+ (process-lock (rucksack-transaction-lock rucksack)))
+
+(defmethod transaction-commit-1 :after ((transaction standard-transaction)
+ (cache standard-cache)
+ (rucksack serial-transaction-rucksack))
+ (process-unlock (rucksack-transaction-lock rucksack)))
+
+(defmethod transaction-rollback-1 :after ((transaction standard-transaction)
+ (cache standard-cache)
+ (rucksack serial-transaction-rucksack))
+ (process-unlock (rucksack-transaction-lock rucksack)))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Committing a transaction
@@ -160,30 +186,40 @@
;; 2. Commit all dirty objects.
;; Q: What if this is interleaved with other commits?
(let ((queue (dirty-queue transaction))
- (table (dirty-objects transaction)))
- (loop until (queue-empty-p queue)
- do (let* ((id (queue-remove queue))
- (object (gethash id table)))
- (when object
- ;; If it's not in the dirty-objects table anymore, the
- ;; object was already saved during this transaction-commit.
- ;; That's possible, because the queue can contain duplicates.
- (save-dirty-object object cache transaction id)
- ;; Remove from hash-table too.
- (remhash id table))))
+ (table (dirty-objects transaction))
+ (heap (heap cache))
+ nr-allocated-octets)
+ (with-allocation-counter (heap)
+ (loop until (queue-empty-p queue)
+ do (let* ((id (queue-remove queue))
+ (object (gethash id table)))
+ (when object
+ ;; If it's not in the dirty-objects table anymore, the
+ ;; object was already saved during this transaction-commit.
+ ;; That's possible, because the queue can contain duplicates.
+ (save-dirty-object object cache transaction id)
+ ;; Remove from hash-table too.
+ (remhash id table))))
+ (setq nr-allocated-octets (nr-allocated-octets heap)))
;; Check for consistency between hash table and queue.
(unless (zerop (hash-table-count table))
(internal-rucksack-error
"Mismatch between dirty hash-table and queue while committing ~S:
~D objects left in hash-table."
transaction
- (hash-table-count table))))
- ;; 3. Remove transaction from the cache's open transactions.
- (close-transaction cache transaction)
- ;; 4. Delete the commit file to indicate that everything went fine
- ;; and we don't need to recover from this commit.
- (delete-commit-file transaction cache))
+ (hash-table-count table)))
+ ;; 3. Remove transaction from the cache's open transactions.
+ (close-transaction cache transaction)
+ ;; 4. Delete the commit file to indicate that everything went fine
+ ;; and we don't need to recover from this commit.
+ (delete-commit-file transaction cache)
+ ;; 5. Let the garbage collector do an amount of work proportional
+ ;; to the number of octets that were allocated during the commit.
+ (collect-some-garbage heap
+ (gc-work-for-size heap nr-allocated-octets))))
+
+
;;
;; Commit file
;;
More information about the rucksack-cvs
mailing list