From: Paul Khuong Date: Mon, 13 Aug 2012 06:40:54 +0000 (-0400) Subject: More efficient (stable) sort of lists X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=088583ae2b22d8d861fbc354568bd24edc0333cb;p=sbcl.git 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. --- 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))))))))