;;; application where sorting is a major bottleneck, and inlining it
;;; allows the compiler to make enough optimizations that it might be
;;; worth the (large) cost in space.
-(declaim (maybe-inline sort))
+(declaim (maybe-inline sort stable-sort))
(defun sort (sequence predicate &rest args &key key)
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
) ; EVAL-WHEN
\f
;;;; stable sort of lists
-
-(defun last-cons-of (list)
- (loop (let ((rest (rest list)))
- (if rest
- (setf list rest)
- (return list)))))
+(declaim (maybe-inline merge-lists* stable-sort-list))
;;; Destructively merge LIST-1 with LIST-2 (given that they're already
;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
;;; way). In the resulting list, elements of LIST-1 are guaranteed to
;;; come before equal elements of LIST-2.
;;;
-;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
-;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
-;;; the last cons in the list which NRECONC calls TAIL).
-(defun merge-lists* (list-1 list-2 pred-fun key-fun)
- (declare (type list list-1 list-2))
- (declare (type function pred-fun key-fun))
- (cond ((null list-1) (values list-2 (last-cons-of list-2)))
- ((null list-2) (values list-1 (last-cons-of list-1)))
- (t (let* ((reversed-result-so-far nil)
- (key-1 (funcall key-fun (car list-1)))
- (key-2 (funcall key-fun (car list-2))))
- (loop
- (macrolet ((frob (list-i key-i other-list)
- `(progn
- ;; basically
- ;; (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
- ;; except doing some fancy footwork to
- ;; reuse the cons cell:
- (psetf (cdr ,list-i) reversed-result-so-far
- reversed-result-so-far ,list-i
- ,list-i (cdr ,list-i))
- ;; Now maybe we're done.
- (if (endp ,list-i)
- (return (values (nreconc
- reversed-result-so-far
- ,other-list)
- (last-cons-of
- ,other-list)))
- (setf ,key-i
- (funcall key-fun (car ,list-i)))))))
- ;; Note that by making KEY-2 the first arg to
- ;; PRED-FUN, we arrange that if PRED-FUN is a function
- ;; in the #'< style, the outcome is stably sorted.
- (if (funcall pred-fun key-2 key-1)
- (frob list-2 key-2 list-1)
- (frob list-1 key-1 list-2))))))))
+;;; Enqueues the values in the right order in HEAD's cdr, and returns
+;;; the merged list.
+(defun merge-lists* (head list1 list2 test key &aux (tail head))
+ (declare (type cons head list1 list2)
+ (type function test key)
+ (optimize speed))
+ (let ((key1 (funcall key (car list1)))
+ (key2 (funcall key (car list2))))
+ (macrolet ((merge-one (l1 k1 l2)
+ `(progn
+ (setf (cdr tail) ,l1
+ tail ,l1)
+ (let ((rest (cdr ,l1)))
+ (cond (rest
+ (setf ,l1 rest
+ ,k1 (funcall key (first rest))))
+ (t
+ (setf (cdr ,l1) ,l2)
+ (return (cdr head))))))))
+ (loop
+ (if (funcall test key2 ; this way, equivalent
+ key1) ; values are first popped
+ (merge-one list2 key2 list1) ; from list1
+ (merge-one list1 key1 list2))))))
-;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
-;;; over the list grabbing one element at a time and merging it with
-;;; the next one to form pairs of sorted elements. Then N is doubled,
-;;; and elements are taken in runs of two, merging one run with the
-;;; next to form quadruples of sorted elements. This continues until N
-;;; is large enough that the inner loop only runs for one iteration;
-;;; that is, there are only two runs that can be merged, the first run
-;;; starting at the beginning of the list, and the second being the
-;;; remaining elements.
-(defun stable-sort-list (list pred-fun key-fun)
- (let ((head (cons :header list)) ; head holds on to everything
- (n 1) ; bottom-up size of lists to be merged
- unsorted ; unsorted is the remaining list to be
- ; broken into n size lists and merged
- list-1 ; list-1 is one length n list to be merged
- last) ; last points to the last visited cell
- (declare (type function pred-fun key-fun)
- (type fixnum n))
- (loop
- ;; Start collecting runs of N at the first element.
- (setf unsorted (cdr head))
- ;; Tack on the first merge of two N-runs to the head holder.
- (setf last head)
- (let ((n-1 (1- n)))
- (declare (fixnum n-1))
- (loop
- (setf list-1 unsorted)
- (let ((temp (nthcdr n-1 list-1))
- list-2)
- (cond (temp
- ;; There are enough elements for a second run.
- (setf list-2 (cdr temp))
- (setf (cdr temp) nil)
- (setf temp (nthcdr n-1 list-2))
- (cond (temp
- (setf unsorted (cdr temp))
- (setf (cdr temp) nil))
- ;; The second run goes off the end of the list.
- (t (setf unsorted nil)))
- (multiple-value-bind (merged-head merged-last)
- (merge-lists* list-1 list-2 pred-fun key-fun)
- (setf (cdr last) merged-head
- last merged-last))
- (if (null unsorted) (return)))
- ;; If there is only one run, then tack it on to the end.
- (t (setf (cdr last) list-1)
- (return)))))
- (setf n (ash n 1)) ; (+ n n)
- ;; If the inner loop only executed once, then there were only
- ;; enough elements for two runs given n, so all the elements
- ;; have been merged into one list. This may waste one outer
- ;; iteration to realize.
- (if (eq list-1 (cdr head))
- (return list-1))))))
+;;; Convenience wrapper for CL:MERGE
+(declaim (inline merge-lists))
+(defun merge-lists (list1 list2 test key)
+ (cond ((null list1)
+ list2)
+ ((null list2)
+ list1)
+ (t
+ (let ((head (cons nil nil)))
+ (declare (dynamic-extent head))
+ (merge-lists* head list1 list2 test key)))))
+
+;;; Small specialised stable sorts
+(declaim (inline stable-sort-list-2 stable-sort-list-3))
+(defun stable-sort-list-2 (list test key)
+ (declare (type cons list)
+ (type function test key))
+ (let ((second (cdr list)))
+ (declare (type cons second))
+ (when (funcall test (funcall key (car second))
+ (funcall key (car list)))
+ (rotatef (car list) (car second)))
+ (values list second (shiftf (cdr second) nil))))
+
+(defun stable-sort-list-3 (list test key)
+ (declare (type cons list)
+ (type function test key))
+ (let* ((second (cdr list))
+ (third (cdr second))
+ (x (car list))
+ (y (car second))
+ (z (car third)))
+ (declare (type cons second third))
+ (when (funcall test (funcall key y)
+ (funcall key x))
+ (rotatef x y))
+ (let ((key-z (funcall key z)))
+ (when (funcall test key-z
+ (funcall key y))
+ (if (funcall test key-z
+ (funcall key x))
+ (rotatef x z y)
+ (rotatef z y))))
+ (setf (car list) x
+ (car second) y
+ (car third) z)
+ (values list third (shiftf (cdr third) nil))))
+
+;;; STABLE-SORT-LIST implements a top-down merge sort. See the closest
+;;; intro to algorithms book. Benchmarks have shown significantly
+;;; improved performance over the previous (hairier) bottom-up
+;;; implementation, particularly on non-power-of-two sizes: bottom-up
+;;; recursed on power-of-two-sized subsequences, which can result in
+;;; very unbalanced recursion trees.
+
+;;; The minimum length at which list merge sort will try and detect
+;;; it can merge disjoint ranges (e.g. sorted inputs) in constant time.
+(defconstant +stable-sort-fast-merge-limit+ 8)
+
+(defun stable-sort-list (list test key &aux (head (cons :head list)))
+ (declare (type list list)
+ (type function test key)
+ (dynamic-extent head))
+ (labels ((merge* (size list1 tail1 list2 tail2 rest)
+ (declare (optimize speed)
+ (type (and fixnum unsigned-byte) size)
+ (type cons list1 tail1 list2 tail2))
+ (when (>= size +stable-sort-fast-merge-limit+)
+ (cond ((not (funcall test (funcall key (car list2)) ; stability
+ (funcall key (car tail1)))) ; trickery
+ (setf (cdr tail1) list2)
+ (return-from merge* (values list1 tail2 rest)))
+ ((funcall test (funcall key (car tail2))
+ (funcall key (car list1)))
+ (setf (cdr tail2) list1)
+ (return-from merge* (values list2 tail1 rest)))))
+ (values (merge-lists* head list1 list2 test key)
+ (if (null (cdr tail1))
+ tail1
+ tail2)
+ rest))
+ (recur (list size)
+ (declare (optimize speed)
+ (type cons list)
+ (type (and fixnum unsigned-byte) size))
+ (cond ((> size 3)
+ (let ((half (ash size -1)))
+ (multiple-value-bind (list1 tail1 rest)
+ (recur list half)
+ (multiple-value-bind (list2 tail2 rest)
+ (recur rest (- size half))
+ (merge* size list1 tail1 list2 tail2 rest)))))
+ ((= size 3)
+ (stable-sort-list-3 list test key))
+ ((= size 2)
+ (stable-sort-list-2 list test key))
+ (t ; (= size 1)
+ (values list list (shiftf (cdr list) nil))))))
+ (when list
+ (values (recur list (length list))))))
\f
;;;; stable sort of vectors
;; FIXME: This implementation is remarkably inefficient in various
;; ways. In decreasing order of estimated user astonishment, I note:
;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
- ;; to lists before doing MERGE-LISTS*; and walking input lists
- ;; (because of the call to MERGE-LISTS*, which walks the list to
- ;; find the last element for its second return value) even in cases
- ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
- ;; can be largely ignored. -- WHN 2003-01-05
+ ;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
(let ((type (specifier-type result-type)))
(cond
((csubtypep type (specifier-type 'list))
(%coerce-callable-to-fun key)
#'identity)))
(when (type= type (specifier-type 'list))
- (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun))))
+ (return-from merge (merge-lists s1 s2 pred-fun key-fun)))
(when (eq type *empty-type*)
(bad-sequence-type-error nil))
(when (type= type (specifier-type 'null))
(sequence-type-length-mismatch-error type length))
(unless (>= length min)
(sequence-type-length-mismatch-error type length)))
- (values (merge-lists* s1 s2 pred-fun key-fun))))
+ (merge-lists s1 s2 pred-fun key-fun)))
(sequence-type-too-hairy result-type))))
((csubtypep type (specifier-type 'vector))
(let* ((vector-1 (coerce sequence1 'vector))