3 ;;;; This software is part of the SBCL system. See the README file for
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
12 (in-package "SB!IMPL")
14 (defun sort-vector (vector start end predicate-fun key-fun-or-nil)
15 (sort-vector vector start end predicate-fun key-fun-or-nil))
17 ;;; This is MAYBE-INLINE because it's not too hard to have an
18 ;;; application where sorting is a major bottleneck, and inlining it
19 ;;; allows the compiler to make enough optimizations that it might be
20 ;;; worth the (large) cost in space.
21 (declaim (maybe-inline sort stable-sort))
22 (defun sort (sequence predicate &rest args &key key)
24 "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
25 ARG1 is to precede ARG2."
26 (declare (truly-dynamic-extent args))
27 (let ((predicate-fun (%coerce-callable-to-fun predicate)))
28 (seq-dispatch sequence
29 (stable-sort-list sequence
31 (if key (%coerce-callable-to-fun key) #'identity))
32 (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
33 (with-array-data ((vector (the vector sequence))
36 :check-fill-pointer t)
37 (sort-vector vector start end predicate-fun key-fun-or-nil))
39 (apply #'sb!sequence:sort sequence predicate args))))
42 (defun stable-sort (sequence predicate &rest args &key key)
44 "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
45 ARG1 is to precede ARG2."
46 (declare (truly-dynamic-extent args))
47 (let ((predicate-fun (%coerce-callable-to-fun predicate)))
48 (seq-dispatch sequence
49 (stable-sort-list sequence
51 (if key (%coerce-callable-to-fun key) #'identity))
52 (if (typep sequence 'simple-vector)
53 (stable-sort-simple-vector sequence
55 (and key (%coerce-callable-to-fun key)))
56 (stable-sort-vector sequence
58 (and key (%coerce-callable-to-fun key))))
59 (apply #'sb!sequence:stable-sort sequence predicate args))))
61 ;;; FUNCALL-USING-KEY saves us a function call sometimes.
62 (eval-when (:compile-toplevel :execute)
63 (sb!xc:defmacro funcall2-using-key (pred key one two)
65 (funcall ,pred (funcall ,key ,one)
67 (funcall ,pred ,one ,two)))
70 ;;;; stable sort of lists
71 (declaim (maybe-inline merge-lists* stable-sort-list))
73 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
74 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
75 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
76 ;;; come before equal elements of LIST-2.
78 ;;; Enqueues the values in the right order in HEAD's cdr, and returns
80 (defun merge-lists* (head list1 list2 test key &aux (tail head))
81 (declare (type cons head list1 list2)
82 (type function test key)
84 (macrolet ((merge-one (l1 l2)
88 (let ((rest (cdr ,l1)))
93 (return (cdr head))))))))
95 (if (funcall test (funcall key (car list2)) ; this way, equivalent
96 (funcall key (car list1))) ; values are first popped
97 (merge-one list2 list1) ; from list1
98 (merge-one list1 list2)))))
100 ;;; Convenience wrapper for CL:MERGE
101 (declaim (inline merge-lists))
102 (defun merge-lists (list1 list2 test key)
108 (let ((head (cons nil nil)))
109 (declare (dynamic-extent head))
110 (merge-lists* head list1 list2 test key)))))
112 ;;; STABLE-SORT-LIST implements a top-down merge sort. See the closest
113 ;;; intro to algorithms book. Benchmarks have shown significantly
114 ;;; improved performance over the previous (hairier) bottom-up
115 ;;; implementation, particularly on non-power-of-two sizes: bottom-up
116 ;;; recursed on power-of-two-sized subsequences, which can result in
117 ;;; very unbalanced recursion trees.
118 (defun stable-sort-list (list test key &aux (head (cons :head list)))
119 (declare (type list list)
120 (type function test key)
121 (dynamic-extent head))
122 (labels ((recur (list size)
123 (declare (optimize speed)
125 (type (and fixnum unsigned-byte) size))
127 (values list (shiftf (cdr list) nil))
128 (let ((half (ash size -1)))
129 (multiple-value-bind (list1 rest)
131 (multiple-value-bind (list2 rest)
132 (recur rest (- size half))
133 (values (merge-lists* head list1 list2 test key)
136 (values (recur list (length list))))))
138 ;;;; stable sort of vectors
140 ;;; Stable sorting vectors is done with the same algorithm used for
141 ;;; lists, using a temporary vector to merge back and forth between it
142 ;;; and the given vector to sort.
144 (eval-when (:compile-toplevel :execute)
146 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
147 ;;; start-1 (inclusive) ... end-1 (exclusive) and
148 ;;; end-1 (inclusive) ... end-2 (exclusive),
149 ;;; and merges them into a target vector starting at index start-1.
151 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
158 (,j ,end-1) ; start-2
159 (,target-i ,start-1))
160 (declare (fixnum ,i ,j ,target-i))
163 (loop (if (= ,j ,end-2) (return))
164 (setf (,target-ref ,target ,target-i)
165 (,source-ref ,source ,j))
170 (loop (if (= ,i ,end-1) (return))
171 (setf (,target-ref ,target ,target-i)
172 (,source-ref ,source ,i))
176 ((funcall2-using-key ,pred ,key
177 (,source-ref ,source ,j)
178 (,source-ref ,source ,i))
179 (setf (,target-ref ,target ,target-i)
180 (,source-ref ,source ,j))
182 (t (setf (,target-ref ,target ,target-i)
183 (,source-ref ,source ,i))
187 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
188 ;;; but it uses a temporary vector. DIRECTION determines whether we
189 ;;; are merging into the temporary (T) or back into the given vector
191 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
193 (vector-len n direction unsorted start-1 end-1 end-2 temp i)
194 `(let* ((,vector-len (length (the vector ,vector)))
195 (,n 1) ; bottom-up size of contiguous runs to be merged
196 (,direction t) ; t vector --> temp nil temp --> vector
197 (,temp (make-array ,vector-len))
198 (,unsorted 0) ; unsorted..vector-len are the elements that need
199 ; to be merged for a given n
200 (,start-1 0)) ; one n-len subsequence to be merged with the next
201 (declare (fixnum ,vector-len ,n ,unsorted ,start-1)
202 (simple-vector ,temp))
204 ;; for each n, we start taking n-runs from the start of the vector
207 (setf ,start-1 ,unsorted)
208 (let ((,end-1 (+ ,start-1 ,n)))
209 (declare (fixnum ,end-1))
210 (cond ((< ,end-1 ,vector-len)
211 ;; there are enough elements for a second run
212 (let ((,end-2 (+ ,end-1 ,n)))
213 (declare (fixnum ,end-2))
214 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
215 (setf ,unsorted ,end-2)
217 (stable-sort-merge-vectors*
219 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
220 (stable-sort-merge-vectors*
222 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
223 (if (= ,unsorted ,vector-len) (return))))
224 ;; if there is only one run, copy those elements to the end
226 (do ((,i ,start-1 (1+ ,i)))
228 (declare (fixnum ,i))
229 (setf (svref ,temp ,i) (,vector-ref ,vector ,i)))
230 (do ((,i ,start-1 (1+ ,i)))
232 (declare (fixnum ,i))
233 (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
235 ;; If the inner loop only executed once, then there were only enough
236 ;; elements for two subsequences given n, so all the elements have
237 ;; been merged into one list. Start-1 will have remained 0 upon exit.
238 (when (zerop ,start-1)
240 ;; if we just merged into the temporary, copy it all back
241 ;; to the given vector.
242 (dotimes (,i ,vector-len)
243 (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
244 ;; Kill the new vector to prevent garbage from being retained.
245 (%shrink-vector ,temp 0)
247 (setf ,n (ash ,n 1)) ; (* 2 n)
248 (setf ,direction (not ,direction))))))
252 (defun stable-sort-simple-vector (vector pred key)
253 (declare (type simple-vector vector)
255 (type (or null function) key))
256 (vector-merge-sort vector pred key svref))
258 (defun stable-sort-vector (vector pred key)
259 (declare (type function pred)
260 (type (or null function) key))
261 (vector-merge-sort vector pred key aref))
265 (eval-when (:compile-toplevel :execute)
267 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
268 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
269 ;;; are chosen only if they are strictly less than elements of
270 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
271 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
272 result-vector pred key access)
273 (let ((result-i (gensym))
276 `(let* ((,result-i 0)
279 (declare (fixnum ,result-i ,i ,j))
281 (cond ((= ,i ,length-1)
282 (loop (if (= ,j ,length-2) (return))
283 (setf (,access ,result-vector ,result-i)
284 (,access ,vector-2 ,j))
287 (return ,result-vector))
289 (loop (if (= ,i ,length-1) (return))
290 (setf (,access ,result-vector ,result-i)
291 (,access ,vector-1 ,i))
294 (return ,result-vector))
295 ((funcall2-using-key ,pred ,key
296 (,access ,vector-2 ,j) (,access ,vector-1 ,i))
297 (setf (,access ,result-vector ,result-i)
298 (,access ,vector-2 ,j))
300 (t (setf (,access ,result-vector ,result-i)
301 (,access ,vector-1 ,i))
307 (defun merge (result-type sequence1 sequence2 predicate &key key)
309 "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
310 sequence of type RESULT-TYPE using PREDICATE to order the elements."
311 ;; FIXME: This implementation is remarkably inefficient in various
312 ;; ways. In decreasing order of estimated user astonishment, I note:
313 ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
314 ;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
315 (let ((type (specifier-type result-type)))
317 ((csubtypep type (specifier-type 'list))
318 ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
319 ;; benefits from the error checking there. Short of
320 ;; reimplementing everything, we can't do the same for the LIST
321 ;; case, so do relevant length checking here:
322 (let ((s1 (coerce sequence1 'list))
323 (s2 (coerce sequence2 'list))
324 (pred-fun (%coerce-callable-to-fun predicate))
326 (%coerce-callable-to-fun key)
328 (when (type= type (specifier-type 'list))
329 (return-from merge (merge-lists s1 s2 pred-fun key-fun)))
330 (when (eq type *empty-type*)
331 (bad-sequence-type-error nil))
332 (when (type= type (specifier-type 'null))
333 (if (and (null s1) (null s2))
334 (return-from merge 'nil)
335 ;; FIXME: This will break on circular lists (as,
336 ;; indeed, will the whole MERGE function).
337 (sequence-type-length-mismatch-error type
340 (if (cons-type-p type)
341 (multiple-value-bind (min exactp)
342 (sb!kernel::cons-type-length-info type)
343 (let ((length (+ (length s1) (length s2))))
345 (unless (= length min)
346 (sequence-type-length-mismatch-error type length))
347 (unless (>= length min)
348 (sequence-type-length-mismatch-error type length)))
349 (merge-lists s1 s2 pred-fun key-fun)))
350 (sequence-type-too-hairy result-type))))
351 ((csubtypep type (specifier-type 'vector))
352 (let* ((vector-1 (coerce sequence1 'vector))
353 (vector-2 (coerce sequence2 'vector))
354 (length-1 (length vector-1))
355 (length-2 (length vector-2))
356 (result (make-sequence result-type (+ length-1 length-2))))
357 (declare (vector vector-1 vector-2)
358 (fixnum length-1 length-2))
359 (if (and (simple-vector-p result)
360 (simple-vector-p vector-1)
361 (simple-vector-p vector-2))
362 (merge-vectors vector-1 length-1 vector-2 length-2
363 result predicate key svref)
364 (merge-vectors vector-1 length-1 vector-2 length-2
365 result predicate key aref))))
366 ((and (csubtypep type (specifier-type 'sequence))
367 (find-class result-type nil))
368 (let* ((vector-1 (coerce sequence1 'vector))
369 (vector-2 (coerce sequence2 'vector))
370 (length-1 (length vector-1))
371 (length-2 (length vector-2))
372 (temp (make-array (+ length-1 length-2)))
373 (result (make-sequence result-type (+ length-1 length-2))))
374 (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
375 (merge-vectors vector-1 length-1 vector-2 length-2
376 temp predicate key aref)
377 (replace result temp)
379 (t (bad-sequence-type-error result-type)))))