Changeset 13870


Ignore:
Timestamp:
02/11/12 15:53:33 (9 years ago)
Author:
Mark Evenson
Message:

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
speed-ups

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).

Cheers,
Jorge

[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.

[1]: http://article.gmane.org/gmane.lisp.armedbear.devel/2220

File:
1 edited

Legend:

Unmodified
Added
Removed
  • trunk/abcl/src/org/armedbear/lisp/sort.lisp

    r13852 r13870  
    3434(require "EXTENSIBLE-SEQUENCES-BASE")
    3535
    36 (defun sort (sequence predicate &rest args &key key)
    37   (sequence::seq-dispatch sequence
    38     (sort-list sequence predicate key)
    39     (quicksort sequence 0 (1- (length sequence)) predicate (or key #'identity))
    40     (apply #'sequence:sort sequence predicate args)))
    41 
    42 (defun stable-sort (sequence predicate &rest args &key key)
    43   (sequence::seq-dispatch sequence
    44     (sort-list sequence predicate key)
    45 ;;; Jorge Tavares:
    46 ;;; As a quick fix, I send in attach a patch that uses in stable-sort merge
    47 ;;; sort for all sequences. This is done by coercing the sequence to list,
    48 ;;; calling merge sort and coercing it back to the original sequence type.
    49 ;;; However, as a long term improvement, the best solution would be to
    50 ;;; implement a merge sort for non-list sequences.
    51     (coerce (sort-list (coerce sequence 'list)
    52            predicate
    53            key)
    54       (type-of sequence))
    55     (apply #'sequence:stable-sort sequence predicate args)))
     36;;;
     37;;; STABLE SORT
     38;;;
     39
     40;;;
     41;;; MERGE SORT for vectors (and sequences in general)
     42;;;
     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
     53;;;
     54
     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))))))))
     126
     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))))))
     161
     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))
     174
     175
     176;;;
     177;;;  MERGE SORT for lists
     178;;;
    56179
    57180;; Adapted from SBCL.
     
    183306            (return list-1))))))
    184307
    185 #|
    186 <> dc:author "Jorge Tavares" ;
    187     dc:description
    188 """
    189 The quicksort function picks the pivot by selecting a midpoint and
    190 also sorts the smaller partition first. These are enough to avoid the
    191 stack overflow problem as reported. I've performed some tests and it
    192 looks it is correct
    193 """" .
    194 |#
     308
     309;;;
     310;;; SORT
     311;;;
     312
    195313;;;
    196314;;; QUICKSORT
    197 ;;; - the pivot is a middle point
     315;;;
     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
    198319;;; - sorts the smaller partition first
    199 ;;;
    200 (defun quicksort (vector start end predicate key)
    201   (declare (type fixnum start end)
    202      (type function predicate key))
    203   (if (< start end)
    204       (let* ((i start)
    205        (j (1+ end))
    206        (p (+ start (ash (- end start) -1)))
    207        (d (aref vector p))
    208        (kd (funcall key d)))
    209   (rotatef (aref vector p) (aref vector start))
    210   (block outer-loop
    211     (loop
    212       (loop
    213         (unless (> (decf j) i) (return-from outer-loop))
    214         (when (funcall predicate
    215            (funcall key (aref vector j)) kd)
    216     (return)))
    217       (loop
    218         (unless (< (incf i) j) (return-from outer-loop))
    219         (unless (funcall predicate
    220              (funcall key (aref vector i)) kd)
    221     (return)))
    222       (rotatef (aref vector i) (aref vector j))))
    223   (setf (aref vector start) (aref vector j)
    224         (aref vector j) d)
    225   (if (< (- j start) (- end j))
    226       (progn
    227         (quicksort vector start (1- j) predicate key)
    228         (quicksort vector (1+ j) end predicate key))
    229       (progn
    230         (quicksort vector (1+ j) end predicate key)
    231         (quicksort vector start (1- j) predicate key))))
    232       vector))
    233 
    234 ;;; DEPRECATED -- to be removed in abcl-1.4
    235 ;;; From ECL.
    236 (defun quick-sort (seq start end pred key)
    237   (unless key (setq key #'identity))
    238   (if (<= end (1+ start))
    239       seq
    240       (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
    241         (block outer-loop
    242           (loop (loop (decf k)
    243                   (unless (< j k) (return-from outer-loop))
    244                   (when (funcall pred (funcall key (elt seq k)) kd)
    245                     (return)))
    246             (loop (incf j)
    247               (unless (< j k) (return-from outer-loop))
    248               (unless (funcall pred (funcall key (elt seq j)) kd)
    249                 (return)))
    250             (let ((temp (elt seq j)))
    251               (setf (elt seq j) (elt seq k)
    252                     (elt seq k) temp))))
    253         (setf (elt seq start) (elt seq j)
    254               (elt seq j) d)
    255         (quick-sort seq start j pred key)
    256         (quick-sort seq (1+ j) end pred key))))
    257 
    258 ;;; From ECL. Should already be user-extensible as it does no type dispatch
    259 ;;; and uses only user-extensible functions.
    260 (defun merge (result-type sequence1 sequence2 predicate
    261                           &key key
    262                           &aux (l1 (length sequence1)) (l2 (length sequence2)))
    263   (unless key (setq key #'identity))
    264   (do ((newseq (make-sequence result-type (+ l1 l2)))
    265        (j 0 (1+ j))
    266        (i1 0)
    267        (i2 0))
    268     ((and (= i1 l1) (= i2 l2)) newseq)
    269     (cond ((and (< i1 l1) (< i2 l2))
    270            (cond ((funcall predicate
    271                            (funcall key (elt sequence1 i1))
    272                            (funcall key (elt sequence2 i2)))
    273                   (setf (elt newseq j) (elt sequence1 i1))
    274                   (incf i1))
    275                  ((funcall predicate
    276                            (funcall key (elt sequence2 i2))
    277                            (funcall key (elt sequence1 i1)))
    278                   (setf (elt newseq j) (elt sequence2 i2))
    279                   (incf i2))
    280                  (t
    281                   (setf (elt newseq j) (elt sequence1 i1))
    282                   (incf i1))))
    283           ((< i1 l1)
    284            (setf (elt newseq j) (elt sequence1 i1))
    285            (incf i1))
    286           (t
    287            (setf (elt newseq j) (elt sequence2 i2))
    288            (incf i2)))))
     320;;; - the macro generates the quicksort body with or without funcall to key
     321;;;
     322
     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)))))
     377
     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))
     390
     391
     392;;;
     393;;; main SORT and STABLE-SORT function calls
     394;;;
     395;;; - sort: quicksort and merge sort (only for lists)
     396;;; - stable-sort: merge sort (all types)
     397;;;
     398
     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)))
     404
     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 TracChangeset for help on using the changeset viewer.