source: trunk/abcl/src/org/armedbear/lisp/sort.lisp @ 13870

Last change on this file since 13870 was 13870, checked in by Mark Evenson, 10 years ago

See #196: further patch for STABLE-SORT from Jorge Tavares.

easye: still seeing the ANSI failures, but this is a much more
plausible "final" implementation with the appropiate optimizations
which should be easier to fix modulo the possible hairy macro
debugging part. But that's why they call it trunk, right?

I send in attach a patch with further improvements to sort and
stable-sort for sequences other than lists. In short, the patch
includes a merge sort for vectors. To allow different types I've
written the algorithm using macros and these generate the appropriate
code according to the vector type. This way the algorithm is in a
single place avoiding duplication of code. The macros also take care
of the situation of when no key is present, avoiding the use of
unnecessary funcalls. The quicksort algorithm was also refactored in
the same way.

I've tested the algorithms and they seem to be working correct. Stable
sort is now considerably faster since the fix before converted the
sequences to a list and used the sort-list function. I've made some
benchmarking to verify how fast is sort and stable-sort. The tables
with the results are also in a file sent in attach [1]. For
stable-sort I've compare the current trunk version with the patched
one while for sort I've compared 1.0.1, the trunk and with the
patch. For unsorted vectors sort has a speed up of 7.5 from 1.0.1 and
this considers only vectors of size 8 to 8192 (1.0.1 hits the
worst-case quite fast). For stable-sort the speed up is around 90.2
from vectors of size 8 to 32768. The sort functions become even faster
for the nearly sorted vectors. I think the tables clearly show t he

Naturally these benchmarks cannot be used to draw definite conclusions
since they lack rigorous testing but I think they can provide some
indications. With this patch, I think ABCL gets good performant
sorting functions, especially for large vectors. As for lists, I
haven't looked at them so probably they can also be improved (but I
really don't know).


[1] The tables result from the generation of simple-vectors of sizes 8
to 524288 (powers of 2 from 3 to 19) with distinct integer: unsorted,
nearly sorted (distances 0, 4 and 16), sorted and reversed sorted. The
nearly sorted vectors were constructed by selecting pairs where they
would swap with a neighbor at a certain distance. I did 100 runs and
timed only the sorting operation. The tables contain the averages of
the 100 runs. They were performed in an iMac (2.5GHz i5, 4GB) with Mac
OS X 10.7.3.


  • Property svn:eol-style set to native
  • Property svn:keywords set to Id
File size: 15.0 KB
1;;; sort.lisp
3;;; Copyright (C) 2003-2005 Peter Graves
4;;; $Id: sort.lisp 13870 2012-02-11 15:53:33Z mevenson $
6;;; This program is free software; you can redistribute it and/or
7;;; modify it under the terms of the GNU General Public License
8;;; as published by the Free Software Foundation; either version 2
9;;; of the License, or (at your option) any later version.
11;;; This program is distributed in the hope that it will be useful,
12;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
14;;; GNU General Public License for more details.
16;;; You should have received a copy of the GNU General Public License
17;;; along with this program; if not, write to the Free Software
18;;; Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA  02111-1307, USA.
20;;; As a special exception, the copyright holders of this library give you
21;;; permission to link this library with independent modules to produce an
22;;; executable, regardless of the license terms of these independent
23;;; modules, and to copy and distribute the resulting executable under
24;;; terms of your choice, provided that you also meet, for each linked
25;;; independent module, the terms and conditions of the license of that
26;;; module.  An independent module is a module which is not derived from
27;;; or based on this library.  If you modify this library, you may extend
28;;; this exception to your version of the library, but you are not
29;;; obligated to do so.  If you do not wish to do so, delete this
30;;; exception statement from your version.
32(in-package #:system)
41;;; MERGE SORT for vectors (and sequences in general)
43;;; - top-down stable merge sort
44;;; - it is defined with 2 macros to allow a single algorithm
45;;;   and multiple sequence types: merge-vectors-body and merge-sort-body
46;;; - merge-vectors-body merges two given sequences
47;;; - merge-sort-body contains the top-down algorithm
48;;; - the body macro is called by the merge-sort-vectors functions,
49;;;   which typecases the type of sequence and expands the apropriate body
50;;; - more types of sequences/vectors can be added
51;;; - the macros generate the merge sort body with or without funcall to key
52;;; - the merge-vectors algorithm is inspired from the CCL base code
55(defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key)
56  (let ((i-a (gensym)) 
57  (i-b (gensym))
58  (i-aux (gensym))
59  (v-a (gensym))
60  (v-b (gensym))
61  (k-a (gensym))
62  (k-b (gensym))
63  (merge-block (gensym))) 
64    `(locally
65   (declare (type fixnum ,start-a ,end-a ,start-b ,end-b ,start-aux)
66      (type ,type ,a ,b)
67      (type simple-vector ,aux)
68      (type function ,predicate ,@(if key `(,key)))
69      (optimize (speed 3) (safety 0)))
70       (block ,merge-block
71    (let ((,i-a ,start-a)
72    (,i-b ,start-b)
73    (,i-aux ,start-aux)
74    ,v-a ,v-b ,k-a ,k-b)
75      (declare (type fixnum ,i-a ,i-b ,i-aux))
76      (cond ((= ,start-a ,end-a)
77       (when (= ,start-b ,end-b)
78         (return-from ,merge-block))
79       (setf ,i-a ,start-b
80       ,end-a ,end-b
81       ,a ,b
82       ,v-a (,ref ,a ,i-a)))
83      ((= ,start-b ,end-b)
84       (setf ,i-a ,start-a
85       ,v-a (,ref ,a ,i-a)))
86      (t
87       (setf ,v-a (,ref ,a ,i-a)
88       ,v-b (,ref ,b ,i-b)
89       ,@(if key 
90             `(,k-a (funcall ,key ,v-a))
91             `(,k-a ,v-a))
92       ,@(if key 
93             `(,k-b (funcall ,key ,v-b))
94             `(,k-b ,v-b)))
95       (loop 
96         (if (funcall ,predicate ,k-b ,k-a)
97       (progn 
98         (setf (svref ,aux ,i-aux) ,v-b
99         ,i-aux (+ ,i-aux 1)
100         ,i-b (+ ,i-b 1))
101         (when (= ,i-b ,end-b) (return))
102         (setf ,v-b (,ref ,b ,i-b)
103         ,@(if key 
104               `(,k-b (funcall ,key ,v-b))
105               `(,k-b ,v-b))))
106       (progn 
107         (setf (svref ,aux ,i-aux) ,v-a
108         ,i-aux (+ ,i-aux 1)
109         ,i-a (+ ,i-a 1))
110         (when (= ,i-a ,end-a)
111           (setf ,a ,b 
112           ,i-a ,i-b 
113           ,end-a ,end-b 
114           ,v-a ,v-b)
115           (return))
116         (setf ,v-a (,ref ,a ,i-a)
117         ,@(if key 
118               `(,k-a (funcall ,key ,v-a))
119               `(,k-a ,v-a))))))))
120      (loop
121        (setf (svref ,aux ,i-aux) ,v-a
122        ,i-a (+ ,i-a 1))
123        (when (= ,i-a ,end-a) (return))
124        (setf ,v-a (,ref ,a ,i-a)
125        ,i-aux (+ ,i-aux 1))))))))
127(defmacro merge-sort-body (type ref mpredicate mkey msequence mstart mend)
128  (let ((merge-sort-call (gensym))
129  (maux (gensym))
130  (aux (gensym))
131  (sequence (gensym))
132  (start (gensym))
133  (end (gensym))
134  (predicate (gensym))
135  (key (gensym))
136  (mid (gensym))
137  (direction (gensym)))
138    `(locally
139   (declare (optimize (speed 3) (safety 0)))
140       (labels ((,merge-sort-call (,sequence ,start ,end ,predicate ,key ,aux ,direction)
141      (declare (type function ,predicate ,@(if mkey `(,key)))
142         (type fixnum ,start ,end)
143         (type ,type ,sequence))
144      (let ((,mid (+ ,start (ash (- ,end ,start) -1))))
145        (declare (type fixnum ,mid))
146        (if (<= (- ,mid 1) ,start)
147      (unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start)))
148      (,merge-sort-call ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction)))
149        (if (>= (+ ,mid 1) ,end)
150      (unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid)))
151      (,merge-sort-call ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction)))
152        (unless ,direction (psetq ,sequence ,aux ,aux ,sequence))
153        ,(if mkey
154       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
155                ,mid ,end ,aux ,start ,predicate ,key)
156       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
157                ,mid ,end ,aux ,start ,predicate)))))
158   (let ((,maux (make-array ,mend)))
159     (declare (type simple-vector ,maux))
160     (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil))))))
162(defun merge-sort-vectors (sequence predicate key)
163  (let ((end (length sequence)))
164    (typecase sequence
165      (simple-vector 
166       (if key
167     (merge-sort-body simple-vector svref predicate key sequence 0 end)
168     (merge-sort-body simple-vector svref predicate nil sequence 0 end)))
169      (vector 
170       (if key
171     (merge-sort-body vector aref predicate key sequence 0 end)
172     (merge-sort-body vector aref predicate nil sequence 0 end))))
173    sequence))
177;;;  MERGE SORT for lists
180;; Adapted from SBCL.
181(declaim (ftype (function (list) cons) last-cons-of))
182(defun last-cons-of (list)
183  (loop
184    (let ((rest (rest list)))
185      (if rest
186          (setf list rest)
187          (return list)))))
189;; Adapted from OpenMCL.
190(defun merge-lists (list1 list2 pred key)
191  (declare (optimize (speed 3) (safety 0)))
192  (if (null key)
193      (merge-lists-no-key list1 list2 pred)
194      (cond ((null list1)
195             (values list2 (last-cons-of list2)))
196            ((null list2)
197             (values list1 (last-cons-of list1)))
198            (t
199             (let* ((result (cons nil nil))
200                    (p result)               ; p points to last cell of result
201                    (key1 (funcall key (car list1)))
202                    (key2 (funcall key (car list2))))
203               (declare (type list p))
204               (loop
205                 (cond ((funcall pred key2 key1)
206                        (rplacd p list2)     ; append the lesser list to last cell of
207                        (setf p (cdr p))     ;   result.  Note: test must bo done for
208                        (pop list2)          ;   list2 < list1 so merge will be
209                        (unless list2        ;   stable for list1
210                          (rplacd p list1)
211                          (return (values (cdr result) (last-cons-of p))))
212                        (setf key2 (funcall key (car list2))))
213                       (t
214                        (rplacd p list1)
215                        (setf p (cdr p))
216                        (pop list1)
217                        (unless list1
218                          (rplacd p list2)
219                          (return (values (cdr result) (last-cons-of p))))
220                        (setf key1 (funcall key (car list1)))))))))))
222(defun merge-lists-no-key (list1 list2 pred)
223  (declare (optimize (speed 3) (safety 0)))
224  (cond ((null list1)
225         (values list2 (last-cons-of list2)))
226        ((null list2)
227         (values list1 (last-cons-of list1)))
228        (t
229         (let* ((result (cons nil nil))
230                (p result)                   ; p points to last cell of result
231                (key1 (car list1))
232                (key2 (car list2)))
233           (declare (type list p))
234           (loop
235             (cond ((funcall pred key2 key1)
236                    (rplacd p list2)         ; append the lesser list to last cell of
237                    (setf p (cdr p))         ;   result.  Note: test must bo done for
238                    (pop list2)              ;   list2 < list1 so merge will be
239                    (unless list2            ;   stable for list1
240                      (rplacd p list1)
241                      (return (values (cdr result) (last-cons-of p))))
242                    (setf key2 (car list2)))
243                   (t
244                    (rplacd p list1)
245                    (setf p (cdr p))
246                    (pop list1)
247                    (unless list1
248                      (rplacd p list2)
249                      (return (values (cdr result) (last-cons-of p))))
250                    (setf key1 (car list1)))))))))
252;;; SORT-LIST uses a bottom up merge sort.  First a pass is made over
253;;; the list grabbing one element at a time and merging it with the next one
254;;; form pairs of sorted elements.  Then n is doubled, and elements are taken
255;;; in runs of two, merging one run with the next to form quadruples of sorted
256;;; elements.  This continues until n is large enough that the inner loop only
257;;; runs for one iteration; that is, there are only two runs that can be merged,
258;;; the first run starting at the beginning of the list, and the second being
259;;; the remaining elements.
261(defun sort-list (list pred key)
262  (when (or (eq key #'identity) (eq key 'identity))
263    (setf key nil))
264  (let ((head (cons nil list)) ; head holds on to everything
265        (n 1)                  ; bottom-up size of lists to be merged
266        unsorted               ; unsorted is the remaining list to be
267                               ;   broken into n size lists and merged
268        list-1                 ; list-1 is one length n list to be merged
269        last                   ; last points to the last visited cell
270        )
271    (declare (type fixnum n))
272    (loop
273      ;; start collecting runs of n at the first element
274      (setf unsorted (cdr head))
275      ;; tack on the first merge of two n-runs to the head holder
276      (setf last head)
277      (let ((n-1 (1- n)))
278        (declare (type fixnum n-1))
279        (loop
280          (setf list-1 unsorted)
281          (let ((temp (nthcdr n-1 list-1))
282                list-2)
283            (cond (temp
284                   ;; there are enough elements for a second run
285                   (setf list-2 (cdr temp))
286                   (setf (cdr temp) nil)
287                   (setf temp (nthcdr n-1 list-2))
288                   (cond (temp
289                          (setf unsorted (cdr temp))
290                          (setf (cdr temp) nil))
291                         ;; the second run goes off the end of the list
292                         (t (setf unsorted nil)))
293                   (multiple-value-bind (merged-head merged-last)
294                       (merge-lists list-1 list-2 pred key)
295                     (setf (cdr last) merged-head)
296                     (setf last merged-last))
297                   (if (null unsorted) (return)))
298                  ;; if there is only one run, then tack it on to the end
299                  (t (setf (cdr last) list-1)
300                     (return)))))
301        (setf n (+ n n))
302        ;; If the inner loop only executed once, then there were only enough
303        ;; elements for two runs given n, so all the elements have been merged
304        ;; into one list.  This may waste one outer iteration to realize.
305        (if (eq list-1 (cdr head))
306            (return list-1))))))
310;;; SORT
316;;; - algorithm is in the quicksort-body macro, so that it allows
317;;;   the use of different types (e.g., simple-vector, vector)
318;;; - the pivot is picked by selecting middle point
319;;; - sorts the smaller partition first
320;;; - the macro generates the quicksort body with or without funcall to key
323(defmacro quicksort-body (type ref mpredicate mkey sequence mstart mend)
324  (let ((quicksort-call (gensym))
325  (predicate (gensym))
326  (key (gensym))
327  (vector (gensym))
328  (start (gensym))
329  (end (gensym))
330  (i (gensym))
331  (j (gensym))
332  (p (gensym))
333  (d (gensym))
334  (kd (gensym)))
335    `(locally 
336   (declare (speed 3) (safety 0))
337       (labels ((,quicksort-call (,vector ,start ,end ,predicate ,key)
338       (declare (type function ,predicate ,@(if mkey `(,key)))
339          (type fixnum ,start ,end)
340          (type ,type ,sequence))
341       (if (< ,start ,end)
342           (let* ((,i ,start)
343            (,j (1+ ,end))
344            (,p (the fixnum (+ ,start (ash (- ,end ,start) -1))))
345            (,d (,ref ,vector ,p))
346            ,@(if mkey
347            `((,kd (funcall ,key ,d)))
348            `((,kd ,d))))
349       (rotatef (,ref ,vector ,p) (,ref ,vector ,start))
350       (block outer-loop
351         (loop
352           (loop 
353             (unless (> (decf ,j) ,i) (return-from outer-loop))
354             (when (funcall ,predicate 
355                ,@(if mkey 
356                `((funcall ,key (,ref ,vector ,j)))
357                `((,ref ,vector ,j)))
358                ,kd) (return)))
359           (loop 
360             (unless (< (incf ,i) ,j) (return-from outer-loop))
361             (unless (funcall ,predicate
362            ,@(if mkey 
363                `((funcall ,key (,ref ,vector ,i)))
364                `((,ref ,vector ,i)))
365            ,kd) (return)))
366           (rotatef (,ref ,vector ,i) (,ref ,vector ,j))))
367       (setf (,ref ,vector ,start) (,ref ,vector ,j)
368             (,ref ,vector ,j) ,d)
369       (if (< (- ,j ,start) (- ,end ,j))
370           (progn
371             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)
372             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key))
373           (progn
374             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key)
375             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)))))))
376   (,quicksort-call ,sequence ,mstart ,mend ,mpredicate ,mkey)))))
378(defun quicksort (sequence predicate key)
379  (let ((end (1- (length sequence))))
380    (typecase sequence
381      (simple-vector 
382       (if key
383     (quicksort-body simple-vector svref predicate key sequence 0 end)
384     (quicksort-body simple-vector svref predicate nil sequence 0 end)))
385      (vector 
386       (if key
387     (quicksort-body vector aref predicate key sequence 0 end)
388     (quicksort-body vector aref predicate nil sequence 0 end))))
389    sequence))
393;;; main SORT and STABLE-SORT function calls
395;;; - sort: quicksort and merge sort (only for lists)
396;;; - stable-sort: merge sort (all types)
399(defun sort (sequence predicate &rest args &key key)
400  (sequence::seq-dispatch sequence
401    (sort-list sequence predicate key)
402    (quicksort sequence predicate key)
403    (apply #'sequence:sort sequence predicate args)))
405(defun stable-sort (sequence predicate &rest args &key key)
406  (sequence::seq-dispatch sequence
407    (sort-list sequence predicate key)
408    (merge-sort-vectors sequence predicate key)
409    (apply #'sequence:stable-sort sequence predicate args)))
Note: See TracBrowser for help on using the repository browser.