Permalink
Browse files

concurrent transaction.

  • Loading branch information...
1 parent 37c8f2e commit 2b6d58fab0bc670d820b81e59fae2ff9b0a5ecba @quek committed Oct 23, 2011
Showing with 436 additions and 250 deletions.
  1. +2 −0 .gitignore
  2. +48 −26 cache.lisp
  3. +2 −2 errors.lisp
  4. +45 −41 garbage-collector.lisp
  5. +64 −26 heap.lisp
  6. +4 −4 object-table.lisp
  7. +17 −13 objects.lisp
  8. +4 −1 package.lisp
  9. +1 −0 rucksack.asd
  10. +58 −69 rucksack.lisp
  11. +1 −1 tests/rucksack-test.asd
  12. +70 −4 tests/unit-tests.lisp
  13. +53 −0 thread.lisp
  14. +67 −63 transactions.lisp
View
@@ -0,0 +1,2 @@
+*~
+*.fasl
View
@@ -128,11 +128,19 @@ less time and less memory to do its work. Disadvantage is that it's
very stupid about the objects it should try to keep in memory."))
+(defclass concurrent-cache (lazy-cache)
+ ()
+ (:documentation "concurrent-cache doesn't user objects slots.
+objects slot of concurrent-transaction is used.
+any object is not shared with each transaction."))
+
+
(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)))
+ (with-heap-stream (s (heap cache))
+ (pathname s))
(cache-count cache))))
@@ -216,8 +224,7 @@ very stupid about the objects it should try to keep in memory."))
(defun commit-filename (cache)
- (merge-pathnames "commit"
- (pathname (heap-stream (heap cache)))))
+ (merge-pathnames "commit" (pathname (slot-value (heap cache) 'stream))))
;;
@@ -275,6 +282,15 @@ already dirty, nothing happens."
;; Let the transaction keep track of the dirty object.
(transaction-touch-object transaction object object-id))))
+(defmethod cache-touch-object (object (cache concurrent-cache))
+ "Checks for transaction conflicts and wait for commit.
+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)))
+ (transaction-touch-object transaction object object-id)))
(defmethod cache-get-object (object-id (cache standard-cache))
@@ -311,35 +327,41 @@ already dirty, nothing happens."
(add-to-queue object-id cache)
result))
+(defmethod cache-get-object (object-id (cache concurrent-cache))
+ (let* ((transaction (current-transaction))
+ (result (or
+ ;; Unmodified, already loaded and compatible with the
+ ;; current transaction? Fine, let's use it.
+ (gethash object-id (objects cache))
+ ;; New object.
+ (transaction-changed-object transaction object-id)
+ ;; 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)
+ (declare (ignore 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))))
+ ;; Modified by the current-transaction itself? Then use that version.
+ (transaction-changed-object current-transaction object-id)))
(defmethod cache-delete-object (object-id (cache standard-cache))
View
@@ -35,8 +35,8 @@ 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."
+ (format stream "~&~A can't modify object #~D, because #~A already
+modified it."
(transaction error)
(object-id error)
(old-transaction error)))
View
@@ -8,8 +8,6 @@
(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
@@ -32,6 +30,9 @@
:documentation
"A flag to prevent recursive calls to COLLECT-SOME-GARBAGE.")))
+(defmethod serialization-buffer ((garbage-collector garbage-collector))
+ (make-instance 'serialization-buffer))
+
(defgeneric scan (buffer garbage-collector)
(:documentation "Scans the object in the serialization buffer, marking or
@@ -130,8 +131,9 @@ rounded up.)")))
;; 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)))
+ (with-heap-stream (stream heap)
+ (file-position stream (+ block (block-header-size heap)))
+ (serialize (- block-size) stream)))
(defmethod handle-written-object (object-id block (heap mark-and-sweep-heap))
@@ -329,17 +331,18 @@ collector."
(defmethod load-block ((heap mark-and-sweep-heap) block
&key (buffer (serialization-buffer heap))
- (skip-header nil))
+ (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)))
+ (with-heap-stream (stream heap)
+ (load-buffer buffer
+ stream
+ (block-size block heap)
+ :eof-error-p nil
+ :file-position (if skip-header
+ (+ block (block-header-size heap))
+ block))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Sweeping the heap
@@ -353,34 +356,35 @@ collector."
(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 (not free-p) ; only non-free blocks
- (let* ((heap-stream (heap-stream heap))
- (object-id (progn
- (deserialize heap-stream)
- (deserialize heap-stream))))
- (when (not (block-alive-p object-table object-id 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))))
+ 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 (not free-p) ; only non-free blocks
+ (with-heap-stream (stream heap)
+ (let* ((heap-stream stream)
+ (object-id (progn
+ (deserialize heap-stream)
+ (deserialize heap-stream))))
+ (when (not (block-alive-p object-table object-id 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))
@@ -401,7 +405,7 @@ collector."
;; followed by the previous version pointer (a serialized positive
;; integer or nil) or the block size (a serialized negative integer; for
;; free blocks).
- (let ((stream (heap-stream heap)))
+ (with-heap-stream (stream heap)
(file-position stream position)
(let ((block-header (read-unsigned-bytes (cell-buffer heap) stream)))
(file-position stream (+ 8 position))
Oops, something went wrong.

0 comments on commit 2b6d58f

Please sign in to comment.