From: Nikodemus Siivola Date: Thu, 11 Mar 2010 10:11:44 +0000 (+0000) Subject: 1.0.36.18: remove *MERGE-SORT-TEMP-VECTOR* and *ZAP-ARRAY-DATA-TEMP* X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=d4a07c5481b3a0692963e018753089f1e5203d10;p=sbcl.git 1.0.36.18: remove *MERGE-SORT-TEMP-VECTOR* and *ZAP-ARRAY-DATA-TEMP* * STABLE-SORT no longer uses a pre-allocated temporary vector, but rather allocates it as-required. Based on patch by: Keith James * ADJUST-ARRAY no longer uses a pre-allocated temporary vector, but rather allocates is as-required. In both cases after the temporary vector is done with, it is truncated to 0-length to prevent garbage retention. Fixes Launchpad bug #496249. --- diff --git a/NEWS b/NEWS index 9630737..1ed9aa5 100644 --- a/NEWS +++ b/NEWS @@ -10,6 +10,8 @@ changes relative to sbcl-1.0.36: for accessing such arrays. * optimization: passing NIL as the environment argument to TYPEP no longer inhibits optimizing it. (lp#309788) + * optimization: ADJUST-ARRAY and STABLE-SORT on vectors no longer use + pre-allocated temporary vectors. (lp#496249) * bug fix: Fix compiler error involving MAKE-ARRAY and IF forms in :INITIAL-CONTENTS. (lp#523612) * bug fix: FUNCTION-LAMBDA-EXPRESSION lost declarations from interpreted diff --git a/doc/internals-notes/threading-specials b/doc/internals-notes/threading-specials index 56895e7..4b4cfd3 100644 --- a/doc/internals-notes/threading-specials +++ b/doc/internals-notes/threading-specials @@ -1017,7 +1017,6 @@ SB-IMPL::*INTEGER-READER-SAFE-DIGITS* SB-IMPL::*TIMEZONE-TABLE* SB-IMPL::*BQ-COMMA-FLAG* ; readonly SB-IMPL::*PRINT-OBJECT-IS-DISABLED-P* -SB-IMPL::*MERGE-SORT-TEMP-VECTOR* ; safe, allocated per-thread SB-IMPL::*PROFILE-HASH-CACHE* SB-IMPL::*FIXNUM-POWER--1* SB-IMPL::*SHARP-EQUAL-CIRCLE-TABLE* @@ -1030,7 +1029,6 @@ SB-IMPL::*CLOSE-IN-PARENT* SB-IMPL::*IN-COMPILATION-UNIT* SB-IMPL::*CIRCULARITY-HASH-TABLE* SB-IMPL::*LOAD-PRINT-STUFF* -SB-IMPL::*ZAP-ARRAY-DATA-TEMP* ; safe, allocated per-thread SB-IMPL::*ACTIVE-PROCESSES* SB-IMPL::*SHARP-SHARP-ALIST* SB-IMPL::*BASE-POWER* diff --git a/src/code/array.lisp b/src/code/array.lisp index b46b1ff..8f3f133 100644 --- a/src/code/array.lisp +++ b/src/code/array.lisp @@ -1170,44 +1170,17 @@ function to be removed without further warning." (%array-data-vector array)) array))) -;;;; used by SORT - -;;; temporary vector for stable sorting vectors, allocated for each new thread -(defvar *merge-sort-temp-vector* (vector)) -(declaim (simple-vector *merge-sort-temp-vector*)) ;;;; ZAP-ARRAY-DATA for ADJUST-ARRAY -;;; a temporary to be used when OLD-DATA and NEW-DATA are EQ. -;;; KLUDGE: Boy, DYNAMIC-EXTENT would be nice. This is rebound -;;; to length zero array in each new thread. -;;; -;;; DX is probably a bad idea, because a with a big array it would -;;; be fairly easy to blow the stack. -(defvar *zap-array-data-temp* (vector)) -(declaim (simple-vector *zap-array-data-temp*)) - -(defun zap-array-data-temp (length initial-element initial-element-p) - (declare (fixnum length)) - (let ((tmp *zap-array-data-temp*)) - (declare (simple-vector tmp)) - (cond ((> length (length tmp)) - (setf *zap-array-data-temp* - (if initial-element-p - (make-array length :initial-element initial-element) - (make-array length)))) - (initial-element-p - (fill tmp initial-element :end length)) - (t - tmp)))) - ;;; This does the grinding work for ADJUST-ARRAY. It zaps the data ;;; from the OLD-DATA in an arrangement specified by the OLD-DIMS to ;;; the NEW-DATA in an arrangement specified by the NEW-DIMS. OFFSET ;;; is a displaced offset to be added to computed indices of OLD-DATA. (defun zap-array-data (old-data old-dims offset new-data new-dims new-length element-type initial-element initial-element-p) - (declare (list old-dims new-dims)) + (declare (list old-dims new-dims) + (fixnum new-length)) ;; OLD-DIMS comes from array-dimensions, which returns a fresh list ;; at least in SBCL. ;; NEW-DIMS comes from the user. @@ -1224,14 +1197,15 @@ function to be removed without further warning." (unless (typep initial-element element-type) (error "~S can't be used to initialize an array of type ~S." initial-element element-type))) - (let ((temp (zap-array-data-temp new-length - initial-element initial-element-p))) + (let ((temp (if initial-element-p + (make-array new-length :initial-element initial-element) + (make-array new-length)))) (declare (simple-vector temp)) (zap-array-data-aux old-data old-dims offset temp new-dims) (dotimes (i new-length) - (setf (aref new-data i) (aref temp i) - ;; zero out any garbage right away - (aref temp i) 0)))) + (setf (aref new-data i) (aref temp i))) + ;; Kill the temporary vector to prevent garbage retention. + (%shrink-vector temp 0))) (t ;; When OLD-DATA and NEW-DATA are not EQ, NEW-DATA has ;; already been filled with any diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 076a9b9..06cd2c6 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -227,73 +227,62 @@ ;;; (NIL). (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref) (with-unique-names - (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i) + (vector-len n direction unsorted start-1 end-1 end-2 temp i) `(let* ((,vector-len (length (the vector ,vector))) - (,n 1) ; bottom-up size of contiguous runs to be merged - (,direction t) ; t vector --> temp nil temp --> vector - (,temp *merge-sort-temp-vector*) - (,temp-len (length ,temp)) - (,unsorted 0) ; unsorted..vector-len are the elements that need - ; to be merged for a given n - (,start-1 0)) ; one n-len subsequence to be merged with the next - (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1) + (,n 1) ; bottom-up size of contiguous runs to be merged + (,direction t) ; t vector --> temp nil temp --> vector + (,temp (make-array ,vector-len)) + (,unsorted 0) ; unsorted..vector-len are the elements that need + ; to be merged for a given n + (,start-1 0)) ; one n-len subsequence to be merged with the next + (declare (fixnum ,vector-len ,n ,unsorted ,start-1) (simple-vector ,temp)) - (when (> ,vector-len ,temp-len) - (setf ,temp (make-array (max ,vector-len - (min (truncate array-dimension-limit 2) - (logand most-positive-fixnum (+ ,temp-len ,temp-len))))) - *merge-sort-temp-vector* ,temp)) - ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also - ;; interrupt safe: we bind before we put any data of our own in - ;; the temp vector. - (let ((*merge-sort-temp-vector* (vector))) + (loop + ;; for each n, we start taking n-runs from the start of the vector + (setf ,unsorted 0) (loop - ;; for each n, we start taking n-runs from the start of the vector - (setf ,unsorted 0) - (loop - (setf ,start-1 ,unsorted) - (let ((,end-1 (+ ,start-1 ,n))) - (declare (fixnum ,end-1)) - (cond ((< ,end-1 ,vector-len) - ;; there are enough elements for a second run - (let ((,end-2 (+ ,end-1 ,n))) - (declare (fixnum ,end-2)) - (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) - (setf ,unsorted ,end-2) - (if ,direction - (stable-sort-merge-vectors* - ,vector ,temp - ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) - (stable-sort-merge-vectors* - ,temp ,vector - ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) - (if (= ,unsorted ,vector-len) (return)))) - ;; if there is only one run, copy those elements to the end - (t (if ,direction - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (svref ,temp ,i) - (,vector-ref ,vector ,i))) - (do ((,i ,start-1 (1+ ,i))) - ((= ,i ,vector-len)) - (declare (fixnum ,i)) - (setf (,vector-ref ,vector ,i) - (svref ,temp ,i)))) - (return))))) - ;; If the inner loop only executed once, then there were only enough - ;; elements for two subsequences given n, so all the elements have - ;; been merged into one list. Start-1 will have remained 0 upon exit. - (when (zerop ,start-1) - (if ,direction - ;; if we just merged into the temporary, copy it all back - ;; to the given vector. - (dotimes (,i ,vector-len) - (setf (,vector-ref ,vector ,i) - (svref ,temp ,i)))) - (return ,vector)) - (setf ,n (ash ,n 1)) ; (* 2 n) - (setf ,direction (not ,direction))))))) + (setf ,start-1 ,unsorted) + (let ((,end-1 (+ ,start-1 ,n))) + (declare (fixnum ,end-1)) + (cond ((< ,end-1 ,vector-len) + ;; there are enough elements for a second run + (let ((,end-2 (+ ,end-1 ,n))) + (declare (fixnum ,end-2)) + (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len)) + (setf ,unsorted ,end-2) + (if ,direction + (stable-sort-merge-vectors* + ,vector ,temp + ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref) + (stable-sort-merge-vectors* + ,temp ,vector + ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref)) + (if (= ,unsorted ,vector-len) (return)))) + ;; if there is only one run, copy those elements to the end + (t (if ,direction + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (svref ,temp ,i) (,vector-ref ,vector ,i))) + (do ((,i ,start-1 (1+ ,i))) + ((= ,i ,vector-len)) + (declare (fixnum ,i)) + (setf (,vector-ref ,vector ,i) (svref ,temp ,i)))) + (return))))) + ;; If the inner loop only executed once, then there were only enough + ;; elements for two subsequences given n, so all the elements have + ;; been merged into one list. Start-1 will have remained 0 upon exit. + (when (zerop ,start-1) + (when ,direction + ;; if we just merged into the temporary, copy it all back + ;; to the given vector. + (dotimes (,i ,vector-len) + (setf (,vector-ref ,vector ,i) (svref ,temp ,i)))) + ;; Kill the new vector to prevent garbage from being retained. + (%shrink-vector ,temp 0) + (return ,vector)) + (setf ,n (ash ,n 1)) ; (* 2 n) + (setf ,direction (not ,direction)))))) ) ; EVAL-when diff --git a/src/code/target-signal.lisp b/src/code/target-signal.lisp index e08e38d..f23f2a4 100644 --- a/src/code/target-signal.lisp +++ b/src/code/target-signal.lisp @@ -12,22 +12,16 @@ (in-package "SB!UNIX") (defmacro with-interrupt-bindings (&body body) - (with-unique-names (empty) - `(let* - ;; KLUDGE: Whatever is on the PCL stacks before the interrupt - ;; handler runs doesn't really matter, since we're not on the - ;; same call stack, really -- and if we don't bind these (esp. - ;; the cache one) we can get a bogus metacircle if an interrupt - ;; handler calls a GF that was being computed when the interrupt - ;; hit. - ((sb!pcl::*cache-miss-values-stack* nil) - (sb!pcl::*dfun-miss-gfs-on-stack* nil) - ;; Unless we do this, ADJUST-ARRAY and SORT would need to - ;; disable interrupts. - (,empty (vector)) - (sb!impl::*zap-array-data-temp* ,empty) - (sb!impl::*merge-sort-temp-vector* ,empty)) - ,@body))) + `(let* + ;; KLUDGE: Whatever is on the PCL stacks before the interrupt + ;; handler runs doesn't really matter, since we're not on the + ;; same call stack, really -- and if we don't bind these (esp. + ;; the cache one) we can get a bogus metacircle if an interrupt + ;; handler calls a GF that was being computed when the interrupt + ;; hit. + ((sb!pcl::*cache-miss-values-stack* nil) + (sb!pcl::*dfun-miss-gfs-on-stack* nil)) + ,@body)) ;;; Evaluate CLEANUP-FORMS iff PROTECTED-FORM does a non-local exit. (defmacro nlx-protect (protected-form &rest cleanup-froms) diff --git a/src/code/target-thread.lisp b/src/code/target-thread.lisp index e513872..7970945 100644 --- a/src/code/target-thread.lisp +++ b/src/code/target-thread.lisp @@ -905,9 +905,6 @@ around and can be retrieved by JOIN-THREAD." ;; internal printer variables (sb!impl::*previous-case* nil) (sb!impl::*previous-readtable-case* nil) - (empty (vector)) - (sb!impl::*merge-sort-temp-vector* empty) - (sb!impl::*zap-array-data-temp* empty) (sb!impl::*internal-symbol-output-fun* nil) (sb!impl::*descriptor-handlers* nil)) ; serve-event ;; Binding from C diff --git a/version.lisp-expr b/version.lisp-expr index 03e18d7..7034605 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".) -"1.0.36.17" +"1.0.36.18"