From: Nikodemus Siivola <nikodemus@random-state.net>
Date: Fri, 3 Nov 2006 19:53:59 +0000 (+0000)
Subject: 0.9.18.31: room fix
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d8a6359622d77e002c11e13362d4e174b3fe4004;p=sbcl.git

0.9.18.31: room fix
 * Type-error: SHIFT in VECTOR-TOTAL-SIZE had a bogus declaration,
   masked by SAFETY 0. Remove the offending declaration and increase
   safety.
 * A more aggressive ROOM test.
---

diff --git a/src/code/room.lisp b/src/code/room.lisp
index ea2f309..6102f23 100644
--- a/src/code/room.lisp
+++ b/src/code/room.lisp
@@ -193,16 +193,12 @@
                 (ecase (room-info-kind info)
                   (:vector 0)
                   (:string 1)))))
-    (declare (type (integer -3 3) shift))
     (round-to-dualword
      (+ (* vector-data-offset n-word-bytes)
-        (the fixnum
-             (if (minusp shift)
-                 (ash (the fixnum
-                           (+ len (the fixnum
-                                       (1- (the fixnum (ash 1 (- shift)))))))
-                      shift)
-                 (ash len shift)))))))
+        (if (minusp shift)
+            (ash (+ len (1- (ash 1 (- shift))))
+                 shift)
+            (ash len shift))))))
 
 ;;; Access to the GENCGC page table for better precision in
 ;;; MAP-ALLOCATED-OBJECTS
@@ -216,11 +212,7 @@
               (gen (signed 8))))
   (declaim (inline find-page-index))
   (define-alien-routine "find_page_index" long (index long))
-  (define-alien-variable "page_table"
-      (array (struct page)
-             #.(truncate (- dynamic-space-end
-                            dynamic-space-start)
-                         sb!vm:gencgc-page-size))))
+  (define-alien-variable "page_table" (* (struct page))))
 
 ;;; Iterate over all the objects allocated in SPACE, calling FUN with
 ;;; the object, the object's type code, and the object's total size in
@@ -231,7 +223,7 @@
   (without-gcing
    (multiple-value-bind (start end) (space-bounds space)
      (declare (type system-area-pointer start end))
-     (declare (optimize (speed 3) (safety 0)))
+     (declare (optimize (speed 3)))
      (let ((current start)
            #!+gencgc (skip-tests-until-addr 0))
        (labels ((maybe-finish-mapping ()
@@ -355,7 +347,7 @@
         (counts (make-array 256 :initial-element 0 :element-type 'fixnum)))
     (map-allocated-objects
      (lambda (obj type size)
-       (declare (fixnum size) (optimize (speed 3) (safety 0)) (ignore obj))
+       (declare (fixnum size) (optimize (speed 3)) (ignore obj))
        (incf (aref sizes type) size)
        (incf (aref counts type)))
      space)
@@ -494,7 +486,7 @@
              (type unsigned-byte total-bytes))
     (map-allocated-objects
      (lambda (obj type size)
-       (declare (fixnum size) (optimize (safety 0)))
+       (declare (fixnum size))
        (when (eql type code-header-widetag)
          (incf total-bytes size)
          (let ((words (truly-the fixnum (%code-code-size obj)))
@@ -523,7 +515,7 @@
       (declare (inline map-allocated-objects))
       (map-allocated-objects
        (lambda (obj type size)
-         (declare (fixnum size) (optimize (safety 0)))
+         (declare (fixnum size))
          (case type
            (#.code-header-widetag
             (let ((inst-words (truly-the fixnum (%code-code-size obj))))
@@ -593,7 +585,7 @@
     (declare (fixnum total-objects total-bytes))
     (map-allocated-objects
      (lambda (obj type size)
-       (declare (fixnum size) (optimize (speed 3) (safety 0)))
+       (declare (fixnum size) (optimize (speed 3)))
        (when (eql type instance-header-widetag)
          (incf total-objects)
          (incf total-bytes size)
@@ -664,7 +656,6 @@
                    (note-conses (cdr x)))))
         (map-allocated-objects
          (lambda (obj obj-type size)
-           (declare (optimize (safety 0)))
            (let ((addr (get-lisp-obj-address obj)))
              (when (>= addr start)
                (when (if count
@@ -745,7 +736,6 @@
     (let ((res ()))
       (map-allocated-objects
        (lambda (obj obj-type size)
-         (declare (optimize (safety 0)))
          (when (and (or (not type) (eql obj-type type))
                     (or (not smaller) (<= size smaller))
                     (or (not larger) (>= size larger))
@@ -765,7 +755,7 @@
              (funcall fun obj))))
     (map-allocated-objects
      (lambda (obj obj-type size)
-       (declare (optimize (safety 0)) (ignore obj-type size))
+       (declare (ignore obj-type size))
        (typecase obj
          (cons
           (when (or (eq (car obj) object)
diff --git a/src/runtime/coreparse.c b/src/runtime/coreparse.c
index 00598c5..ae429b4 100644
--- a/src/runtime/coreparse.c
+++ b/src/runtime/coreparse.c
@@ -140,13 +140,13 @@ process_directory(int fd, u32 *ptr, int count, os_vm_offset_t file_offset)
 
         switch (id) {
         case DYNAMIC_CORE_SPACE_ID:
-	    if (len > dynamic_space_size) {
+            if (len > dynamic_space_size) {
                 fprintf(stderr,
                         "dynamic space too small for core: %ldKiB required, %ldKiB available.\n",
                         len >> 10,
                         (long)dynamic_space_size >> 10);
                 exit(1);
-            }		
+            }
 #ifdef LISP_FEATURE_GENCGC
             if (addr != (os_vm_address_t)DYNAMIC_SPACE_START) {
                 fprintf(stderr, "in core: 0x%lx; in runtime: 0x%lx \n",
@@ -161,8 +161,8 @@ process_directory(int fd, u32 *ptr, int count, os_vm_offset_t file_offset)
                         (long)DYNAMIC_0_SPACE_START,
                         (long)DYNAMIC_1_SPACE_START);
                 lose("warning: core/runtime address mismatch: DYNAMIC_SPACE_START\n");
-            }	    
-#endif	    
+            }
+#endif
 #if defined(ALLOCATION_POINTER)
             SetSymbolValue(ALLOCATION_POINTER, (lispobj)free_pointer,0);
 #else
diff --git a/version.lisp-expr b/version.lisp-expr
index baf6bd0..aad4101 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.9.18.30"
+"0.9.18.31"