Email Archive: sbcl-commits (read-only)
|
[Sbcl-commits] master: More efficient (stable) sort of lists
From: Paul Khuong <pkhuong@us...> - 2012-08-13 06:47
|
The branch "master" has been updated in SBCL:
via 088583ae2b22d8d861fbc354568bd24edc0333cb (commit)
from 9ec385d7e964b5d07f2e075db4c9faa07161aca2 (commit)
- Log -----------------------------------------------------------------
commit 088583ae2b22d8d861fbc354568bd24edc0333cb
Author: Paul Khuong <pvk@...>
Date: Mon Aug 13 02:40:54 2012 -0400
More efficient (stable) sort of lists
* (Reverse-) Sorted runs are mostly processed in linear time;
* Calls to the :key function are cached;
* Base cases now include specialised sorts for lists of
length 3 and shorter.
* Minimal test case for stable sorting.
---
NEWS | 2 +
src/code/sort.lisp | 113 +++++++++++++++++++++++++++++++++++++++-----------
tests/seq.pure.lisp | 34 +++++++++++++++
3 files changed, 124 insertions(+), 25 deletions(-)
diff --git a/NEWS b/NEWS
index c38625f..3caaead 100644
--- a/NEWS
+++ b/NEWS
@@ -1,5 +1,7 @@
;;;; -*- coding: utf-8; fill-column: 78 -*-
changes relative to sbcl-1.0.58:
+ * optimization: CL:SORT and CL:STABLE-SORT of lists are faster and use fewer
+ comparisons, particularly on almost-sorted inputs.
* documentation: a section on random number generation has been added to the
manual. (lp#656839)
diff --git a/src/code/sort.lisp b/src/code/sort.lisp
index 504e178..970defb 100644
--- a/src/code/sort.lisp
+++ b/src/code/sort.lisp
@@ -81,21 +81,24 @@
(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
- (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)))))
+ (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))))))
;;; Convenience wrapper for CL:MERGE
(declaim (inline merge-lists))
@@ -109,29 +112,89 @@
(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 ((recur (list size)
+ (labels ((merge* (size list1 tail1 list2 tail2 rest)
+ (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))
- (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)))))))
+ (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))))))
diff --git a/tests/seq.pure.lisp b/tests/seq.pure.lisp
index ab1c8ba..2941097 100644
--- a/tests/seq.pure.lisp
+++ b/tests/seq.pure.lisp
@@ -336,3 +336,37 @@
(t #'shuffle))
size type)
#'<))))))))
+
+(with-test (:name :stable-sort-smoke-test)
+ (flet ((iota (n type &aux (i 0))
+ (map-into (make-sequence type n)
+ (lambda ()
+ (cons 0 (incf i)))))
+ (shuffle (n type)
+ (let ((max (truncate (expt n 1/4)))
+ (i 0))
+ (map-into (make-sequence type n)
+ (lambda ()
+ (cons (random max) (incf i))))))
+ (sortedp (x)
+ (let* ((nonce (list nil))
+ (prev nonce))
+ (every (lambda (x)
+ (prog1 (or (eql prev nonce)
+ (< (car prev) (car x))
+ (and (= (car prev) (car x))
+ (< (cdr prev) (cdr x))))
+ (setf prev x)))
+ x))))
+ (dolist (type '(simple-vector list))
+ (dolist (size '(0 1 2 3 4 5 6 7 8
+ 9 10 11 12 13 14 15 16 17
+ 1023 1024 1025 1536))
+ (loop for repeat below 5 do
+ (assert
+ (sortedp
+ (stable-sort (funcall (case repeat
+ (0 #'iota)
+ (t #'shuffle))
+ size type)
+ #'< :key #'car))))))))
-----------------------------------------------------------------------
hooks/post-receive
--
SBCL
|
Thread View
| Thread | Author | Date |
|---|---|---|
| [Sbcl-commits] master: More efficient (stable) sort of lists | Paul Khuong <pkhuong@us...> |