-;;; 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 key)
- (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
- (pred-fun (%coerce-callable-to-fun pred))
- (key-fun (if key
- (%coerce-callable-to-fun key)
- #'identity)))
- (declare (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))))))