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
))
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 (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 (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
72 (defun last-cons-of (list)
73 (loop (let ((rest (rest list
)))
78 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
79 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
80 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
81 ;;; come before equal elements of LIST-2.
83 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
84 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
85 ;;; the last cons in the list which NRECONC calls TAIL).
86 (defun merge-lists* (list-1 list-2 pred-fun key-fun
)
87 (declare (type list list-1 list-2
))
88 (declare (type function pred-fun key-fun
))
89 (cond ((null list-1
) (values list-2
(last-cons-of list-2
)))
90 ((null list-2
) (values list-1
(last-cons-of list-1
)))
91 (t (let* ((reversed-result-so-far nil
)
92 (key-1 (funcall key-fun
(car list-1
)))
93 (key-2 (funcall key-fun
(car list-2
))))
95 (macrolet ((frob (list-i key-i other-list
)
98 ;; (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
99 ;; except doing some fancy footwork to
100 ;; reuse the cons cell:
101 (psetf (cdr ,list-i
) reversed-result-so-far
102 reversed-result-so-far
,list-i
103 ,list-i
(cdr ,list-i
))
104 ;; Now maybe we're done.
106 (return (values (nreconc
107 reversed-result-so-far
112 (funcall key-fun
(car ,list-i
)))))))
113 ;; Note that by making KEY-2 the first arg to
114 ;; PRED-FUN, we arrange that if PRED-FUN is a function
115 ;; in the #'< style, the outcome is stably sorted.
116 (if (funcall pred-fun key-2 key-1
)
117 (frob list-2 key-2 list-1
)
118 (frob list-1 key-1 list-2
))))))))
120 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
121 ;;; over the list grabbing one element at a time and merging it with
122 ;;; the next one to form pairs of sorted elements. Then N is doubled,
123 ;;; and elements are taken in runs of two, merging one run with the
124 ;;; next to form quadruples of sorted elements. This continues until N
125 ;;; is large enough that the inner loop only runs for one iteration;
126 ;;; that is, there are only two runs that can be merged, the first run
127 ;;; starting at the beginning of the list, and the second being the
128 ;;; remaining elements.
129 (defun stable-sort-list (list pred-fun key-fun
)
130 (let ((head (cons :header list
)) ; head holds on to everything
131 (n 1) ; bottom-up size of lists to be merged
132 unsorted
; unsorted is the remaining list to be
133 ; broken into n size lists and merged
134 list-1
; list-1 is one length n list to be merged
135 last
) ; last points to the last visited cell
136 (declare (type function pred-fun key-fun
)
139 ;; Start collecting runs of N at the first element.
140 (setf unsorted
(cdr head
))
141 ;; Tack on the first merge of two N-runs to the head holder.
144 (declare (fixnum n-1
))
146 (setf list-1 unsorted
)
147 (let ((temp (nthcdr n-1 list-1
))
150 ;; There are enough elements for a second run.
151 (setf list-2
(cdr temp
))
152 (setf (cdr temp
) nil
)
153 (setf temp
(nthcdr n-1 list-2
))
155 (setf unsorted
(cdr temp
))
156 (setf (cdr temp
) nil
))
157 ;; The second run goes off the end of the list.
158 (t (setf unsorted nil
)))
159 (multiple-value-bind (merged-head merged-last
)
160 (merge-lists* list-1 list-2 pred-fun key-fun
)
161 (setf (cdr last
) merged-head
163 (if (null unsorted
) (return)))
164 ;; If there is only one run, then tack it on to the end.
165 (t (setf (cdr last
) list-1
)
167 (setf n
(ash n
1)) ; (+ n n)
168 ;; If the inner loop only executed once, then there were only
169 ;; enough elements for two runs given n, so all the elements
170 ;; have been merged into one list. This may waste one outer
171 ;; iteration to realize.
172 (if (eq list-1
(cdr head
))
175 ;;;; stable sort of vectors
177 ;;; Stable sorting vectors is done with the same algorithm used for
178 ;;; lists, using a temporary vector to merge back and forth between it
179 ;;; and the given vector to sort.
181 (eval-when (:compile-toplevel
:execute
)
183 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
184 ;;; start-1 (inclusive) ... end-1 (exclusive) and
185 ;;; end-1 (inclusive) ... end-2 (exclusive),
186 ;;; and merges them into a target vector starting at index start-1.
188 (sb!xc
:defmacro stable-sort-merge-vectors
* (source target start-1 end-1 end-2
195 (,j
,end-1
) ; start-2
196 (,target-i
,start-1
))
197 (declare (fixnum ,i
,j
,target-i
))
200 (loop (if (= ,j
,end-2
) (return))
201 (setf (,target-ref
,target
,target-i
)
202 (,source-ref
,source
,j
))
207 (loop (if (= ,i
,end-1
) (return))
208 (setf (,target-ref
,target
,target-i
)
209 (,source-ref
,source
,i
))
213 ((funcall2-using-key ,pred
,key
214 (,source-ref
,source
,j
)
215 (,source-ref
,source
,i
))
216 (setf (,target-ref
,target
,target-i
)
217 (,source-ref
,source
,j
))
219 (t (setf (,target-ref
,target
,target-i
)
220 (,source-ref
,source
,i
))
224 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
225 ;;; but it uses a temporary vector. DIRECTION determines whether we
226 ;;; are merging into the temporary (T) or back into the given vector
228 (sb!xc
:defmacro vector-merge-sort
(vector pred key vector-ref
)
230 (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i
)
231 `(let* ((,vector-len
(length (the vector
,vector
)))
232 (,n
1) ; bottom-up size of contiguous runs to be merged
233 (,direction t
) ; t vector --> temp nil temp --> vector
234 (,temp
*merge-sort-temp-vector
*)
235 (,temp-len
(length ,temp
))
236 (,unsorted
0) ; unsorted..vector-len are the elements that need
237 ; to be merged for a given n
238 (,start-1
0)) ; one n-len subsequence to be merged with the next
239 (declare (fixnum ,vector-len
,n
,temp-len
,unsorted
,start-1
)
240 (simple-vector ,temp
))
241 (when (> ,vector-len
,temp-len
)
242 (setf ,temp
(make-array (max ,vector-len
243 (min most-positive-fixnum
244 (+ ,temp-len
,temp-len
))))
245 *merge-sort-temp-vector
* ,temp
))
246 ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also
247 ;; interrupt safe: we bind before we put any data of our own in
249 (let ((*merge-sort-temp-vector
* (vector)))
251 ;; for each n, we start taking n-runs from the start of the vector
254 (setf ,start-1
,unsorted
)
255 (let ((,end-1
(+ ,start-1
,n
)))
256 (declare (fixnum ,end-1
))
257 (cond ((< ,end-1
,vector-len
)
258 ;; there are enough elements for a second run
259 (let ((,end-2
(+ ,end-1
,n
)))
260 (declare (fixnum ,end-2
))
261 (if (> ,end-2
,vector-len
) (setf ,end-2
,vector-len
))
262 (setf ,unsorted
,end-2
)
264 (stable-sort-merge-vectors*
266 ,start-1
,end-1
,end-2
,pred
,key
,vector-ref svref
)
267 (stable-sort-merge-vectors*
269 ,start-1
,end-1
,end-2
,pred
,key svref
,vector-ref
))
270 (if (= ,unsorted
,vector-len
) (return))))
271 ;; if there is only one run, copy those elements to the end
273 (do ((,i
,start-1
(1+ ,i
)))
275 (declare (fixnum ,i
))
276 (setf (svref ,temp
,i
)
277 (,vector-ref
,vector
,i
)))
278 (do ((,i
,start-1
(1+ ,i
)))
280 (declare (fixnum ,i
))
281 (setf (,vector-ref
,vector
,i
)
284 ;; If the inner loop only executed once, then there were only enough
285 ;; elements for two subsequences given n, so all the elements have
286 ;; been merged into one list. Start-1 will have remained 0 upon exit.
287 (when (zerop ,start-1
)
289 ;; if we just merged into the temporary, copy it all back
290 ;; to the given vector.
291 (dotimes (,i
,vector-len
)
292 (setf (,vector-ref
,vector
,i
)
295 (setf ,n
(ash ,n
1)) ; (* 2 n)
296 (setf ,direction
(not ,direction
)))))))
300 ;;; temporary vector for stable sorting vectors, allocated for each new thread
301 (defvar *merge-sort-temp-vector
* (vector))
302 (declaim (simple-vector *merge-sort-temp-vector
*))
304 (defun stable-sort-simple-vector (vector pred key
)
305 (declare (type simple-vector vector
)
307 (type (or null function
) key
))
308 (vector-merge-sort vector pred key svref
))
310 (defun stable-sort-vector (vector pred key
)
311 (declare (type function pred
)
312 (type (or null function
) key
))
313 (vector-merge-sort vector pred key aref
))
317 (eval-when (:compile-toplevel
:execute
)
319 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
320 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
321 ;;; are chosen only if they are strictly less than elements of
322 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
323 (sb!xc
:defmacro merge-vectors
(vector-1 length-1 vector-2 length-2
324 result-vector pred key access
)
325 (let ((result-i (gensym))
328 `(let* ((,result-i
0)
331 (declare (fixnum ,result-i
,i
,j
))
333 (cond ((= ,i
,length-1
)
334 (loop (if (= ,j
,length-2
) (return))
335 (setf (,access
,result-vector
,result-i
)
336 (,access
,vector-2
,j
))
339 (return ,result-vector
))
341 (loop (if (= ,i
,length-1
) (return))
342 (setf (,access
,result-vector
,result-i
)
343 (,access
,vector-1
,i
))
346 (return ,result-vector
))
347 ((funcall2-using-key ,pred
,key
348 (,access
,vector-2
,j
) (,access
,vector-1
,i
))
349 (setf (,access
,result-vector
,result-i
)
350 (,access
,vector-2
,j
))
352 (t (setf (,access
,result-vector
,result-i
)
353 (,access
,vector-1
,i
))
359 (defun merge (result-type sequence1 sequence2 predicate
&key key
)
361 "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
362 sequence of type RESULT-TYPE using PREDICATE to order the elements."
363 ;; FIXME: This implementation is remarkably inefficient in various
364 ;; ways. In decreasing order of estimated user astonishment, I note:
365 ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
366 ;; to lists before doing MERGE-LISTS*; and walking input lists
367 ;; (because of the call to MERGE-LISTS*, which walks the list to
368 ;; find the last element for its second return value) even in cases
369 ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
370 ;; can be largely ignored. -- WHN 2003-01-05
371 (let ((type (specifier-type result-type
)))
373 ((csubtypep type
(specifier-type 'list
))
374 ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
375 ;; benefits from the error checking there. Short of
376 ;; reimplementing everything, we can't do the same for the LIST
377 ;; case, so do relevant length checking here:
378 (let ((s1 (coerce sequence1
'list
))
379 (s2 (coerce sequence2
'list
))
380 (pred-fun (%coerce-callable-to-fun predicate
))
382 (%coerce-callable-to-fun key
)
384 (when (type= type
(specifier-type 'list
))
385 (return-from merge
(values (merge-lists* s1 s2 pred-fun key-fun
))))
386 (when (eq type
*empty-type
*)
387 (bad-sequence-type-error nil
))
388 (when (type= type
(specifier-type 'null
))
389 (if (and (null s1
) (null s2
))
390 (return-from merge
'nil
)
391 ;; FIXME: This will break on circular lists (as,
392 ;; indeed, will the whole MERGE function).
393 (sequence-type-length-mismatch-error type
396 (if (cons-type-p type
)
397 (multiple-value-bind (min exactp
)
398 (sb!kernel
::cons-type-length-info type
)
399 (let ((length (+ (length s1
) (length s2
))))
401 (unless (= length min
)
402 (sequence-type-length-mismatch-error type length
))
403 (unless (>= length min
)
404 (sequence-type-length-mismatch-error type length
)))
405 (values (merge-lists* s1 s2 pred-fun key-fun
))))
406 (sequence-type-too-hairy result-type
))))
407 ((csubtypep type
(specifier-type 'vector
))
408 (let* ((vector-1 (coerce sequence1
'vector
))
409 (vector-2 (coerce sequence2
'vector
))
410 (length-1 (length vector-1
))
411 (length-2 (length vector-2
))
412 (result (make-sequence result-type
(+ length-1 length-2
))))
413 (declare (vector vector-1 vector-2
)
414 (fixnum length-1 length-2
))
415 (if (and (simple-vector-p result
)
416 (simple-vector-p vector-1
)
417 (simple-vector-p vector-2
))
418 (merge-vectors vector-1 length-1 vector-2 length-2
419 result predicate key svref
)
420 (merge-vectors vector-1 length-1 vector-2 length-2
421 result predicate key aref
))))
422 ((and (csubtypep type
(specifier-type 'sequence
))
423 (find-class result-type nil
))
424 (let* ((vector-1 (coerce sequence1
'vector
))
425 (vector-2 (coerce sequence2
'vector
))
426 (length-1 (length vector-1
))
427 (length-2 (length vector-2
))
428 (temp (make-array (+ length-1 length-2
)))
429 (result (make-sequence result-type
(+ length-1 length-2
))))
430 (declare (vector vector-1 vector-2
) (fixnum length-1 length-2
))
431 (merge-vectors vector-1 length-1 vector-2 length-2
432 temp predicate key aref
)
433 (replace result temp
)
435 (t (bad-sequence-type-error result-type
)))))