X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsort.lisp;h=06cd2c6664d62c83d2ed7e2c28ae04b6b6478305;hb=65b5ab7e713d04e0d76bc0ee196374f6e57b922f;hp=d73ed34ab102b1cb28be4178f1c024da8077ea0c;hpb=a682f4c392bc874a6a898632889319ebdd8821fc;p=sbcl.git diff --git a/src/code/sort.lisp b/src/code/sort.lisp index d73ed34..06cd2c6 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -23,7 +23,7 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((predicate-fun (%coerce-callable-to-fun predicate))) (seq-dispatch sequence (stable-sort-list sequence @@ -31,8 +31,9 @@ (if key (%coerce-callable-to-fun key) #'identity)) (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key)))) (with-array-data ((vector (the vector sequence)) - (start 0) - (end (length sequence))) + (start) + (end) + :check-fill-pointer t) (sort-vector vector start end predicate-fun key-fun-or-nil)) sequence) (apply #'sb!sequence:sort sequence predicate args)))) @@ -42,7 +43,7 @@ #!+sb-doc "Destructively sort SEQUENCE. PREDICATE should return non-NIL if ARG1 is to precede ARG2." - (declare (dynamic-extent args)) + (declare (truly-dynamic-extent args)) (let ((predicate-fun (%coerce-callable-to-fun predicate))) (seq-dispatch sequence (stable-sort-list sequence @@ -226,79 +227,65 @@ ;;; (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)) - (if (> ,vector-len ,temp-len) - (setf ,temp (make-array (max ,vector-len - (min most-positive-fixnum - (+ ,temp-len ,temp-len)))) - *merge-sort-temp-vector* ,temp)) - ;; rebind, in case PRED or KEY calls STABLE-SORT - (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 -;;; temporary vector for stable sorting vectors, allocated for each new thread -(defvar *merge-sort-temp-vector* (make-array 50)) - -(declaim (simple-vector *merge-sort-temp-vector*)) - (defun stable-sort-simple-vector (vector pred key) (declare (type simple-vector vector) (type function pred)