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
))
35 (end (length sequence
)))
36 (sort-vector vector start end predicate-fun key-fun-or-nil
))
38 (apply #'sb
!sequence
:sort sequence predicate args
))))
41 (defun stable-sort (sequence predicate
&rest args
&key key
)
43 "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
44 ARG1 is to precede ARG2."
45 (declare (dynamic-extent args
))
46 (let ((predicate-fun (%coerce-callable-to-fun predicate
)))
47 (seq-dispatch sequence
48 (stable-sort-list sequence
50 (if key
(%coerce-callable-to-fun key
) #'identity
))
51 (if (typep sequence
'simple-vector
)
52 (stable-sort-simple-vector sequence
54 (and key
(%coerce-callable-to-fun key
)))
55 (stable-sort-vector sequence
57 (and key
(%coerce-callable-to-fun key
))))
58 (apply #'sb
!sequence
:stable-sort sequence predicate args
))))
60 ;;; FUNCALL-USING-KEY saves us a function call sometimes.
61 (eval-when (:compile-toplevel
:execute
)
62 (sb!xc
:defmacro funcall2-using-key
(pred key one two
)
64 (funcall ,pred
(funcall ,key
,one
)
66 (funcall ,pred
,one
,two
)))
69 ;;;; stable sort of lists
71 (defun last-cons-of (list)
72 (loop (let ((rest (rest list
)))
77 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
78 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
79 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
80 ;;; come before equal elements of LIST-2.
82 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
83 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
84 ;;; the last cons in the list which NRECONC calls TAIL).
85 (defun merge-lists* (list-1 list-2 pred-fun key-fun
)
86 (declare (type list list-1 list-2
))
87 (declare (type function pred-fun key-fun
))
88 (cond ((null list-1
) (values list-2
(last-cons-of list-2
)))
89 ((null list-2
) (values list-1
(last-cons-of list-1
)))
90 (t (let* ((reversed-result-so-far nil
)
91 (key-1 (funcall key-fun
(car list-1
)))
92 (key-2 (funcall key-fun
(car list-2
))))
94 (macrolet ((frob (list-i key-i other-list
)
97 ;; (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
98 ;; except doing some fancy footwork to
99 ;; reuse the cons cell:
100 (psetf (cdr ,list-i
) reversed-result-so-far
101 reversed-result-so-far
,list-i
102 ,list-i
(cdr ,list-i
))
103 ;; Now maybe we're done.
105 (return (values (nreconc
106 reversed-result-so-far
111 (funcall key-fun
(car ,list-i
)))))))
112 ;; Note that by making KEY-2 the first arg to
113 ;; PRED-FUN, we arrange that if PRED-FUN is a function
114 ;; in the #'< style, the outcome is stably sorted.
115 (if (funcall pred-fun key-2 key-1
)
116 (frob list-2 key-2 list-1
)
117 (frob list-1 key-1 list-2
))))))))
119 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
120 ;;; over the list grabbing one element at a time and merging it with
121 ;;; the next one to form pairs of sorted elements. Then N is doubled,
122 ;;; and elements are taken in runs of two, merging one run with the
123 ;;; next to form quadruples of sorted elements. This continues until N
124 ;;; is large enough that the inner loop only runs for one iteration;
125 ;;; that is, there are only two runs that can be merged, the first run
126 ;;; starting at the beginning of the list, and the second being the
127 ;;; remaining elements.
128 (defun stable-sort-list (list pred-fun key-fun
)
129 (let ((head (cons :header list
)) ; head holds on to everything
130 (n 1) ; bottom-up size of lists to be merged
131 unsorted
; unsorted is the remaining list to be
132 ; broken into n size lists and merged
133 list-1
; list-1 is one length n list to be merged
134 last
) ; last points to the last visited cell
135 (declare (type function pred-fun key-fun
)
138 ;; Start collecting runs of N at the first element.
139 (setf unsorted
(cdr head
))
140 ;; Tack on the first merge of two N-runs to the head holder.
143 (declare (fixnum n-1
))
145 (setf list-1 unsorted
)
146 (let ((temp (nthcdr n-1 list-1
))
149 ;; There are enough elements for a second run.
150 (setf list-2
(cdr temp
))
151 (setf (cdr temp
) nil
)
152 (setf temp
(nthcdr n-1 list-2
))
154 (setf unsorted
(cdr temp
))
155 (setf (cdr temp
) nil
))
156 ;; The second run goes off the end of the list.
157 (t (setf unsorted nil
)))
158 (multiple-value-bind (merged-head merged-last
)
159 (merge-lists* list-1 list-2 pred-fun key-fun
)
160 (setf (cdr last
) merged-head
162 (if (null unsorted
) (return)))
163 ;; If there is only one run, then tack it on to the end.
164 (t (setf (cdr last
) list-1
)
166 (setf n
(ash n
1)) ; (+ n n)
167 ;; If the inner loop only executed once, then there were only
168 ;; enough elements for two runs given n, so all the elements
169 ;; have been merged into one list. This may waste one outer
170 ;; iteration to realize.
171 (if (eq list-1
(cdr head
))
174 ;;;; stable sort of vectors
176 ;;; Stable sorting vectors is done with the same algorithm used for
177 ;;; lists, using a temporary vector to merge back and forth between it
178 ;;; and the given vector to sort.
180 (eval-when (:compile-toplevel
:execute
)
182 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
183 ;;; start-1 (inclusive) ... end-1 (exclusive) and
184 ;;; end-1 (inclusive) ... end-2 (exclusive),
185 ;;; and merges them into a target vector starting at index start-1.
187 (sb!xc
:defmacro stable-sort-merge-vectors
* (source target start-1 end-1 end-2
194 (,j
,end-1
) ; start-2
195 (,target-i
,start-1
))
196 (declare (fixnum ,i
,j
,target-i
))
199 (loop (if (= ,j
,end-2
) (return))
200 (setf (,target-ref
,target
,target-i
)
201 (,source-ref
,source
,j
))
206 (loop (if (= ,i
,end-1
) (return))
207 (setf (,target-ref
,target
,target-i
)
208 (,source-ref
,source
,i
))
212 ((funcall2-using-key ,pred
,key
213 (,source-ref
,source
,j
)
214 (,source-ref
,source
,i
))
215 (setf (,target-ref
,target
,target-i
)
216 (,source-ref
,source
,j
))
218 (t (setf (,target-ref
,target
,target-i
)
219 (,source-ref
,source
,i
))
223 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
224 ;;; but it uses a temporary vector. DIRECTION determines whether we
225 ;;; are merging into the temporary (T) or back into the given vector
227 (sb!xc
:defmacro vector-merge-sort
(vector pred key vector-ref
)
229 (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i
)
230 `(let* ((,vector-len
(length (the vector
,vector
)))
231 (,n
1) ; bottom-up size of contiguous runs to be merged
232 (,direction t
) ; t vector --> temp nil temp --> vector
233 (,temp
*merge-sort-temp-vector
*)
234 (,temp-len
(length ,temp
))
235 (,unsorted
0) ; unsorted..vector-len are the elements that need
236 ; to be merged for a given n
237 (,start-1
0)) ; one n-len subsequence to be merged with the next
238 (declare (fixnum ,vector-len
,n
,temp-len
,unsorted
,start-1
)
239 (simple-vector ,temp
))
240 (when (> ,vector-len
,temp-len
)
241 (setf ,temp
(make-array (max ,vector-len
242 (min most-positive-fixnum
243 (+ ,temp-len
,temp-len
))))
244 *merge-sort-temp-vector
* ,temp
))
245 ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also
246 ;; interrupt safe: we bind before we put any data of our own in
248 (let ((*merge-sort-temp-vector
* (vector)))
250 ;; for each n, we start taking n-runs from the start of the vector
253 (setf ,start-1
,unsorted
)
254 (let ((,end-1
(+ ,start-1
,n
)))
255 (declare (fixnum ,end-1
))
256 (cond ((< ,end-1
,vector-len
)
257 ;; there are enough elements for a second run
258 (let ((,end-2
(+ ,end-1
,n
)))
259 (declare (fixnum ,end-2
))
260 (if (> ,end-2
,vector-len
) (setf ,end-2
,vector-len
))
261 (setf ,unsorted
,end-2
)
263 (stable-sort-merge-vectors*
265 ,start-1
,end-1
,end-2
,pred
,key
,vector-ref svref
)
266 (stable-sort-merge-vectors*
268 ,start-1
,end-1
,end-2
,pred
,key svref
,vector-ref
))
269 (if (= ,unsorted
,vector-len
) (return))))
270 ;; if there is only one run, copy those elements to the end
272 (do ((,i
,start-1
(1+ ,i
)))
274 (declare (fixnum ,i
))
275 (setf (svref ,temp
,i
)
276 (,vector-ref
,vector
,i
)))
277 (do ((,i
,start-1
(1+ ,i
)))
279 (declare (fixnum ,i
))
280 (setf (,vector-ref
,vector
,i
)
283 ;; If the inner loop only executed once, then there were only enough
284 ;; elements for two subsequences given n, so all the elements have
285 ;; been merged into one list. Start-1 will have remained 0 upon exit.
286 (when (zerop ,start-1
)
288 ;; if we just merged into the temporary, copy it all back
289 ;; to the given vector.
290 (dotimes (,i
,vector-len
)
291 (setf (,vector-ref
,vector
,i
)
294 (setf ,n
(ash ,n
1)) ; (* 2 n)
295 (setf ,direction
(not ,direction
)))))))
299 ;;; temporary vector for stable sorting vectors, allocated for each new thread
300 (defvar *merge-sort-temp-vector
* (vector))
301 (declaim (simple-vector *merge-sort-temp-vector
*))
303 (defun stable-sort-simple-vector (vector pred key
)
304 (declare (type simple-vector vector
)
306 (type (or null function
) key
))
307 (vector-merge-sort vector pred key svref
))
309 (defun stable-sort-vector (vector pred key
)
310 (declare (type function pred
)
311 (type (or null function
) key
))
312 (vector-merge-sort vector pred key aref
))
316 (eval-when (:compile-toplevel
:execute
)
318 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
319 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
320 ;;; are chosen only if they are strictly less than elements of
321 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
322 (sb!xc
:defmacro merge-vectors
(vector-1 length-1 vector-2 length-2
323 result-vector pred key access
)
324 (let ((result-i (gensym))
327 `(let* ((,result-i
0)
330 (declare (fixnum ,result-i
,i
,j
))
332 (cond ((= ,i
,length-1
)
333 (loop (if (= ,j
,length-2
) (return))
334 (setf (,access
,result-vector
,result-i
)
335 (,access
,vector-2
,j
))
338 (return ,result-vector
))
340 (loop (if (= ,i
,length-1
) (return))
341 (setf (,access
,result-vector
,result-i
)
342 (,access
,vector-1
,i
))
345 (return ,result-vector
))
346 ((funcall2-using-key ,pred
,key
347 (,access
,vector-2
,j
) (,access
,vector-1
,i
))
348 (setf (,access
,result-vector
,result-i
)
349 (,access
,vector-2
,j
))
351 (t (setf (,access
,result-vector
,result-i
)
352 (,access
,vector-1
,i
))
358 (defun merge (result-type sequence1 sequence2 predicate
&key key
)
360 "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
361 sequence of type RESULT-TYPE using PREDICATE to order the elements."
362 ;; FIXME: This implementation is remarkably inefficient in various
363 ;; ways. In decreasing order of estimated user astonishment, I note:
364 ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
365 ;; to lists before doing MERGE-LISTS*; and walking input lists
366 ;; (because of the call to MERGE-LISTS*, which walks the list to
367 ;; find the last element for its second return value) even in cases
368 ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
369 ;; can be largely ignored. -- WHN 2003-01-05
370 (let ((type (specifier-type result-type
)))
372 ((csubtypep type
(specifier-type 'list
))
373 ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
374 ;; benefits from the error checking there. Short of
375 ;; reimplementing everything, we can't do the same for the LIST
376 ;; case, so do relevant length checking here:
377 (let ((s1 (coerce sequence1
'list
))
378 (s2 (coerce sequence2
'list
))
379 (pred-fun (%coerce-callable-to-fun predicate
))
381 (%coerce-callable-to-fun key
)
383 (when (type= type
(specifier-type 'list
))
384 (return-from merge
(values (merge-lists* s1 s2 pred-fun key-fun
))))
385 (when (eq type
*empty-type
*)
386 (bad-sequence-type-error nil
))
387 (when (type= type
(specifier-type 'null
))
388 (if (and (null s1
) (null s2
))
389 (return-from merge
'nil
)
390 ;; FIXME: This will break on circular lists (as,
391 ;; indeed, will the whole MERGE function).
392 (sequence-type-length-mismatch-error type
395 (if (cons-type-p type
)
396 (multiple-value-bind (min exactp
)
397 (sb!kernel
::cons-type-length-info type
)
398 (let ((length (+ (length s1
) (length s2
))))
400 (unless (= length min
)
401 (sequence-type-length-mismatch-error type length
))
402 (unless (>= length min
)
403 (sequence-type-length-mismatch-error type length
)))
404 (values (merge-lists* s1 s2 pred-fun key-fun
))))
405 (sequence-type-too-hairy result-type
))))
406 ((csubtypep type
(specifier-type 'vector
))
407 (let* ((vector-1 (coerce sequence1
'vector
))
408 (vector-2 (coerce sequence2
'vector
))
409 (length-1 (length vector-1
))
410 (length-2 (length vector-2
))
411 (result (make-sequence result-type
(+ length-1 length-2
))))
412 (declare (vector vector-1 vector-2
)
413 (fixnum length-1 length-2
))
414 (if (and (simple-vector-p result
)
415 (simple-vector-p vector-1
)
416 (simple-vector-p vector-2
))
417 (merge-vectors vector-1 length-1 vector-2 length-2
418 result predicate key svref
)
419 (merge-vectors vector-1 length-1 vector-2 length-2
420 result predicate key aref
))))
421 ((and (csubtypep type
(specifier-type 'sequence
))
422 (find-class result-type nil
))
423 (let* ((vector-1 (coerce sequence1
'vector
))
424 (vector-2 (coerce sequence2
'vector
))
425 (length-1 (length vector-1
))
426 (length-2 (length vector-2
))
427 (temp (make-array (+ length-1 length-2
)))
428 (result (make-sequence result-type
(+ length-1 length-2
))))
429 (declare (vector vector-1 vector-2
) (fixnum length-1 length-2
))
430 (merge-vectors vector-1 length-1 vector-2 length-2
431 temp predicate key aref
)
432 (replace result temp
)
434 (t (bad-sequence-type-error result-type
)))))