From 8ef3aa533aba5ac5760e83b798cd6b2388a807a6 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Sun, 20 Nov 2005 19:40:02 +0000 Subject: [PATCH] 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 --- src/code/array.lisp | 26 ++++++++++++++++++++++---- src/code/filesys.lisp | 4 ++-- src/code/seq.lisp | 4 ++-- src/code/stream.lisp | 4 ++-- src/code/target-hash-table.lisp | 8 ++++---- src/compiler/generic/vm-tran.lisp | 2 ++ src/pcl/gray-streams.lisp | 4 ++-- tests/threads.impure.lisp | 2 +- version.lisp-expr | 2 +- 9 files changed, 38 insertions(+), 18 deletions(-) diff --git a/src/code/array.lisp b/src/code/array.lisp index 9b8088a..d1e06bb 100644 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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 --- 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" -- 1.7.10.4