;;; 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))))))))
-
-;;; 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))
+;;; 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))
+ (macrolet ((merge-one (l1 l2)
+ `(progn
+ (setf (cdr tail) ,l1
+ tail ,l1)
+ (let ((rest (cdr ,l1)))
+ (cond (rest
+ (setf ,l1 rest))
+ (t
+ (setf (cdr ,l1) ,l2)
+ (return (cdr head))))))))
(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))))))
+ (if (funcall test (funcall key (car list2)) ; this way, equivalent
+ (funcall key (car list1))) ; values are first popped
+ (merge-one list2 list1) ; from list1
+ (merge-one list1 list2)))))
+
+;;; 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)))))
+
+;;; 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.
+(defun stable-sort-list (list test key &aux (head (cons :head list)))
+ (declare (type list list)
+ (type function test key)
+ (dynamic-extent head))
+ (labels ((recur (list size)
+ (declare (optimize speed)
+ (type cons list)
+ (type (and fixnum unsigned-byte) size))
+ (if (= 1 size)
+ (values list (shiftf (cdr list) nil))
+ (let ((half (ash size -1)))
+ (multiple-value-bind (list1 rest)
+ (recur list half)
+ (multiple-value-bind (list2 rest)
+ (recur rest (- size half))
+ (values (merge-lists* head list1 list2 test key)
+ rest)))))))
+ (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))
projects / sbcl.git / commitdiff