Menu
▾
▴
[Sbcl-commits] master: Improved merge-sort implementation for lists
|
From: Paul K. <pk...@us...> - 2012-06-17 08:57:42
|
The branch "master" has been updated in SBCL:
via 41c307979e17a33e8700c1ca92ed8b3400a301b3 (commit)
from d720bc359f03734ccb9baf66cb45dc01d623f369 (commit)
- Log -----------------------------------------------------------------
commit 41c307979e17a33e8700c1ca92ed8b3400a301b3
Author: Paul Khuong <pv...@pv...>
Date: Sun Jun 17 10:53:47 2012 +0200
Improved merge-sort implementation for lists
The new implementation is simpler and more efficient than the previous
bottom-up sort. It only differs from the original patch aesthetically.
STABLE-SORT-LIST is also now MAYBE-INLINE, to enable selective inlining.
Thanks to Takeru Ohta for the code and for his patience.
---
NEWS | 3 +
src/code/sort.lisp | 167 ++++++++++++++-----------------------
tests/dynamic-extent.impure.lisp | 4 +-
tests/seq.pure.lisp | 33 ++++++++
4 files changed, 102 insertions(+), 105 deletions(-)
diff --git a/NEWS b/NEWS
index 2e0dba0..f9085fb 100644
--- a/NEWS
+++ b/NEWS
@@ -19,6 +19,9 @@ changes relative to sbcl-1.0.57:
function cannot escape.
* optimization: SB-SEQUENCE:DOSEQUENCE is faster on vectors of unknown
element type, and vectors that aren't SIMPLE-ARRAYs.
+ * optimization: CL:SORT and CL:STABLE-SORT are more efficient in execution
+ speed (around 1/3 the time in some cases), and a little better in terms of
+ comparison calls. (Thanks to Takeru Ohta)
* bug fix: On SPARC, a limitation on the number of code constants emittable
by the compiler has been lifted, allowing certain long functions to
compiled and assembled which had previously been unsupported; fixes
diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index 06cd2c6..504e178 100644
--- a/src/code/sort.lisp
+++ b/src/code/sort.lisp
@@ -18,7 +18,7 @@
;;; 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
@@ -68,109 +68,72 @@
) ; EVAL-WHEN
;;;; 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))))))
;;;; stable sort of vectors
@@ -348,11 +311,7 @@
;; 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))
@@ -367,7 +326,7 @@
(%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))
@@ -387,7 +346,7 @@
(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))
diff --git a/tests/dynamic-extent.impure.lisp b/tests/dynamic-extent.impure.lisp
index ff26c1d..4eebf0f 100644
--- a/tests/dynamic-extent.impure.lisp
+++ b/tests/dynamic-extent.impure.lisp
@@ -876,7 +876,9 @@
nil)))
(assert-notes 0 `(lambda (list)
(declare (optimize (space 0)))
- (sort list #'<)))
+ (sort list (lambda (x y) ; shut unrelated notes up
+ (< (truly-the fixnum x)
+ (truly-the fixnum y))))))
(assert-notes 0 `(lambda (other)
#'(lambda (s c n)
(ignore-errors (funcall other s c n)))))))
diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index ded374f..ab1c8ba 100644
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -303,3 +303,36 @@
(funcall (lambda ()
(declare (optimize speed))
(search #() #(1 1) :from-end t))))))
+
+(with-test (:name :sort-smoke-test)
+ (flet ((iota (n type &aux (i 0))
+ (map-into (make-sequence type n)
+ (lambda ()
+ (incf i))))
+ (shuffle (n type)
+ (let ((vector (let ((i 0))
+ (map-into (make-array n)
+ (lambda ()
+ (incf i))))))
+ (dotimes (i n (coerce vector type))
+ (let ((j (+ i (random (- n i)))))
+ (rotatef (aref vector i) (aref vector j))))))
+ (sortedp (x)
+ (let* ((nonce (list nil))
+ (prev nonce))
+ (every (lambda (x)
+ (prog1 (or (eql prev nonce)
+ (< prev x))
+ (setf prev x)))
+ x))))
+ (dolist (type '(simple-vector list))
+ (dolist (size '(7 8 9 13 1023 1024 1025 1536))
+ (loop for repeat below 5 do
+ (assert (sortedp
+ (sort (funcall (case repeat
+ (0 #'iota)
+ (1 (lambda (n type)
+ (reverse (iota n type))))
+ (t #'shuffle))
+ size type)
+ #'<))))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|