Changeset 13870

Timestamp:

02/11/12 15:53:33 (11 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:

• trunk/abcl/src/org/armedbear/lisp/sort.lisp (modified) (2 diffs)

trunk/abcl/src/org/armedbear/lisp/sort.lisp

@@ -34 +34 @@
 (require "EXTENSIBLE-SEQUENCES-BASE")
 
-(defun sort (sequence predicate &rest args &key key)
-  (sequence::seq-dispatch sequence
-    (sort-list sequence predicate key)
-    (quicksort sequence 0 (1- (length sequence)) predicate (or key #'identity))
-    (apply #'sequence:sort sequence predicate args)))
-
-(defun stable-sort (sequence predicate &rest args &key key)
-  (sequence::seq-dispatch sequence
-    (sort-list sequence predicate key)
-;;; Jorge Tavares: 
-;;; As a quick fix, I send in attach a patch that uses in stable-sort merge
-;;; sort for all sequences. This is done by coercing the sequence to list,
-;;; calling merge sort and coercing it back to the original sequence type.
-;;; However, as a long term improvement, the best solution would be to
-;;; implement a merge sort for non-list sequences.
-    (coerce (sort-list (coerce sequence 'list) 
-           predicate
-           key)
-      (type-of sequence))
-    (apply #'sequence:stable-sort sequence predicate args)))
+;;;
+;;; STABLE SORT
+;;;
+
+;;;
+;;; MERGE SORT for vectors (and sequences in general)
+;;;
+;;; - top-down stable merge sort
+;;; - it is defined with 2 macros to allow a single algorithm 
+;;;   and multiple sequence types: merge-vectors-body and merge-sort-body
+;;; - merge-vectors-body merges two given sequences
+;;; - merge-sort-body contains the top-down algorithm
+;;; - the body macro is called by the merge-sort-vectors functions, 
+;;;   which typecases the type of sequence and expands the apropriate body
+;;; - more types of sequences/vectors can be added
+;;; - the macros generate the merge sort body with or without funcall to key
+;;; - the merge-vectors algorithm is inspired from the CCL base code 
+;;;
+
+(defmacro merge-vectors-body (type ref a start-a end-a b start-b end-b aux start-aux predicate &optional key)
+  (let ((i-a (gensym)) 
+  (i-b (gensym))
+  (i-aux (gensym))
+  (v-a (gensym))
+  (v-b (gensym))
+  (k-a (gensym))
+  (k-b (gensym))
+  (merge-block (gensym))) 
+    `(locally
+   (declare (type fixnum ,start-a ,end-a ,start-b ,end-b ,start-aux)
+      (type ,type ,a ,b)
+      (type simple-vector ,aux)
+      (type function ,predicate ,@(if key `(,key)))
+      (optimize (speed 3) (safety 0)))
+       (block ,merge-block
+    (let ((,i-a ,start-a)
+    (,i-b ,start-b)
+    (,i-aux ,start-aux)
+    ,v-a ,v-b ,k-a ,k-b)
+      (declare (type fixnum ,i-a ,i-b ,i-aux))
+      (cond ((= ,start-a ,end-a)
+       (when (= ,start-b ,end-b)
+         (return-from ,merge-block))
+       (setf ,i-a ,start-b
+       ,end-a ,end-b
+       ,a ,b
+       ,v-a (,ref ,a ,i-a)))
+      ((= ,start-b ,end-b)
+       (setf ,i-a ,start-a
+       ,v-a (,ref ,a ,i-a)))
+      (t
+       (setf ,v-a (,ref ,a ,i-a)
+       ,v-b (,ref ,b ,i-b)
+       ,@(if key 
+             `(,k-a (funcall ,key ,v-a))
+             `(,k-a ,v-a))
+       ,@(if key 
+             `(,k-b (funcall ,key ,v-b))
+             `(,k-b ,v-b)))
+       (loop 
+         (if (funcall ,predicate ,k-b ,k-a)
+       (progn 
+         (setf (svref ,aux ,i-aux) ,v-b
+         ,i-aux (+ ,i-aux 1)
+         ,i-b (+ ,i-b 1))
+         (when (= ,i-b ,end-b) (return))
+         (setf ,v-b (,ref ,b ,i-b)
+         ,@(if key 
+               `(,k-b (funcall ,key ,v-b))
+               `(,k-b ,v-b))))
+       (progn 
+         (setf (svref ,aux ,i-aux) ,v-a
+         ,i-aux (+ ,i-aux 1)
+         ,i-a (+ ,i-a 1))
+         (when (= ,i-a ,end-a)
+           (setf ,a ,b 
+           ,i-a ,i-b 
+           ,end-a ,end-b 
+           ,v-a ,v-b)
+           (return))
+         (setf ,v-a (,ref ,a ,i-a)
+         ,@(if key 
+               `(,k-a (funcall ,key ,v-a))
+               `(,k-a ,v-a))))))))
+      (loop
+        (setf (svref ,aux ,i-aux) ,v-a
+        ,i-a (+ ,i-a 1))
+        (when (= ,i-a ,end-a) (return))
+        (setf ,v-a (,ref ,a ,i-a)
+        ,i-aux (+ ,i-aux 1))))))))
+
+(defmacro merge-sort-body (type ref mpredicate mkey msequence mstart mend)
+  (let ((merge-sort-call (gensym))
+  (maux (gensym))
+  (aux (gensym))
+  (sequence (gensym))
+  (start (gensym))
+  (end (gensym))
+  (predicate (gensym))
+  (key (gensym))
+  (mid (gensym))
+  (direction (gensym)))
+    `(locally
+   (declare (optimize (speed 3) (safety 0)))
+       (labels ((,merge-sort-call (,sequence ,start ,end ,predicate ,key ,aux ,direction)
+      (declare (type function ,predicate ,@(if mkey `(,key)))
+         (type fixnum ,start ,end)
+         (type ,type ,sequence))
+      (let ((,mid (+ ,start (ash (- ,end ,start) -1))))
+        (declare (type fixnum ,mid))
+        (if (<= (- ,mid 1) ,start)
+      (unless ,direction (setf (,ref ,aux ,start) (,ref ,sequence ,start)))
+      (,merge-sort-call ,sequence ,start ,mid ,predicate ,key ,aux (not ,direction)))
+        (if (>= (+ ,mid 1) ,end)
+      (unless ,direction (setf (,ref ,aux ,mid) (,ref ,sequence ,mid)))
+      (,merge-sort-call ,sequence ,mid ,end ,predicate ,key ,aux (not ,direction)))
+        (unless ,direction (psetq ,sequence ,aux ,aux ,sequence))
+        ,(if mkey
+       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
+                ,mid ,end ,aux ,start ,predicate ,key)
+       `(merge-vectors-body ,type ,ref ,sequence ,start ,mid ,sequence 
+                ,mid ,end ,aux ,start ,predicate)))))
+   (let ((,maux (make-array ,mend)))
+     (declare (type simple-vector ,maux))
+     (,merge-sort-call ,msequence ,mstart ,mend ,mpredicate ,mkey ,maux nil))))))
+
+(defun merge-sort-vectors (sequence predicate key)
+  (let ((end (length sequence)))
+    (typecase sequence
+      (simple-vector 
+       (if key
+     (merge-sort-body simple-vector svref predicate key sequence 0 end)
+     (merge-sort-body simple-vector svref predicate nil sequence 0 end)))
+      (vector 
+       (if key
+     (merge-sort-body vector aref predicate key sequence 0 end)
+     (merge-sort-body vector aref predicate nil sequence 0 end))))
+    sequence))
+
+
+;;;
+;;;  MERGE SORT for lists
+;;;
 
 ;; Adapted from SBCL.
@@ -183 +306 @@
             (return list-1))))))
 
-#|
-<> dc:author "Jorge Tavares" ;
-    dc:description 
-""" 
-The quicksort function picks the pivot by selecting a midpoint and
-also sorts the smaller partition first. These are enough to avoid the
-stack overflow problem as reported. I've performed some tests and it
-looks it is correct 
-"""" .
-|#
+
+;;;
+;;; SORT 
+;;;
+
 ;;;
 ;;; QUICKSORT
-;;; - the pivot is a middle point
+;;;
+;;; - algorithm is in the quicksort-body macro, so that it allows
+;;;   the use of different types (e.g., simple-vector, vector)
+;;; - the pivot is picked by selecting middle point
 ;;; - sorts the smaller partition first
-;;;
-(defun quicksort (vector start end predicate key)
-  (declare (type fixnum start end)
-     (type function predicate key))
-  (if (< start end)
-      (let* ((i start)
-       (j (1+ end))
-       (p (+ start (ash (- end start) -1)))
-       (d (aref vector p))
-       (kd (funcall key d)))
-  (rotatef (aref vector p) (aref vector start))
-  (block outer-loop
-    (loop
-      (loop 
-        (unless (> (decf j) i) (return-from outer-loop))
-        (when (funcall predicate 
-           (funcall key (aref vector j)) kd)
-    (return)))
-      (loop 
-        (unless (< (incf i) j) (return-from outer-loop))
-        (unless (funcall predicate
-             (funcall key (aref vector i)) kd)
-    (return)))
-      (rotatef (aref vector i) (aref vector j))))
-  (setf (aref vector start) (aref vector j)
-        (aref vector j) d)
-  (if (< (- j start) (- end j))
-      (progn
-        (quicksort vector start (1- j) predicate key)
-        (quicksort vector (1+ j) end predicate key))
-      (progn
-        (quicksort vector (1+ j) end predicate key)
-        (quicksort vector start (1- j) predicate key))))
-      vector))
-
-;;; DEPRECATED -- to be removed in abcl-1.4
-;;; From ECL.
-(defun quick-sort (seq start end pred key)
-  (unless key (setq key #'identity))
-  (if (<= end (1+ start))
-      seq
-      (let* ((j start) (k end) (d (elt seq start)) (kd (funcall key d)))
-        (block outer-loop
-          (loop (loop (decf k)
-                  (unless (< j k) (return-from outer-loop))
-                  (when (funcall pred (funcall key (elt seq k)) kd)
-                    (return)))
-            (loop (incf j)
-              (unless (< j k) (return-from outer-loop))
-              (unless (funcall pred (funcall key (elt seq j)) kd)
-                (return)))
-            (let ((temp (elt seq j)))
-              (setf (elt seq j) (elt seq k)
-                    (elt seq k) temp))))
-        (setf (elt seq start) (elt seq j)
-              (elt seq j) d)
-        (quick-sort seq start j pred key)
-        (quick-sort seq (1+ j) end pred key))))
-
-;;; From ECL. Should already be user-extensible as it does no type dispatch
-;;; and uses only user-extensible functions.
-(defun merge (result-type sequence1 sequence2 predicate
-                          &key key
-                          &aux (l1 (length sequence1)) (l2 (length sequence2)))
-  (unless key (setq key #'identity))
-  (do ((newseq (make-sequence result-type (+ l1 l2)))
-       (j 0 (1+ j))
-       (i1 0)
-       (i2 0))
-    ((and (= i1 l1) (= i2 l2)) newseq)
-    (cond ((and (< i1 l1) (< i2 l2))
-           (cond ((funcall predicate
-                           (funcall key (elt sequence1 i1))
-                           (funcall key (elt sequence2 i2)))
-                  (setf (elt newseq j) (elt sequence1 i1))
-                  (incf i1))
-                 ((funcall predicate
-                           (funcall key (elt sequence2 i2))
-                           (funcall key (elt sequence1 i1)))
-                  (setf (elt newseq j) (elt sequence2 i2))
-                  (incf i2))
-                 (t
-                  (setf (elt newseq j) (elt sequence1 i1))
-                  (incf i1))))
-          ((< i1 l1)
-           (setf (elt newseq j) (elt sequence1 i1))
-           (incf i1))
-          (t
-           (setf (elt newseq j) (elt sequence2 i2))
-           (incf i2)))))
+;;; - the macro generates the quicksort body with or without funcall to key
+;;;
+
+(defmacro quicksort-body (type ref mpredicate mkey sequence mstart mend)
+  (let ((quicksort-call (gensym))
+  (predicate (gensym))
+  (key (gensym))
+  (vector (gensym))
+  (start (gensym))
+  (end (gensym))
+  (i (gensym))
+  (j (gensym))
+  (p (gensym))
+  (d (gensym))
+  (kd (gensym)))
+    `(locally 
+   (declare (speed 3) (safety 0))
+       (labels ((,quicksort-call (,vector ,start ,end ,predicate ,key)
+       (declare (type function ,predicate ,@(if mkey `(,key)))
+          (type fixnum ,start ,end)
+          (type ,type ,sequence))
+       (if (< ,start ,end)
+           (let* ((,i ,start)
+            (,j (1+ ,end))
+            (,p (the fixnum (+ ,start (ash (- ,end ,start) -1))))
+            (,d (,ref ,vector ,p))
+            ,@(if mkey
+            `((,kd (funcall ,key ,d)))
+            `((,kd ,d))))
+       (rotatef (,ref ,vector ,p) (,ref ,vector ,start))
+       (block outer-loop
+         (loop
+           (loop 
+             (unless (> (decf ,j) ,i) (return-from outer-loop))
+             (when (funcall ,predicate 
+                ,@(if mkey 
+                `((funcall ,key (,ref ,vector ,j)))
+                `((,ref ,vector ,j)))
+                ,kd) (return)))
+           (loop 
+             (unless (< (incf ,i) ,j) (return-from outer-loop))
+             (unless (funcall ,predicate
+            ,@(if mkey 
+                `((funcall ,key (,ref ,vector ,i)))
+                `((,ref ,vector ,i)))
+            ,kd) (return)))
+           (rotatef (,ref ,vector ,i) (,ref ,vector ,j))))
+       (setf (,ref ,vector ,start) (,ref ,vector ,j)
+             (,ref ,vector ,j) ,d)
+       (if (< (- ,j ,start) (- ,end ,j))
+           (progn
+             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)
+             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key))
+           (progn
+             (,quicksort-call ,vector (1+ ,j) ,end ,predicate ,key)
+             (,quicksort-call ,vector ,start (1- ,j) ,predicate ,key)))))))
+   (,quicksort-call ,sequence ,mstart ,mend ,mpredicate ,mkey)))))
+
+(defun quicksort (sequence predicate key)
+  (let ((end (1- (length sequence))))
+    (typecase sequence
+      (simple-vector 
+       (if key
+     (quicksort-body simple-vector svref predicate key sequence 0 end)
+     (quicksort-body simple-vector svref predicate nil sequence 0 end)))
+      (vector 
+       (if key
+     (quicksort-body vector aref predicate key sequence 0 end)
+     (quicksort-body vector aref predicate nil sequence 0 end))))
+    sequence))
+
+
+;;;
+;;; main SORT and STABLE-SORT function calls
+;;;
+;;; - sort: quicksort and merge sort (only for lists)
+;;; - stable-sort: merge sort (all types)
+;;;
+
+(defun sort (sequence predicate &rest args &key key)
+  (sequence::seq-dispatch sequence
+    (sort-list sequence predicate key)
+    (quicksort sequence predicate key)
+    (apply #'sequence:sort sequence predicate args)))
+
+(defun stable-sort (sequence predicate &rest args &key key)
+  (sequence::seq-dispatch sequence
+    (sort-list sequence predicate key)
+    (merge-sort-vectors sequence predicate key)
+    (apply #'sequence:stable-sort sequence predicate args)))