(%array-data-vector array))
array)))
\f
-;;;; 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.
(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
;;; (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
projects / sbcl.git / commitdiff