[rucksack-cvs] CVS rucksack

[alemmens]

Update of /project/rucksack/cvsroot/rucksack
In directory clnet:/tmp/cvs-serv11379

Modified Files:
	cache.lisp garbage-collector.lisp heap.lisp serialize.lisp 
Log Message:
Replace free-list-full by free-list-empty. Fix bug in find-block. (From Edi Weitz)


--- /project/rucksack/cvsroot/rucksack/cache.lisp	2006/05/20 21:16:58	1.5
+++ /project/rucksack/cvsroot/rucksack/cache.lisp	2006/08/03 10:59:52	1.6
@@ -1,4 +1,4 @@
-;; $Id: cache.lisp,v 1.5 2006/05/20 21:16:58 alemmens Exp $
+;; $Id: cache.lisp,v 1.6 2006/08/03 10:59:52 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -202,7 +202,8 @@
 ;;
 
 (defmethod cache-create-object (object (cache standard-cache))
-  ;; This is called by an after method on initialize-instance.
+  ;; 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)
--- /project/rucksack/cvsroot/rucksack/garbage-collector.lisp	2006/05/24 20:45:09	1.10
+++ /project/rucksack/cvsroot/rucksack/garbage-collector.lisp	2006/08/03 10:59:52	1.11
@@ -1,4 +1,4 @@
-;; $Id: garbage-collector.lisp,v 1.10 2006/05/24 20:45:09 alemmens Exp $
+;; $Id: garbage-collector.lisp,v 1.11 2006/08/03 10:59:52 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -283,10 +283,11 @@
 (defmethod mark-root ((heap mark-and-sweep-heap) (object-id integer))
   ;; Returns the number of octets scanned.
   (let ((object-table (object-table heap)))
-    (if (eql (object-info object-table object-id) :reserved)
+    (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
+        ;; 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)))
--- /project/rucksack/cvsroot/rucksack/heap.lisp	2006/05/24 20:45:09	1.6
+++ /project/rucksack/cvsroot/rucksack/heap.lisp	2006/08/03 10:59:52	1.7
@@ -1,4 +1,4 @@
-;; $Id: heap.lisp,v 1.6 2006/05/24 20:45:09 alemmens Exp $
+;; $Id: heap.lisp,v 1.7 2006/08/03 10:59:52 alemmens Exp $
 
 (in-package :rucksack)
 
@@ -220,8 +220,8 @@
         ;; Keep copy in memory
         (aref (slot-value heap 'starts) size-class) pointer))
 
-(defmethod free-list-full-p (size-class (heap free-list-heap))
-  ;; A free list is full when the start points to itself.
+(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))))
 
@@ -283,8 +283,8 @@
   ;; 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 full.
-    (when (free-list-full-p size-class heap)
+    ;; 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 nil)))
@@ -304,7 +304,7 @@
   ;; 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-full-p size-class 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)
@@ -351,9 +351,7 @@
           do (let ((block (allocate-block heap :size min-size :expand nil)))
                (when block
                  (return (values block
-                                 (size-class-block-size size-class heap))))))
-    ;; Return nil if we can't find anything.
-    nil))
+                                 (size-class-block-size size-class heap))))))))
 
 
 (defmethod carve-up-block-for-free-list (size-class block size
@@ -393,9 +391,9 @@
 (defmethod heap-info ((heap free-list-heap))
   ;; Returns the total number of free octets in the heap.
   ;; As a second value it returns a list with, for each free list
-  ;; that is not full, a plist with info about that free list.
+  ;; that is not empty, a plist with info about that free list.
   (let* ((info (loop for size-class below (nr-free-lists heap)
-                     unless (free-list-full-p size-class heap)
+                     unless (free-list-empty-p size-class heap)
                      collect (free-list-info size-class heap)))
          (total (loop for plist in info
                       sum (getf plist :nr-free-octets))))
--- /project/rucksack/cvsroot/rucksack/serialize.lisp	2006/05/18 12:46:57	1.3
+++ /project/rucksack/cvsroot/rucksack/serialize.lisp	2006/08/03 10:59:52	1.4
@@ -1,4 +1,4 @@
-;; $Id: serialize.lisp,v 1.3 2006/05/18 12:46:57 alemmens Exp $
+;; $Id: serialize.lisp,v 1.4 2006/08/03 10:59:52 alemmens Exp $
 
 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 ;;; Serialize
@@ -954,8 +954,7 @@
       array)))
 
 (defmethod scan-contents ((marker (eql +array+)) stream gc)
-  ;; Scan type
-  (scan stream gc)
+  (scan stream gc) ; scan type
   (let ((dimensions (deserialize-list stream)))
     (when (= 1 (length dimensions))
       (let ((has-fill-pointer-p (deserialize stream)))