From: Paul Khuong <pkhuong@us...>  20120617 08:57:42

The branch "master" has been updated in SBCL: via 41c307979e17a33e8700c1ca92ed8b3400a301b3 (commit) from d720bc359f03734ccb9baf66cb45dc01d623f369 (commit)  Log  commit 41c307979e17a33e8700c1ca92ed8b3400a301b3 Author: Paul Khuong <pvk@...> Date: Sun Jun 17 10:53:47 2012 +0200 Improved mergesort implementation for lists The new implementation is simpler and more efficient than the previous bottomup sort. It only differs from the original patch aesthetically. STABLESORTLIST is also now MAYBEINLINE, to enable selective inlining. Thanks to Takeru Ohta for the code and for his patience.  NEWS  3 + src/code/sort.lisp  167 ++++++++++++++ tests/dynamicextent.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 sbcl1.0.57: function cannot escape. * optimization: SBSEQUENCE:DOSEQUENCE is faster on vectors of unknown element type, and vectors that aren't SIMPLEARRAYs. + * optimization: CL:SORT and CL:STABLESORT 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 (maybeinline sort)) +(declaim (maybeinline sort stablesort)) (defun sort (sequence predicate &rest args &key key) #!+sbdoc "Destructively sort SEQUENCE. PREDICATE should return nonNIL if @@ 68,109 +68,72 @@ ) ; EVALWHEN ;;;; stable sort of lists  (defun lastconsof (list)  (loop (let ((rest (rest list)))  (if rest  (setf list rest)  (return list))))) +(declaim (maybeinline mergelists* stablesortlist)) ;;; Destructively merge LIST1 with LIST2 (given that they're already ;;; sorted w.r.t. PREDFUN on KEYFUN, giving output sorted the same ;;; way). In the resulting list, elements of LIST1 are guaranteed to ;;; come before equal elements of LIST2. ;;; ;;; 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 mergelists* (list1 list2 predfun keyfun)  (declare (type list list1 list2))  (declare (type function predfun keyfun))  (cond ((null list1) (values list2 (lastconsof list2)))  ((null list2) (values list1 (lastconsof list1)))  (t (let* ((reversedresultsofar nil)  (key1 (funcall keyfun (car list1)))  (key2 (funcall keyfun (car list2))))  (loop  (macrolet ((frob (listi keyi otherlist)  `(progn  ;; basically  ;; (PUSH (POP ,LISTI) REVERSEDRESULTSOFAR),  ;; except doing some fancy footwork to  ;; reuse the cons cell:  (psetf (cdr ,listi) reversedresultsofar  reversedresultsofar ,listi  ,listi (cdr ,listi))  ;; Now maybe we're done.  (if (endp ,listi)  (return (values (nreconc  reversedresultsofar  ,otherlist)  (lastconsof  ,otherlist)))  (setf ,keyi  (funcall keyfun (car ,listi)))))))  ;; Note that by making KEY2 the first arg to  ;; PREDFUN, we arrange that if PREDFUN is a function  ;; in the #'< style, the outcome is stably sorted.  (if (funcall predfun key2 key1)  (frob list2 key2 list1)  (frob list1 key1 list2))))))))  ;;; STABLESORTLIST uses a bottomup 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 stablesortlist (list predfun keyfun)  (let ((head (cons :header list)) ; head holds on to everything  (n 1) ; bottomup size of lists to be merged  unsorted ; unsorted is the remaining list to be  ; broken into n size lists and merged  list1 ; list1 is one length n list to be merged  last) ; last points to the last visited cell  (declare (type function predfun keyfun)  (type fixnum n)) +;;; Enqueues the values in the right order in HEAD's cdr, and returns +;;; the merged list. +(defun mergelists* (head list1 list2 test key &aux (tail head)) + (declare (type cons head list1 list2) + (type function test key) + (optimize speed)) + (macrolet ((mergeone (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 Nruns to the head holder.  (setf last head)  (let ((n1 (1 n)))  (declare (fixnum n1))  (loop  (setf list1 unsorted)  (let ((temp (nthcdr n1 list1))  list2)  (cond (temp  ;; There are enough elements for a second run.  (setf list2 (cdr temp))  (setf (cdr temp) nil)  (setf temp (nthcdr n1 list2))  (cond (temp  (setf unsorted (cdr temp))  (setf (cdr temp) nil))  ;; The second run goes off the end of the list.  (t (setf unsorted nil)))  (multiplevaluebind (mergedhead mergedlast)  (mergelists* list1 list2 predfun keyfun)  (setf (cdr last) mergedhead  last mergedlast))  (if (null unsorted) (return)))  ;; If there is only one run, then tack it on to the end.  (t (setf (cdr last) list1)  (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 list1 (cdr head))  (return list1)))))) + (if (funcall test (funcall key (car list2)) ; this way, equivalent + (funcall key (car list1))) ; values are first popped + (mergeone list2 list1) ; from list1 + (mergeone list1 list2))))) + +;;; Convenience wrapper for CL:MERGE +(declaim (inline mergelists)) +(defun mergelists (list1 list2 test key) + (cond ((null list1) + list2) + ((null list2) + list1) + (t + (let ((head (cons nil nil))) + (declare (dynamicextent head)) + (mergelists* head list1 list2 test key))))) + +;;; STABLESORTLIST implements a topdown merge sort. See the closest +;;; intro to algorithms book. Benchmarks have shown significantly +;;; improved performance over the previous (hairier) bottomup +;;; implementation, particularly on nonpoweroftwo sizes: bottomup +;;; recursed on poweroftwosized subsequences, which can result in +;;; very unbalanced recursion trees. +(defun stablesortlist (list test key &aux (head (cons :head list))) + (declare (type list list) + (type function test key) + (dynamicextent head)) + (labels ((recur (list size) + (declare (optimize speed) + (type cons list) + (type (and fixnum unsignedbyte) size)) + (if (= 1 size) + (values list (shiftf (cdr list) nil)) + (let ((half (ash size 1))) + (multiplevaluebind (list1 rest) + (recur list half) + (multiplevaluebind (list2 rest) + (recur rest ( size half)) + (values (mergelists* 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 SPECIFIERTYPE at runtime; copying input vectors  ;; to lists before doing MERGELISTS*; and walking input lists  ;; (because of the call to MERGELISTS*, 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 20030105 + ;; to lists before doing MERGELISTS  WHN 20030105 (let ((type (specifiertype resulttype))) (cond ((csubtypep type (specifiertype 'list)) @@ 367,7 +326,7 @@ (%coercecallabletofun key) #'identity))) (when (type= type (specifiertype 'list))  (returnfrom merge (values (mergelists* s1 s2 predfun keyfun)))) + (returnfrom merge (mergelists s1 s2 predfun keyfun))) (when (eq type *emptytype*) (badsequencetypeerror nil)) (when (type= type (specifiertype 'null)) @@ 387,7 +346,7 @@ (sequencetypelengthmismatcherror type length)) (unless (>= length min) (sequencetypelengthmismatcherror type length)))  (values (mergelists* s1 s2 predfun keyfun)))) + (mergelists s1 s2 predfun keyfun))) (sequencetypetoohairy resulttype)))) ((csubtypep type (specifiertype 'vector)) (let* ((vector1 (coerce sequence1 'vector)) diff git a/tests/dynamicextent.impure.lisp b/tests/dynamicextent.impure.lisp index ff26c1d..4eebf0f 100644  a/tests/dynamicextent.impure.lisp +++ b/tests/dynamicextent.impure.lisp @@ 876,7 +876,9 @@ nil))) (assertnotes 0 `(lambda (list) (declare (optimize (space 0)))  (sort list #'<))) + (sort list (lambda (x y) ; shut unrelated notes up + (< (trulythe fixnum x) + (trulythe fixnum y)))))) (assertnotes 0 `(lambda (other) #'(lambda (s c n) (ignoreerrors (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) :fromend t)))))) + +(withtest (:name :sortsmoketest) + (flet ((iota (n type &aux (i 0)) + (mapinto (makesequence type n) + (lambda () + (incf i)))) + (shuffle (n type) + (let ((vector (let ((i 0)) + (mapinto (makearray 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 '(simplevector 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/postreceive  SBCL 