[rucksack-cvs] CVS rucksack
alemmens
alemmens at common-lisp.net
Thu Aug 24 15:21:25 UTC 2006
Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv9687
Modified Files:
cache.lisp garbage-collector.lisp make.lisp objects.lisp
package.lisp rucksack.lisp serialize.lisp test.lisp
transactions.lisp
Log Message:
The class and slot indexes were normal hash tables, but they should be
persistent objects like everything else: I replaced them by btrees.
Get PROCESS-LOCK and PROCESS-UNLOCK working on SBCL (thanks to Geoff Cant).
--- /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/10 12:36:16 1.9
+++ /project/rucksack/cvsroot/rucksack/cache.lisp 2006/08/24 15:21:25 1.10
@@ -1,4 +1,4 @@
-;; $Id: cache.lisp,v 1.9 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: cache.lisp,v 1.10 2006/08/24 15:21:25 alemmens Exp $
(in-package :rucksack)
@@ -281,7 +281,8 @@
;; current transaction? Fine, let's use it.
(let ((object (gethash object-id (objects cache))))
(and object
- (<= (transaction-id object) (transaction-id transaction))
+ (or (null transaction)
+ (<= (transaction-id object) (transaction-id transaction)))
object))
;; Modified by an open transaction? Try to find the
;; 'compatible' version.
@@ -318,22 +319,23 @@
;; EFFICIENCY: Maybe we should use another data structure than a
;; hash table for faster searching in the potentially relevant
;; transactions? An in-memory btree might be good...
- (or
- ;; Modified by the current-transaction itself? Then use that version.
- (transaction-changed-object current-transaction object-id)
- ;; Otherwise iterate over all open transactions, keeping track
- ;; of the best candidate.
- (let ((result-transaction nil)
- (result nil))
- (loop for transaction being the hash-value of (transactions cache)
- for object = (transaction-changed-object transaction object-id)
- when (and object
- (transaction-older-p transaction current-transaction)
- (or (null result-transaction)
- (transaction-older-p result-transaction transaction)))
- do (setf result-transaction transaction
- result object))
- result)))
+ (and current-transaction
+ (or
+ ;; Modified by the current-transaction itself? Then use that version.
+ (transaction-changed-object current-transaction object-id)
+ ;; Otherwise iterate over all open transactions, keeping track
+ ;; of the best candidate.
+ (let ((result-transaction nil)
+ (result nil))
+ (loop for transaction being the hash-value of (transactions cache)
+ for object = (transaction-changed-object transaction object-id)
+ when (and object
+ (transaction-older-p transaction current-transaction)
+ (or (null result-transaction)
+ (transaction-older-p result-transaction transaction)))
+ do (setf result-transaction transaction
+ result object))
+ result))))
--- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/09 13:23:18 1.17
+++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp 2006/08/24 15:21:25 1.18
@@ -1,4 +1,4 @@
-;; $Id: garbage-collector.lisp,v 1.17 2006/08/09 13:23:18 alemmens Exp $
+;; $Id: garbage-collector.lisp,v 1.18 2006/08/24 15:21:25 alemmens Exp $
(in-package :rucksack)
@@ -221,14 +221,21 @@
(loop until (or (eql (state heap) :ready) (<= amount 0))
do (ecase (state heap)
(:starting
- ;; We were not collecting garbage; start doing that now.
- (setf (nr-object-bytes-marked heap) 0
- (nr-heap-bytes-scanned heap) 0
- (nr-heap-bytes-sweeped heap) 0
- (nr-object-bytes-sweeped heap) 0
- ;; We don't need to copy the roots, because we're not
- ;; going to modify the list (just push and pop).
- (roots heap) (slot-value (rucksack heap) 'roots))
+ (let ((rucksack (rucksack heap)))
+ ;; We were not collecting garbage; start doing that now.
+ (setf (nr-object-bytes-marked heap) 0
+ (nr-heap-bytes-scanned heap) 0
+ (nr-heap-bytes-sweeped heap) 0
+ (nr-object-bytes-sweeped heap) 0
+ ;; We don't need to copy the roots, because we're not
+ ;; going to modify the list (just push and pop).
+ ;; But we do need to add the btrees for the class-index-table
+ ;; and slot-index-tables to the GC roots.
+ (roots heap) (append (and (slot-boundp rucksack 'class-index-table)
+ (list (slot-value rucksack 'class-index-table)))
+ (and (slot-boundp rucksack 'slot-index-tables)
+ (list (slot-value rucksack 'slot-index-tables)))
+ (slot-value (rucksack heap) 'roots))))
(setf (state heap) :marking-object-table))
(:marking-object-table
(decf amount (mark-some-objects-in-table heap amount)))
--- /project/rucksack/cvsroot/rucksack/make.lisp 2006/05/25 13:01:38 1.3
+++ /project/rucksack/cvsroot/rucksack/make.lisp 2006/08/24 15:21:25 1.4
@@ -1,4 +1,4 @@
-;; $Id: make.lisp,v 1.3 2006/05/25 13:01:38 alemmens Exp $
+;; $Id: make.lisp,v 1.4 2006/08/24 15:21:25 alemmens Exp $
(in-package :cl-user)
@@ -23,7 +23,7 @@
"index"
"rucksack"
"transactions"
- "test")
+ #+nil "test")
do (tagbody
:retry
(let ((lisp (make-pathname :name file
--- /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/10 12:36:16 1.8
+++ /project/rucksack/cvsroot/rucksack/objects.lisp 2006/08/24 15:21:25 1.9
@@ -1,4 +1,4 @@
-;; $Id: objects.lisp,v 1.8 2006/08/10 12:36:16 alemmens Exp $
+;; $Id: objects.lisp,v 1.9 2006/08/24 15:21:25 alemmens Exp $
(in-package :rucksack)
@@ -75,9 +75,9 @@
object)
(defun cache (object)
- (let ((rucksack (rucksack object)))
- (and rucksack
- (rucksack-cache (rucksack object)))))
+ (and (slot-boundp object 'rucksack)
+ (rucksack object)
+ (rucksack-cache (rucksack object))))
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; Low level persistent data structures.
--- /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/11 12:44:21 1.7
+++ /project/rucksack/cvsroot/rucksack/package.lisp 2006/08/24 15:21:25 1.8
@@ -1,4 +1,4 @@
-;; $Id: package.lisp,v 1.7 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: package.lisp,v 1.8 2006/08/24 15:21:25 alemmens Exp $
#-(or allegro lispworks sbcl openmcl)
(error "Unsupported implementation: ~A" (lisp-implementation-type))
@@ -68,7 +68,7 @@
;; Transactions
#:current-transaction
#:transaction-start #:transaction-commit #:transaction-rollback
- #:with-transaction
+ #:with-transaction #:*transaction*
#:transaction #:standard-transaction
#:transaction-start-1 #:transaction-commit-1
#:transaction-id
--- /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/11 12:44:21 1.10
+++ /project/rucksack/cvsroot/rucksack/rucksack.lisp 2006/08/24 15:21:25 1.11
@@ -1,4 +1,4 @@
-;; $Id: rucksack.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: rucksack.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $
(in-package :rucksack)
@@ -213,15 +213,64 @@
(defun process-lock (lock)
#+lispworks
(mp:process-lock lock)
- #-lispworks
+ #+sbcl
+ (sb-thread:get-mutex lock)
+ #-(or sbcl lispworks)
(not-implemented 'process-lock))
+
(defun process-unlock (lock)
#+lispworks
(mp:process-unlock lock)
- #-lispworks
+ #+sbcl
+ (sb-thread:release-mutex lock)
+ #-(or sbcl lispworks)
(not-implemented 'process-unlock))
+
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+;; WITH-TRANSACTION
+;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+
+;; It would be prettier if we could put this macro in TRANSACTIONS.LISP, but
+;; we need it here already.
+
+(defparameter *transaction* nil
+ "The currently active transaction.")
+
+(defmacro with-transaction ((&rest args
+ &key (rucksack '(current-rucksack))
+ &allow-other-keys)
+ &body body)
+ (let ((committed (gensym "COMMITTED"))
+ (transaction (gensym "TRANSACTION"))
+ (result (gensym "RESULT")))
+ `(let ((,transaction nil))
+ (loop named ,transaction do
+ (with-simple-restart (retry "Retry ~S" ,transaction)
+ (let ((,committed nil)
+ (,result nil))
+ (unwind-protect
+ (progn
+ ;; Use a local variable for the transaction so that nothing
+ ;; can replace it from underneath us, and only then bind
+ ;; it to *TRANSACTION*.
+ (setf ,transaction (transaction-start :rucksack ,rucksack
+ ,@(sans args :rucksack)))
+ (let ((*transaction* ,transaction))
+ (with-simple-restart (abort "Abort ~S" ,transaction)
+ (setf ,result (progn , at body))
+ (transaction-commit ,transaction)
+ (setf ,committed t)))
+ ;; Normal exit from the WITH-SIMPLE-RESTART above -- either
+ ;; everything went well or we aborted -- the ,COMMITTED will tell
+ ;; us. In either case we jump out of the RETRY loop.
+ (return-from ,transaction (values ,result ,committed)))
+ (unless ,committed
+ (transaction-rollback ,transaction)))))
+ ;; Normal exit from the above block -- we selected the RETRY restart.
+ ))))
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Rucksacks
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
@@ -239,16 +288,12 @@
from which the garbage collector can reach all live objects.")
(roots-changed-p :initform nil :accessor roots-changed-p)
;; Indexes
- (class-index-table :initform (make-hash-table)
- :documentation
- "A mapping from class names to indexes. Each index contains the ids
-of all instances from a class."
- :reader class-index-table)
- (slot-index-tables :initform (make-hash-table)
- :reader slot-index-tables
- :documentation
- "A mapping from class names to slot index tables, where each slot
-index table is a mapping from slot names to slot indexes. Each slot
+ (class-index-table :documentation
+ "A btree mapping class names to indexes. Each index contains the ids
+of all instances from a class.")
+ (slot-index-tables :documentation
+ "A btree mapping class names to slot index tables, where each slot
+index table is a btree mapping slot names to slot indexes. Each slot
index maps slot values to object ids.")))
(defmethod print-object ((rucksack rucksack) stream)
@@ -261,6 +306,43 @@
(merge-pathnames "roots" (rucksack-directory rucksack)))
+(defmethod class-index-table ((rucksack standard-rucksack))
+ ;; Create class-index-table if it doesn't exist yet.
+ (flet ((do-it ()
+ (unless (slot-boundp rucksack 'class-index-table)
+ (let ((btree (make-instance 'btree
+ :rucksack rucksack
+ :key< 'string<
+ :value= 'p-eql
+ :unique-keys-p t)))
+ (setf (slot-value rucksack 'class-index-table) (object-id btree))))
+ (cache-get-object (slot-value rucksack 'class-index-table)
+ (rucksack-cache rucksack))))
+ (if (current-transaction)
+ (do-it)
+ (with-transaction (:rucksack rucksack)
+ (do-it)))))
+
+
+(defmethod slot-index-tables ((rucksack standard-rucksack))
+ ;; Create slot-index-tables if they don't exist yet.
+ (flet ((do-it ()
+ (unless (slot-boundp rucksack 'slot-index-tables)
+ (let ((btree (make-instance 'btree
+ :rucksack rucksack
+ :key< 'string<
+ :value= 'p-eql
+ :unique-keys-p t)))
+ (setf (slot-value rucksack 'slot-index-tables) (object-id btree))))
+ ;;
+ (cache-get-object (slot-value rucksack 'slot-index-tables)
+ (rucksack-cache rucksack))))
+ (if (current-transaction)
+ (do-it)
+ (with-transaction (:rucksack rucksack)
+ (do-it)))))
+
+
(defmethod initialize-instance :after ((rucksack standard-rucksack)
&key
(cache-class 'standard-cache)
@@ -275,6 +357,7 @@
(load-roots rucksack))
+
(defun load-roots (rucksack)
;; Read roots (i.e. object ids) from the roots file (if there is one).
;; Also load the class and slot index tables.
@@ -282,18 +365,22 @@
(when (probe-file roots-file)
(destructuring-bind (root-list class-index slot-index)
(load-objects roots-file)
- (with-slots (roots class-index-table slot-index-tables)
+ (with-slots (roots class-index-table slot-index-tables cache)
rucksack
- (setf roots root-list
- class-index-table (maybe-dereference-proxy class-index)
- slot-index-tables (maybe-dereference-proxy slot-index))))))
+ (setf roots root-list)
+ (when class-index
+ (setf class-index-table class-index))
+ (when slot-index
+ (setf slot-index-tables slot-index))))))
rucksack)
(defun save-roots (rucksack)
(save-objects (list (slot-value rucksack 'roots)
- (class-index-table rucksack)
- (slot-index-tables rucksack))
+ (and (slot-boundp rucksack 'class-index-table)
+ (slot-value rucksack 'class-index-table))
+ (and (slot-boundp rucksack 'slot-index-tables)
+ (slot-value rucksack 'slot-index-tables)))
(rucksack-roots-pathname rucksack))
(setf (roots-changed-p rucksack) nil))
@@ -403,9 +490,11 @@
(rucksack-commit rucksack))
(defmethod rucksack-commit ((rucksack standard-rucksack))
- (cache-commit (rucksack-cache rucksack))
- (when (roots-changed-p rucksack)
- (save-roots rucksack)))
+ (when (or (roots-changed-p rucksack)
+ (not (slot-boundp rucksack 'class-index-table))
+ (not (slot-boundp rucksack 'slot-index-tables)))
+ (save-roots rucksack))
+ (cache-commit (rucksack-cache rucksack)))
;;
;; Rollback
@@ -550,13 +639,13 @@
&key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
- (when (and errorp (gethash class (class-index-table rucksack)))
+ (when (and errorp (btree-search (class-index-table rucksack) class
+ :errorp nil :default-value nil))
(simple-rucksack-error "Class index for ~S already exists in ~A."
class
rucksack))
(let ((index (rucksack-make-class-index rucksack class)))
- (setf (gethash class (class-index-table rucksack)) index)
- (add-rucksack-root index rucksack)
+ (btree-insert class index :if-exists :overwrite)
index))
(defmethod rucksack-make-class-index
@@ -571,14 +660,16 @@
&key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
- (when (and errorp
- (not (gethash class (class-index-table rucksack))))
- (simple-rucksack-error "Class index for ~S doesn't exist in ~A."
- class
- rucksack))
- (let ((index (gethash class (class-index-table rucksack))))
- (remhash class (class-index-table rucksack))
- (delete-rucksack-root index rucksack)))
+ (handler-bind ((btree-deletion-error
+ ;; Translate a btree error to something that makes more sense
+ ;; in this context.
+ (lambda (error)
+ (declare (ignore error))
+ (simple-rucksack-error "Class index for ~S doesn't exist in ~A."
+ class
+ rucksack))))
+ (btree-delete-key class
+ :if-does-not-exist (if errorp :error :ignore))))
(defmethod rucksack-map-class-indexes (rucksack function)
@@ -588,11 +679,19 @@
&key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
- (or (gethash class (class-index-table rucksack))
- (and errorp
- (simple-rucksack-error "Can't find class index for ~S in ~A."
- class
- rucksack))))
+ (and (slot-boundp rucksack 'class-index-table)
+ (handler-bind ((btree-search-error
+ ;; Translate a btree error to something that makes more sense
+ ;; in this context.
+ (lambda (error)
+ (declare (ignore error))
+ (simple-rucksack-error "Can't find class index for ~S in ~A."
+ class
+ rucksack))))
+ (btree-search (class-index-table rucksack) class
+ :errorp errorp
+ :default-value nil))))
+
(defmethod rucksack-maybe-index-new-object ((rucksack standard-rucksack)
class object)
@@ -640,67 +739,72 @@
;; Find the slot index table for CLASS, create a slot index and add that
;; index to the table.
(let* ((slot-index-tables (slot-index-tables rucksack))
- (slot-index-table (or (gethash class slot-index-tables)
- (let ((table (make-hash-table)))
- (setf (gethash class slot-index-tables) table)
- table)))
- (new-slot-index (make-index index-spec unique-p))
- (old-slot-index (gethash slot slot-index-table)))
- ;; Add a new slot index table if necessary.
- (when (and errorp old-slot-index)
- (simple-rucksack-error "Slot index for slot ~S of class ~S
+ (slot-index-table
+ (or (btree-search slot-index-tables class :errorp nil)
+ (let ((table (make-instance 'btree
+ :key< 'string<
+ :value= 'p-eql
+ :unique-keys-p t)))
+ (btree-insert table slot-index-tables :if-exists :error)
+ table)))
+ (new-slot-index (make-index index-spec unique-p)))
+ (handler-bind ((btree-key-already-present-error
+ (lambda (error)
+ (declare (ignore error))
+ (simple-rucksack-error "Slot index for slot ~S of class ~S
already exists in ~A."
- slot
- class
- rucksack))
- (add-rucksack-root new-slot-index rucksack)
- (when old-slot-index
- (delete-rucksack-root old-slot-index rucksack))
- (setf (gethash slot slot-index-table) new-slot-index)))
+ slot
+ class
+ rucksack))))
+ (btree-insert slot slot-index-table new-slot-index
+ :if-exists (if errorp :error :overwrite)))
+ new-slot-index))
+
(defmethod rucksack-remove-slot-index (rucksack class slot &key (errorp nil))
(unless (symbolp class)
(setq class (class-name class)))
(unless (symbolp slot)
(setq slot (slot-definition-name slot)))
- (flet ((oops ()
+ (flet ((oops (error)
+ (declare (ignore error))
(simple-rucksack-error "Attempt to remove non-existing slot
index for slot ~S of class ~S in ~A."
slot
class
rucksack)))
- (let ((slot-index-table (gethash class (slot-index-tables rucksack))))
- (if slot-index-table
- (if errorp
- (let ((index (gethash slot slot-index-table)))
- (if index
- (progn
- (remhash slot slot-index-table)
- (delete-rucksack-root index rucksack))
- (oops)))
- (remhash slot slot-index-table))
- (and errorp (oops))))))
+ ;; Return the slot name if everything went fine; otherwise, return
+ ;; NIL (or signal an error).
+ (and (handler-bind ((btree-search-error #'oops))
+
+ (let ((slot-index-table (btree-search (slot-index-tables rucksack) class
+ :errorp errorp)))
+ (handler-bind ((btree-deletion-error #'oops))
+ (btree-delete-key slot slot-index-table
+ :if-does-not-exist (if errorp :error :ignore)))))
+ slot)))
(defmethod rucksack-map-slot-indexes ((rucksack standard-rucksack) function
&key (class t) (include-subclasses t))
(if (eql class t)
- (maphash (lambda (class slot-index-table)
- (maphash (lambda (slot slot-index)
- (funcall function class slot slot-index))
- slot-index-table))
- (slot-index-tables rucksack))
+ (map-btree (slot-index-tables rucksack)
+ (lambda (class slot-index-table)
+ (map-btree slot-index-table
+ (lambda (slot slot-index)
+ (funcall function class slot slot-index)))))
(let ((visited-p (make-hash-table)))
(flet ((map-indexes (class)
(unless (gethash class visited-p)
- (let ((slot-index-table (gethash (class-name class)
- (slot-index-tables rucksack))))
+ (let ((slot-index-table (btree-search (slot-index-tables rucksack)
+ (class-name class)
+ :errorp nil)))
(when slot-index-table
- (maphash (lambda (slot slot-index)
- (funcall function (class-name class)
- slot
- slot-index))
- slot-index-table)))
+ (map-btree slot-index-table
+ (lambda (slot slot-index)
+ (funcall function (class-name class)
+ slot
+ slot-index)))))
(setf (gethash class visited-p) t)
(when include-subclasses
(mapc #'map-indexes
@@ -728,12 +832,12 @@
(setq slot (slot-definition-name slot)))
(let ((slot-index-tables (slot-index-tables rucksack)))
(flet ((find-index (class)
- (let ((slot-index-table (gethash class slot-index-tables)))
+ (let ((slot-index-table (btree-search slot-index-tables class
+ :errorp nil)))
(and slot-index-table
- (gethash slot slot-index-table)))))
+ (btree-search slot-index-table slot :errorp nil)))))
(or (find-index class)
- (loop for superclass in (class-precedence-list
- (find-class class))
+ (loop for superclass in (class-precedence-list (find-class class))
thereis (find-index (class-name superclass)))
(and errorp
(simple-rucksack-error
--- /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/11 12:44:21 1.6
+++ /project/rucksack/cvsroot/rucksack/serialize.lisp 2006/08/24 15:21:25 1.7
@@ -1,4 +1,4 @@
-;; $Id: serialize.lisp,v 1.6 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: serialize.lisp,v 1.7 2006/08/24 15:21:25 alemmens Exp $
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Serialize
@@ -1124,6 +1124,11 @@
do (scan serializer gc))))
+(defmethod scan-contents ((marker (eql +unbound-slot+)) serializer gc)
+ ;; Just skip the marker and continue.
+ :do-nothing)
+
+
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Structures
;;;
--- /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/11 12:44:21 1.10
+++ /project/rucksack/cvsroot/rucksack/test.lisp 2006/08/24 15:21:25 1.11
@@ -1,4 +1,4 @@
-;; $Id: test.lisp,v 1.10 2006/08/11 12:44:21 alemmens Exp $
+;; $Id: test.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $
(in-package :test-rucksack)
@@ -26,7 +26,7 @@
(defclass p-thing-1 ()
()
(:metaclass persistent-class))
-
+
(defclass p-thing-2 ()
((x :initarg :x :reader x-of :persistence t))
(:metaclass persistent-class))
@@ -258,7 +258,7 @@
(format t "~&Deleting~%")
(let ((btree (first (rucksack-roots rucksack))))
(dotimes (i delete)
- (when (zerop (mod (1+ i) 1000))
+ (when (zerop (mod (1+ i) 100))
(format t "~D " (1+ i)))
(btree-delete-key btree (aref array i)))
(check-order btree)
--- /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/10 12:36:17 1.10
+++ /project/rucksack/cvsroot/rucksack/transactions.lisp 2006/08/24 15:21:25 1.11
@@ -1,4 +1,4 @@
-;; $Id: transactions.lisp,v 1.10 2006/08/10 12:36:17 alemmens Exp $
+;; $Id: transactions.lisp,v 1.11 2006/08/24 15:21:25 alemmens Exp $
(in-package :rucksack)
@@ -58,8 +58,6 @@
(transaction-id transaction)
(hash-table-count (dirty-objects transaction)))))
-(defparameter *transaction* nil
- "The currently active transaction.")
(defun current-transaction ()
*transaction*)
@@ -181,45 +179,48 @@
(cache standard-cache)
(rucksack standard-rucksack))
;; Save all dirty objects to disk.
- ;; 1. Create the commit file
- (create-commit-file transaction cache)
- ;; 2. Commit all dirty objects.
- ;; Q: What if this is interleaved with other commits?
- (let ((queue (dirty-queue transaction))
- (table (dirty-objects transaction))
- (heap (heap cache))
- nr-allocated-octets)
- (with-allocation-counter (heap)
- (loop until (queue-empty-p queue)
- do (let* ((id (queue-remove queue))
- (object (gethash id table)))
- (when object
- ;; If it's not in the dirty-objects table anymore, the
- ;; object was already saved during this transaction-commit.
- ;; That's possible, because the queue can contain duplicates.
- (save-dirty-object object cache transaction id)
- ;; Remove from hash-table too.
- (remhash id table))))
- (setq nr-allocated-octets (nr-allocated-octets heap)))
- ;; Check for consistency between hash table and queue.
- (unless (zerop (hash-table-count table))
- (internal-rucksack-error
- "Mismatch between dirty hash-table and queue while committing ~S:
+ (if (zerop (transaction-nr-dirty-objects transaction))
+ (close-transaction cache transaction)
+ (progn
+ ;; 1. Create the commit file
+ (create-commit-file transaction cache)
+ ;; 2. Commit all dirty objects.
+ ;; Q: What if this is interleaved with other commits?
+ (let ((queue (dirty-queue transaction))
+ (table (dirty-objects transaction))
+ (heap (heap cache))
+ nr-allocated-octets)
+ (with-allocation-counter (heap)
+ (loop until (queue-empty-p queue)
+ do (let* ((id (queue-remove queue))
+ (object (gethash id table)))
+ (when object
+ ;; If it's not in the dirty-objects table anymore, the
+ ;; object was already saved during this transaction-commit.
+ ;; That's possible, because the queue can contain duplicates.
+ (save-dirty-object object cache transaction id)
+ ;; Remove from hash-table too.
+ (remhash id table))))
+ (setq nr-allocated-octets (nr-allocated-octets heap)))
+ ;; Check for consistency between hash table and queue.
+ (unless (zerop (hash-table-count table))
+ (internal-rucksack-error
+ "Mismatch between dirty hash-table and queue while committing ~S:
~D objects left in hash-table."
- transaction
- (hash-table-count table)))
- ;; 3. Remove transaction from the cache's open transactions.
- (close-transaction cache transaction)
- ;; 4. Delete the commit file to indicate that everything went fine
- ;; and we don't need to recover from this commit.
- (delete-commit-file transaction cache)
- ;; 5. Let the garbage collector do an amount of work proportional
- ;; to the number of octets that were allocated during the commit.
- (collect-some-garbage heap
- (gc-work-for-size heap nr-allocated-octets))
- ;; 6. Make sure that all changes are actually on disk before
- ;; we continue.
- (finish-all-output rucksack)))
+ transaction
+ (hash-table-count table)))
+ ;; 3. Remove transaction from the cache's open transactions.
+ (close-transaction cache transaction)
+ ;; 4. Delete the commit file to indicate that everything went fine
+ ;; and we don't need to recover from this commit.
+ (delete-commit-file transaction cache)
+ ;; 5. Let the garbage collector do an amount of work proportional
+ ;; to the number of octets that were allocated during the commit.
+ (collect-some-garbage heap
+ (gc-work-for-size heap nr-allocated-octets))
+ ;; 6. Make sure that all changes are actually on disk before
+ ;; we continue.
+ (finish-all-output rucksack)))))
(defmethod finish-all-output ((rucksack standard-rucksack))
(let ((cache (rucksack-cache rucksack)))
@@ -362,42 +363,6 @@
(close-transaction cache transaction))
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-;; WITH-TRANSACTION
-;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
-
-(defmacro with-transaction ((&rest args
- &key (rucksack '(current-rucksack))
- &allow-other-keys)
- &body body)
- (let ((committed (gensym "COMMITTED"))
- (transaction (gensym "TRANSACTION"))
- (result (gensym "RESULT")))
- `(let ((,transaction nil))
- (loop named ,transaction do
- (with-simple-restart (retry "Retry ~S" ,transaction)
- (let ((,committed nil)
- (,result nil))
- (unwind-protect
- (progn
- ;; Use a local variable for the transaction so that nothing
- ;; can replace it from underneath us, and only then bind
- ;; it to *TRANSACTION*.
- (setf ,transaction (transaction-start :rucksack ,rucksack
- ,@(sans args :rucksack)))
- (let ((*transaction* ,transaction))
- (with-simple-restart (abort "Abort ~S" ,transaction)
- (setf ,result (progn , at body))
- (transaction-commit ,transaction)
- (setf ,committed t)))
- ;; Normal exit from the WITH-SIMPLE-RESTART above -- either
- ;; everything went well or we aborted -- the ,COMMITTED will tell
- ;; us. In either case we jump out of the RETRY loop.
- (return-from ,transaction (values ,result ,committed)))
- (unless ,committed
- (transaction-rollback ,transaction)))))
- ;; Normal exit from the above block -- we selected the RETRY restart.
- ))))
More information about the rucksack-cvs
mailing list