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 ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
15 ;;; isn't really related to the CMU CL code, since instead of trying
16 ;;; to generalize the CMU CL code to allow START and END values, this
17 ;;; code has been written from scratch following Chapter 7 of
18 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
19 (macrolet ((%index (x) `(truly-the index ,x))
20 (%parent (i) `(ash ,i -1))
21 (%left (i) `(%index (ash ,i 1)))
22 (%right (i) `(%index (1+ (ash ,i 1))))
25 (left (%left i) (%left i)))
26 ((> left current-heap-size))
27 (declare (type index i left))
28 (let* ((i-elt (%elt i))
29 (i-key (funcall keyfun i-elt))
30 (left-elt (%elt left))
31 (left-key (funcall keyfun left-elt)))
32 (multiple-value-bind (large large-elt large-key)
33 (if (funcall predicate i-key left-key)
34 (values left left-elt left-key)
35 (values i i-elt i-key))
36 (let ((right (%right i)))
37 (multiple-value-bind (largest largest-elt)
38 (if (> right current-heap-size)
39 (values large large-elt)
40 (let* ((right-elt (%elt right))
41 (right-key (funcall keyfun right-elt)))
42 (if (funcall predicate large-key right-key)
43 (values right right-elt)
44 (values large large-elt))))
48 (setf (%elt i) largest-elt
51 (%sort-vector (keyfun &optional (vtype 'vector))
52 `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
53 ;; type inference to propagate all the way
54 ;; through this tangled mess of inlining. The
55 ;; TRULY-THE here works around that. -- WHN
57 `(aref (truly-the ,',vtype vector)
58 (%index (+ (%index ,i) start-1)))))
59 (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
60 (current-heap-size (- end start))
62 (declare (type (integer -1 #.(1- most-positive-fixnum))
64 (declare (type index current-heap-size))
65 (declare (type function keyfun))
66 (loop for i of-type index
67 from (ash current-heap-size -1) downto 1 do
70 (when (< current-heap-size 2)
72 (rotatef (%elt 1) (%elt current-heap-size))
73 (decf current-heap-size)
76 (declaim (inline sort-vector))
77 (defun sort-vector (vector start end predicate key)
78 (declare (type vector vector))
79 (declare (type index start end))
80 (declare (type function predicate))
81 (declare (type (or function null) key))
82 ;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now
83 ;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including
84 ;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer
85 ;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast,
86 ;; pretty safe, and safety is no more important than speed".
87 (declare (optimize (speed 2) (safety 2) (debug 1) (space 1)))
88 (if (typep vector 'simple-vector)
89 ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
90 ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
92 ;; Special-casing the KEY=NIL case lets us avoid some
94 (%sort-vector #'identity simple-vector)
95 (%sort-vector key simple-vector))
96 ;; It's hard to anticipate many speed-critical applications for
97 ;; sorting vector types other than (VECTOR T), so we just lump
98 ;; them all together in one slow dynamically typed mess.
100 (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
101 (%sort-vector (or key #'identity))))))
103 ;;; This is MAYBE-INLINE because it's not too hard to have an
104 ;;; application where sorting is a major bottleneck, and inlining it
105 ;;; allows the compiler to make enough optimizations that it might be
106 ;;; worth the (large) cost in space.
107 (declaim (maybe-inline sort))
108 (defun sort (sequence predicate &key key)
110 "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
111 ARG1 is to precede ARG2."
112 (let ((predicate-function (%coerce-callable-to-fun predicate))
113 (key-function (and key (%coerce-callable-to-fun key))))
115 (list (sort-list sequence predicate-function key-function))
117 (with-array-data ((vector (the vector sequence))
119 (end (length sequence)))
120 (sort-vector vector start end predicate-function key-function))
123 (error 'simple-type-error
125 :expected-type 'sequence
126 :format-control "~S is not a sequence."
127 :format-arguments (list sequence))))))
131 (defun stable-sort (sequence predicate &key key)
133 "Destructively sorts sequence. Predicate should return non-Nil if
134 Arg1 is to precede Arg2."
137 (stable-sort-simple-vector sequence predicate key))
139 (sort-list sequence predicate key))
141 (stable-sort-vector sequence predicate key))
143 (error 'simple-type-error
145 :expected-type 'sequence
146 :format-control "~S is not a sequence."
147 :format-arguments (list sequence)))))
149 ;;; stable sort of lists
151 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
152 ;;; the list grabbing one element at a time and merging it with the
153 ;;; next one form pairs of sorted elements. Then n is doubled, and
154 ;;; elements are taken in runs of two, merging one run with the next
155 ;;; to form quadruples of sorted elements. This continues until n is
156 ;;; large enough that the inner loop only runs for one iteration; that
157 ;;; is, there are only two runs that can be merged, the first run
158 ;;; starting at the beginning of the list, and the second being the
159 ;;; remaining elements.
161 (defun sort-list (list pred key)
162 (let ((head (cons :header list)) ; head holds on to everything
163 (n 1) ; bottom-up size of lists to be merged
164 unsorted ; unsorted is the remaining list to be
165 ; broken into n size lists and merged
166 list-1 ; list-1 is one length n list to be merged
167 last) ; last points to the last visited cell
170 ;; start collecting runs of n at the first element
171 (setf unsorted (cdr head))
172 ;; tack on the first merge of two n-runs to the head holder
175 (declare (fixnum n-1))
177 (setf list-1 unsorted)
178 (let ((temp (nthcdr n-1 list-1))
181 ;; there are enough elements for a second run
182 (setf list-2 (cdr temp))
183 (setf (cdr temp) nil)
184 (setf temp (nthcdr n-1 list-2))
186 (setf unsorted (cdr temp))
187 (setf (cdr temp) nil))
188 ;; the second run goes off the end of the list
189 (t (setf unsorted nil)))
190 (multiple-value-bind (merged-head merged-last)
191 (merge-lists* list-1 list-2 pred key)
192 (setf (cdr last) merged-head)
193 (setf last merged-last))
194 (if (null unsorted) (return)))
195 ;; if there is only one run, then tack it on to the end
196 (t (setf (cdr last) list-1)
198 (setf n (ash n 1)) ; (+ n n)
199 ;; If the inner loop only executed once, then there were only
200 ;; enough elements for two runs given n, so all the elements
201 ;; have been merged into one list. This may waste one outer
202 ;; iteration to realize.
203 (if (eq list-1 (cdr head))
206 ;;; APPLY-PRED saves us a function call sometimes.
207 (eval-when (:compile-toplevel :execute)
208 (sb!xc:defmacro apply-pred (one two pred key)
210 (funcall ,pred (funcall ,key ,one)
212 (funcall ,pred ,one ,two)))
215 (defvar *merge-lists-header* (list :header))
217 ;;; MERGE-LISTS* originally written by Jim Large.
218 ;;; modified to return a pointer to the end of the result
219 ;;; and to not cons header each time its called.
220 ;;; It destructively merges list-1 with list-2. In the resulting
221 ;;; list, elements of list-2 are guaranteed to come after equal elements
223 (defun merge-lists* (list-1 list-2 pred key)
224 (do* ((result *merge-lists-header*)
225 (P result)) ; points to last cell of result
226 ((or (null list-1) (null list-2)) ; done when either list used up
227 (if (null list-1) ; in which case, append the
228 (rplacd p list-2) ; other list
231 (lead (cdr p) (cdr lead)))
233 (values (prog1 (cdr result) ; Return the result sans header
234 (rplacd result nil)) ; (free memory, be careful)
235 drag)))) ; and return pointer to last element.
236 (cond ((apply-pred (car list-2) (car list-1) pred key)
237 (rplacd p list-2) ; Append the lesser list to last cell of
238 (setq p (cdr p)) ; result. Note: test must be done for
239 (pop list-2)) ; LIST-2 < LIST-1 so merge will be
240 (T (rplacd p list-1) ; stable for LIST-1.
244 ;;; stable sort of vectors
246 ;;; Stable sorting vectors is done with the same algorithm used for
247 ;;; lists, using a temporary vector to merge back and forth between it
248 ;;; and the given vector to sort.
250 (eval-when (:compile-toplevel :execute)
252 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
253 ;;; start-1 (inclusive) ... end-1 (exclusive) and
254 ;;; end-1 (inclusive) ... end-2 (exclusive),
255 ;;; and merges them into a target vector starting at index start-1.
257 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
264 (,j ,end-1) ; start-2
265 (,target-i ,start-1))
266 (declare (fixnum ,i ,j ,target-i))
269 (loop (if (= ,j ,end-2) (return))
270 (setf (,target-ref ,target ,target-i)
271 (,source-ref ,source ,j))
276 (loop (if (= ,i ,end-1) (return))
277 (setf (,target-ref ,target ,target-i)
278 (,source-ref ,source ,i))
282 ((apply-pred (,source-ref ,source ,j)
283 (,source-ref ,source ,i)
285 (setf (,target-ref ,target ,target-i)
286 (,source-ref ,source ,j))
288 (t (setf (,target-ref ,target ,target-i)
289 (,source-ref ,source ,i))
293 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
294 ;;; but it uses a temporary vector. DIRECTION determines whether we
295 ;;; are merging into the temporary (T) or back into the given vector
297 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
298 (let ((vector-len (gensym)) (n (gensym))
299 (direction (gensym)) (unsorted (gensym))
300 (start-1 (gensym)) (end-1 (gensym))
301 (end-2 (gensym)) (temp-len (gensym))
303 `(let ((,vector-len (length (the vector ,vector)))
304 (,n 1) ; bottom-up size of contiguous runs to be merged
305 (,direction t) ; t vector --> temp nil temp --> vector
306 (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
307 (,unsorted 0) ; unsorted..vector-len are the elements that need
308 ; to be merged for a given n
309 (,start-1 0)) ; one n-len subsequence to be merged with the next
310 (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
311 (if (> ,vector-len ,temp-len)
312 (setf *merge-sort-temp-vector*
313 (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
315 ;; for each n, we start taking n-runs from the start of the vector
318 (setf ,start-1 ,unsorted)
319 (let ((,end-1 (+ ,start-1 ,n)))
320 (declare (fixnum ,end-1))
321 (cond ((< ,end-1 ,vector-len)
322 ;; there are enough elements for a second run
323 (let ((,end-2 (+ ,end-1 ,n)))
324 (declare (fixnum ,end-2))
325 (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
326 (setf ,unsorted ,end-2)
328 (stable-sort-merge-vectors*
329 ,vector *merge-sort-temp-vector*
330 ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
331 (stable-sort-merge-vectors*
332 *merge-sort-temp-vector* ,vector
333 ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
334 (if (= ,unsorted ,vector-len) (return))))
335 ;; if there is only one run, copy those elements to the end
337 (do ((,i ,start-1 (1+ ,i)))
339 (declare (fixnum ,i))
340 (setf (svref *merge-sort-temp-vector* ,i)
341 (,vector-ref ,vector ,i)))
342 (do ((,i ,start-1 (1+ ,i)))
344 (declare (fixnum ,i))
345 (setf (,vector-ref ,vector ,i)
346 (svref *merge-sort-temp-vector* ,i))))
348 ;; If the inner loop only executed once, then there were only enough
349 ;; elements for two subsequences given n, so all the elements have
350 ;; been merged into one list. Start-1 will have remained 0 upon exit.
351 (when (zerop ,start-1)
353 ;; if we just merged into the temporary, copy it all back
354 ;; to the given vector.
355 (dotimes (,i ,vector-len)
356 (setf (,vector-ref ,vector ,i)
357 (svref *merge-sort-temp-vector* ,i))))
359 (setf ,n (ash ,n 1)) ; (* 2 n)
360 (setf ,direction (not ,direction))))))
364 ;;; temporary vector for stable sorting vectors
365 (defvar *merge-sort-temp-vector*
368 (declaim (simple-vector *merge-sort-temp-vector*))
370 (defun stable-sort-simple-vector (vector pred key)
371 (declare (simple-vector vector))
372 (vector-merge-sort vector pred key svref))
374 (defun stable-sort-vector (vector pred key)
375 (vector-merge-sort vector pred key aref))
379 (eval-when (:compile-toplevel :execute)
381 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
382 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
383 ;;; are chosen only if they are strictly less than elements of
384 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
385 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
386 result-vector pred key access)
387 (let ((result-i (gensym))
390 `(let* ((,result-i 0)
393 (declare (fixnum ,result-i ,i ,j))
395 (cond ((= ,i ,length-1)
396 (loop (if (= ,j ,length-2) (return))
397 (setf (,access ,result-vector ,result-i)
398 (,access ,vector-2 ,j))
401 (return ,result-vector))
403 (loop (if (= ,i ,length-1) (return))
404 (setf (,access ,result-vector ,result-i)
405 (,access ,vector-1 ,i))
408 (return ,result-vector))
409 ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
411 (setf (,access ,result-vector ,result-i)
412 (,access ,vector-2 ,j))
414 (t (setf (,access ,result-vector ,result-i)
415 (,access ,vector-1 ,i))
421 (defun merge (result-type sequence1 sequence2 predicate &key key)
423 "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
424 sequence of type RESULT-TYPE using PREDICATE to order the elements."
425 (let ((type (specifier-type result-type)))
427 ((csubtypep type (specifier-type 'list))
428 ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
429 ;; benefits from the error checking there. Short of
430 ;; reimplementing everything, we can't do the same for the LIST
431 ;; case, so do relevant length checking here:
432 (let ((s1 (coerce sequence1 'list))
433 (s2 (coerce sequence2 'list)))
434 (when (type= type (specifier-type 'list))
435 (return-from merge (values (merge-lists* s1 s2 predicate key))))
436 (when (eq type *empty-type*)
437 (bad-sequence-type-error nil))
438 (when (type= type (specifier-type 'null))
439 (if (and (null s1) (null s2))
440 (return-from merge 'nil)
441 ;; FIXME: This will break on circular lists (as,
442 ;; indeed, will the whole MERGE function).
443 (sequence-type-length-mismatch-error type
446 (if (csubtypep (specifier-type '(cons nil t)) type)
447 (if (and (null s1) (null s2))
448 (sequence-type-length-mismatch-error type 0)
449 (values (merge-lists* s1 s2 predicate key)))
450 (sequence-type-too-hairy result-type))))
451 ((csubtypep type (specifier-type 'vector))
452 (let* ((vector-1 (coerce sequence1 'vector))
453 (vector-2 (coerce sequence2 'vector))
454 (length-1 (length vector-1))
455 (length-2 (length vector-2))
456 (result (make-sequence result-type
457 (+ length-1 length-2))))
458 (declare (vector vector-1 vector-2)
459 (fixnum length-1 length-2))
460 (if (and (simple-vector-p result)
461 (simple-vector-p vector-1)
462 (simple-vector-p vector-2))
463 (merge-vectors vector-1 length-1 vector-2 length-2
464 result predicate key svref)
465 (merge-vectors vector-1 length-1 vector-2 length-2
466 result predicate key aref))))
467 (t (bad-sequence-type-error result-type)))))