0.9.6.53: in the name of stability and goodwill

  * SHRINK-VECTOR is now safe wrt to gcing: it returns a new vector
    if needed, only shrinks arrays with fill pointers destructively.
  * %SHRINK-VECTOR is what SHRINK-VECTOR used to be, an unsafe
    performance hack for the case where the vector cannot be accessed
    from interrupts/other threads.
  * don't call %ARRAY-DISPLACED-P on vectors

diff --git a/src/code/array.lisp b/src/code/array.lisp
index 9b8088a..d1e06bb 100644 (file)
--- a/src/code/array.lisp
+++ b/src/code/array.lisp
@@ -825,7 +825,8 @@ of specialized arrays is supported."
                (declare (fixnum old-length new-length))
                (with-array-data ((old-data array) (old-start)
                                  (old-end old-length))
-                 (cond ((or (%array-displaced-p array)
+                 (cond ((or (and (array-header-p array)
+                                 (%array-displaced-p array))
                             (< old-length new-length))
                         (setf new-data
                               (data-vector-from-inits
@@ -849,7 +850,8 @@ of specialized arrays is supported."
                (with-array-data ((old-data array) (old-start)
                                  (old-end old-length))
                  (declare (ignore old-end))
-                 (let ((new-data (if (or (%array-displaced-p array)
+                 (let ((new-data (if (or (and (array-header-p array)
+                                              (%array-displaced-p array))
                                          (> new-length old-length))
                                      (data-vector-from-inits
                                       dimensions new-length
@@ -900,8 +902,12 @@ of specialized arrays is supported."
                 fill-pointer))))
 
 ;;; Destructively alter VECTOR, changing its length to NEW-LENGTH,
-;;; which must be less than or equal to its current length.
-(defun shrink-vector (vector new-length)
+;;; which must be less than or equal to its current length. This can
+;;; be called on vectors without a fill pointer but it is extremely
+;;; dangerous to do so: shrinking the size of an object (as viewed by
+;;; the gc) makes bounds checking unreliable in the face of interrupts
+;;; or multi-threading. Call it only on provably local vectors.
+(defun %shrink-vector (vector new-length)
   (declare (vector vector))
   (unless (array-header-p vector)
     (macrolet ((frob (name &rest things)
@@ -915,6 +921,10 @@ of specialized arrays is supported."
                                           ,fill-value
                                           :start new-length))))
                               things))))
+      ;; Set the 'tail' of the vector to the appropriate type of zero,
+      ;; "because in some cases we'll scavenge larger areas in one go,
+      ;; like groups of pages that had triggered the write barrier, or
+      ;; the whole static space" according to jsnell.
       #.`(frob vector
           ,@(map 'list
                  (lambda (saetp)
@@ -932,6 +942,14 @@ of specialized arrays is supported."
   (setf (%array-fill-pointer vector) new-length)
   vector)
 
+(defun shrink-vector (vector new-length)
+  (declare (vector vector))
+  (cond ((eq (length vector) new-length)
+         vector)
+        ((array-has-fill-pointer-p vector)
+         (setf (%array-fill-pointer vector) new-length))
+        (t (subseq vector 0 new-length))))
+
 ;;; Fill in array header with the provided information, and return the array.
 (defun set-array-header (array data length fill-pointer displacement dimensions
                          &optional displacedp)

diff --git a/src/code/filesys.lisp b/src/code/filesys.lisp
index f916cce..28b09c9 100644 (file)
--- a/src/code/filesys.lisp
+++ b/src/code/filesys.lisp
@@ -75,7 +75,7 @@
              :complaint "backslash in a bad place"
              :namestring namestr
              :offset (1- end)))
-    (shrink-vector result dst)))
+    (%shrink-vector result dst)))
 
 (defvar *ignore-wildcards* nil)
 
@@ -652,7 +652,7 @@
               ((zerop q)
                (incf i)
                (replace res res :start2 i :end2 len)
-               (shrink-vector res (- len i)))
+               (%shrink-vector res (- len i)))
            (declare (simple-string res)
                     (fixnum len i r q))
            (multiple-value-setq (q r) (truncate q 10))

diff --git a/src/code/seq.lisp b/src/code/seq.lisp
index 64075ab..a994632 100644 (file)
--- a/src/code/seq.lisp
+++ b/src/code/seq.lisp
@@ -1383,7 +1383,7 @@
             (= number-zapped count))
         (do ((index index (,bump index))
              (new-index new-index (,bump new-index)))
-            ((= index (the fixnum ,right)) (shrink-vector result new-index))
+            ((= index (the fixnum ,right)) (%shrink-vector result new-index))
           (declare (fixnum index new-index))
           (setf (aref result new-index) (aref sequence index))))
      (declare (fixnum index new-index number-zapped))
@@ -1665,7 +1665,7 @@
       (setf (aref result jndex) (aref vector index))
       (setq index (1+ index))
       (setq jndex (1+ jndex)))
-    (shrink-vector result jndex)))
+    (%shrink-vector result jndex)))
 
 (define-sequence-traverser remove-duplicates
     (sequence &key test test-not start end from-end key)

diff --git a/src/code/stream.lisp b/src/code/stream.lisp
index b2ea43d..1e6dcdc 100644 (file)
--- a/src/code/stream.lisp
+++ b/src/code/stream.lisp
@@ -248,7 +248,7 @@
            (cond (ch
                   (when (char= ch #\newline)
                     (done-with-fast-read-char)
-                    (return (values (shrink-vector res index) nil)))
+                    (return (values (%shrink-vector res index) nil)))
                   (when (= index len)
                     (setq len (* len 2))
                     (let ((new (make-string len)))
@@ -266,7 +266,7 @@
                  ;; shouldn't do another READ-CHAR.
                  (t
                   (done-with-fast-read-char)
-                  (return (values (shrink-vector res index) t)))))))))
+                  (return (values (%shrink-vector res index) t)))))))))
 
 (defun read-line (&optional (stream *standard-input*) (eof-error-p t) eof-value
                             recursive-p)

diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index 0eb63f5..83fd171 100644 (file)
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -343,11 +343,11 @@
     (setf (hash-table-next-vector table) new-next-vector)
     (setf (hash-table-hash-vector table) new-hash-vector)
     ;; Shrink the old vectors to 0 size to help the conservative GC.
-    (shrink-vector old-kv-vector 0)
-    (shrink-vector old-index-vector 0)
-    (shrink-vector old-next-vector 0)
+    (%shrink-vector old-kv-vector 0)
+    (%shrink-vector old-index-vector 0)
+    (%shrink-vector old-next-vector 0)
     (when old-hash-vector
-      (shrink-vector old-hash-vector 0))
+      (%shrink-vector old-hash-vector 0))
     (setf (hash-table-rehash-trigger table) new-size))
   (values))
 

diff --git a/src/compiler/generic/vm-tran.lisp b/src/compiler/generic/vm-tran.lisp
index 2542c12..4d29fcf 100644 (file)
--- a/src/compiler/generic/vm-tran.lisp
+++ b/src/compiler/generic/vm-tran.lisp
@@ -79,6 +79,8 @@
                 `(the ,(type-specifier declared-element-ctype)
                       ,bare-form)))))))
 
+;;; Transform multi-dimensional to one dimensional SIMPLE-ARRAY
+;;; access.
 (deftransform data-vector-ref ((array index)
                                (simple-array t))
   (let ((array-type (lvar-type array)))

diff --git a/src/pcl/gray-streams.lisp b/src/pcl/gray-streams.lisp
index 873bf38..28ed0f1 100644 (file)
--- a/src/pcl/gray-streams.lisp
+++ b/src/pcl/gray-streams.lisp
@@ -229,10 +229,10 @@
     (loop
      (let ((ch (stream-read-char stream)))
        (cond ((eq ch :eof)
-              (return (values (shrink-vector res index) t)))
+              (return (values (%shrink-vector res index) t)))
              (t
               (when (char= ch #\newline)
-                (return (values (shrink-vector res index) nil)))
+                (return (values (%shrink-vector res index) nil)))
               (when (= index len)
                 (setq len (* len 2))
                 (let ((new (make-string len)))

diff --git a/tests/threads.impure.lisp b/tests/threads.impure.lisp
index 5d1a380..ddff614 100644 (file)
--- a/tests/threads.impure.lisp
+++ b/tests/threads.impure.lisp
@@ -496,7 +496,7 @@
 
 (defun send-gc ()
   (loop until (< *n-gcs-done* *n-gcs-requested*))
-  (format t "G" *n-gcs-requested* *n-gcs-done*)
+  (format t "G")
   (force-output)
   (sb-ext:gc)
   (incf *n-gcs-done*))

diff --git a/version.lisp-expr b/version.lisp-expr
index 4a5bdb2..363b9f6 100644 (file)
--- 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.6.52"
+"0.9.6.53"