src/code/sort.lisp

   1 ;;;; SORT and friends
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!IMPL")
  13
  14 (defun sort-vector (vector start end predicate-fun key-fun-or-nil)
  15   (sort-vector vector start end predicate-fun key-fun-or-nil))
  16
  17 ;;; This is MAYBE-INLINE because it's not too hard to have an
  18 ;;; application where sorting is a major bottleneck, and inlining it
  19 ;;; allows the compiler to make enough optimizations that it might be
  20 ;;; worth the (large) cost in space.
  21 (declaim (maybe-inline sort stable-sort))
  22 (defun sort (sequence predicate &rest args &key key)
  23   #!+sb-doc
  24   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  25    ARG1 is to precede ARG2."
  26   (declare (truly-dynamic-extent args))
  27   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
  28     (seq-dispatch sequence
  29       (stable-sort-list sequence
  30                         predicate-fun
  31                         (if key (%coerce-callable-to-fun key) #'identity))
  32       (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
  33         (with-array-data ((vector (the vector sequence))
  34                           (start)
  35                           (end)
  36                           :check-fill-pointer t)
  37           (sort-vector vector start end predicate-fun key-fun-or-nil))
  38         sequence)
  39       (apply #'sb!sequence:sort sequence predicate args))))
  40 \f
  41 ;;;; stable sorting
  42 (defun stable-sort (sequence predicate &rest args &key key)
  43   #!+sb-doc
  44   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  45    ARG1 is to precede ARG2."
  46   (declare (truly-dynamic-extent args))
  47   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
  48     (seq-dispatch sequence
  49       (stable-sort-list sequence
  50                         predicate-fun
  51                         (if key (%coerce-callable-to-fun key) #'identity))
  52       (if (typep sequence 'simple-vector)
  53           (stable-sort-simple-vector sequence
  54                                      predicate-fun
  55                                      (and key (%coerce-callable-to-fun key)))
  56           (stable-sort-vector sequence
  57                               predicate-fun
  58                               (and key (%coerce-callable-to-fun key))))
  59       (apply #'sb!sequence:stable-sort sequence predicate args))))
  60 \f
  61 ;;; FUNCALL-USING-KEY saves us a function call sometimes.
  62 (eval-when (:compile-toplevel :execute)
  63   (sb!xc:defmacro funcall2-using-key (pred key one two)
  64     `(if ,key
  65          (funcall ,pred (funcall ,key ,one)
  66                   (funcall ,key  ,two))
  67          (funcall ,pred ,one ,two)))
  68 ) ; EVAL-WHEN
  69 \f
  70 ;;;; stable sort of lists
  71 (declaim (maybe-inline merge-lists* stable-sort-list))
  72
  73 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
  74 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
  75 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
  76 ;;; come before equal elements of LIST-2.
  77 ;;;
  78 ;;; Enqueues the values in the right order in HEAD's cdr, and returns
  79 ;;; the merged list.
  80 (defun merge-lists* (head list1 list2 test key &aux (tail head))
  81   (declare (type cons head list1 list2)
  82            (type function test key)
  83            (optimize speed))
  84   (macrolet ((merge-one (l1 l2)
  85                `(progn
  86                   (setf (cdr tail) ,l1
  87                         tail       ,l1)
  88                   (let ((rest (cdr ,l1)))
  89                     (cond (rest
  90                            (setf ,l1 rest))
  91                           (t
  92                            (setf (cdr ,l1) ,l2)
  93                            (return (cdr head))))))))
  94     (loop
  95      (if (funcall test (funcall key (car list2))  ; this way, equivalent
  96                        (funcall key (car list1))) ; values are first popped
  97          (merge-one list2 list1)                  ; from list1
  98          (merge-one list1 list2)))))
  99
 100 ;;; Convenience wrapper for CL:MERGE
 101 (declaim (inline merge-lists))
 102 (defun merge-lists (list1 list2 test key)
 103   (cond ((null list1)
 104          list2)
 105         ((null list2)
 106          list1)
 107         (t
 108          (let ((head (cons nil nil)))
 109            (declare (dynamic-extent head))
 110            (merge-lists* head list1 list2 test key)))))
 111
 112 ;;; STABLE-SORT-LIST implements a top-down merge sort. See the closest
 113 ;;; intro to algorithms book.  Benchmarks have shown significantly
 114 ;;; improved performance over the previous (hairier) bottom-up
 115 ;;; implementation, particularly on non-power-of-two sizes: bottom-up
 116 ;;; recursed on power-of-two-sized subsequences, which can result in
 117 ;;; very unbalanced recursion trees.
 118 (defun stable-sort-list (list test key &aux (head (cons :head list)))
 119   (declare (type list list)
 120            (type function test key)
 121            (dynamic-extent head))
 122   (labels ((recur (list size)
 123              (declare (optimize speed)
 124                       (type cons list)
 125                       (type (and fixnum unsigned-byte) size))
 126              (if (= 1 size)
 127                  (values list (shiftf (cdr list) nil))
 128                  (let ((half (ash size -1)))
 129                    (multiple-value-bind (list1 rest)
 130                        (recur list half)
 131                      (multiple-value-bind (list2 rest)
 132                          (recur rest (- size half))
 133                        (values (merge-lists* head list1 list2 test key)
 134                                rest)))))))
 135     (when list
 136       (values (recur list (length list))))))
 137 \f
 138 ;;;; stable sort of vectors
 139
 140 ;;; Stable sorting vectors is done with the same algorithm used for
 141 ;;; lists, using a temporary vector to merge back and forth between it
 142 ;;; and the given vector to sort.
 143
 144 (eval-when (:compile-toplevel :execute)
 145
 146 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 147 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 148 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 149 ;;; and merges them into a target vector starting at index start-1.
 150
 151 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 152                                                      pred key source-ref
 153                                                      target-ref)
 154   (let ((i (gensym))
 155         (j (gensym))
 156         (target-i (gensym)))
 157     `(let ((,i ,start-1)
 158            (,j ,end-1) ; start-2
 159            (,target-i ,start-1))
 160        (declare (fixnum ,i ,j ,target-i))
 161        (loop
 162         (cond ((= ,i ,end-1)
 163                (loop (if (= ,j ,end-2) (return))
 164                      (setf (,target-ref ,target ,target-i)
 165                            (,source-ref ,source ,j))
 166                      (incf ,target-i)
 167                      (incf ,j))
 168                (return))
 169               ((= ,j ,end-2)
 170                (loop (if (= ,i ,end-1) (return))
 171                      (setf (,target-ref ,target ,target-i)
 172                            (,source-ref ,source ,i))
 173                      (incf ,target-i)
 174                      (incf ,i))
 175                (return))
 176               ((funcall2-using-key ,pred ,key
 177                                    (,source-ref ,source ,j)
 178                                    (,source-ref ,source ,i))
 179                (setf (,target-ref ,target ,target-i)
 180                      (,source-ref ,source ,j))
 181                (incf ,j))
 182               (t (setf (,target-ref ,target ,target-i)
 183                        (,source-ref ,source ,i))
 184                  (incf ,i)))
 185         (incf ,target-i)))))
 186
 187 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 188 ;;; but it uses a temporary vector. DIRECTION determines whether we
 189 ;;; are merging into the temporary (T) or back into the given vector
 190 ;;; (NIL).
 191 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 192   (with-unique-names
 193       (vector-len n direction unsorted start-1 end-1 end-2 temp i)
 194     `(let* ((,vector-len (length (the vector ,vector)))
 195             (,n 1)            ; bottom-up size of contiguous runs to be merged
 196             (,direction t)    ; t vector --> temp    nil temp --> vector
 197             (,temp (make-array ,vector-len))
 198             (,unsorted 0)   ; unsorted..vector-len are the elements that need
 199                                         ; to be merged for a given n
 200             (,start-1 0))   ; one n-len subsequence to be merged with the next
 201        (declare (fixnum ,vector-len ,n ,unsorted ,start-1)
 202                 (simple-vector ,temp))
 203        (loop
 204          ;; for each n, we start taking n-runs from the start of the vector
 205          (setf ,unsorted 0)
 206          (loop
 207            (setf ,start-1 ,unsorted)
 208            (let ((,end-1 (+ ,start-1 ,n)))
 209              (declare (fixnum ,end-1))
 210              (cond ((< ,end-1 ,vector-len)
 211                     ;; there are enough elements for a second run
 212                     (let ((,end-2 (+ ,end-1 ,n)))
 213                       (declare (fixnum ,end-2))
 214                       (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 215                       (setf ,unsorted ,end-2)
 216                       (if ,direction
 217                           (stable-sort-merge-vectors*
 218                            ,vector ,temp
 219                            ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 220                           (stable-sort-merge-vectors*
 221                            ,temp ,vector
 222                            ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 223                       (if (= ,unsorted ,vector-len) (return))))
 224                    ;; if there is only one run, copy those elements to the end
 225                    (t (if ,direction
 226                           (do ((,i ,start-1 (1+ ,i)))
 227                               ((= ,i ,vector-len))
 228                             (declare (fixnum ,i))
 229                             (setf (svref ,temp ,i) (,vector-ref ,vector ,i)))
 230                           (do ((,i ,start-1 (1+ ,i)))
 231                               ((= ,i ,vector-len))
 232                             (declare (fixnum ,i))
 233                             (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
 234                       (return)))))
 235          ;; If the inner loop only executed once, then there were only enough
 236          ;; elements for two subsequences given n, so all the elements have
 237          ;; been merged into one list. Start-1 will have remained 0 upon exit.
 238          (when (zerop ,start-1)
 239            (when ,direction
 240              ;; if we just merged into the temporary, copy it all back
 241              ;; to the given vector.
 242              (dotimes (,i ,vector-len)
 243                (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
 244            ;; Kill the new vector to prevent garbage from being retained.
 245            (%shrink-vector ,temp 0)
 246            (return ,vector))
 247          (setf ,n (ash ,n 1))           ; (* 2 n)
 248          (setf ,direction (not ,direction))))))
 249
 250 ) ; EVAL-when
 251
 252 (defun stable-sort-simple-vector (vector pred key)
 253   (declare (type simple-vector vector)
 254            (type function pred)
 255            (type (or null function) key))
 256   (vector-merge-sort vector pred key svref))
 257
 258 (defun stable-sort-vector (vector pred key)
 259   (declare (type function pred)
 260            (type (or null function) key))
 261   (vector-merge-sort vector pred key aref))
 262 \f
 263 ;;;; merging
 264
 265 (eval-when (:compile-toplevel :execute)
 266
 267 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 268 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 269 ;;; are chosen only if they are strictly less than elements of
 270 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 271 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 272                                result-vector pred key access)
 273   (let ((result-i (gensym))
 274         (i (gensym))
 275         (j (gensym)))
 276     `(let* ((,result-i 0)
 277             (,i 0)
 278             (,j 0))
 279        (declare (fixnum ,result-i ,i ,j))
 280        (loop
 281         (cond ((= ,i ,length-1)
 282                (loop (if (= ,j ,length-2) (return))
 283                      (setf (,access ,result-vector ,result-i)
 284                            (,access ,vector-2 ,j))
 285                      (incf ,result-i)
 286                      (incf ,j))
 287                (return ,result-vector))
 288               ((= ,j ,length-2)
 289                (loop (if (= ,i ,length-1) (return))
 290                      (setf (,access ,result-vector ,result-i)
 291                            (,access ,vector-1 ,i))
 292                      (incf ,result-i)
 293                      (incf ,i))
 294                (return ,result-vector))
 295               ((funcall2-using-key ,pred ,key
 296                                    (,access ,vector-2 ,j) (,access ,vector-1 ,i))
 297                (setf (,access ,result-vector ,result-i)
 298                      (,access ,vector-2 ,j))
 299                (incf ,j))
 300               (t (setf (,access ,result-vector ,result-i)
 301                        (,access ,vector-1 ,i))
 302                  (incf ,i)))
 303         (incf ,result-i)))))
 304
 305 ) ; EVAL-WHEN
 306
 307 (defun merge (result-type sequence1 sequence2 predicate &key key)
 308   #!+sb-doc
 309   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 310    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 311   ;; FIXME: This implementation is remarkably inefficient in various
 312   ;; ways. In decreasing order of estimated user astonishment, I note:
 313   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
 314   ;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
 315   (let ((type (specifier-type result-type)))
 316     (cond
 317       ((csubtypep type (specifier-type 'list))
 318        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
 319        ;; benefits from the error checking there. Short of
 320        ;; reimplementing everything, we can't do the same for the LIST
 321        ;; case, so do relevant length checking here:
 322        (let ((s1 (coerce sequence1 'list))
 323              (s2 (coerce sequence2 'list))
 324              (pred-fun (%coerce-callable-to-fun predicate))
 325              (key-fun (if key
 326                           (%coerce-callable-to-fun key)
 327                           #'identity)))
 328          (when (type= type (specifier-type 'list))
 329            (return-from merge (merge-lists s1 s2 pred-fun key-fun)))
 330          (when (eq type *empty-type*)
 331            (bad-sequence-type-error nil))
 332          (when (type= type (specifier-type 'null))
 333            (if (and (null s1) (null s2))
 334                (return-from merge 'nil)
 335                ;; FIXME: This will break on circular lists (as,
 336                ;; indeed, will the whole MERGE function).
 337                (sequence-type-length-mismatch-error type
 338                                                     (+ (length s1)
 339                                                        (length s2)))))
 340          (if (cons-type-p type)
 341              (multiple-value-bind (min exactp)
 342                  (sb!kernel::cons-type-length-info type)
 343                (let ((length (+ (length s1) (length s2))))
 344                  (if exactp
 345                      (unless (= length min)
 346                        (sequence-type-length-mismatch-error type length))
 347                      (unless (>= length min)
 348                        (sequence-type-length-mismatch-error type length)))
 349                  (merge-lists s1 s2 pred-fun key-fun)))
 350              (sequence-type-too-hairy result-type))))
 351       ((csubtypep type (specifier-type 'vector))
 352        (let* ((vector-1 (coerce sequence1 'vector))
 353               (vector-2 (coerce sequence2 'vector))
 354               (length-1 (length vector-1))
 355               (length-2 (length vector-2))
 356               (result (make-sequence result-type (+ length-1 length-2))))
 357          (declare (vector vector-1 vector-2)
 358                   (fixnum length-1 length-2))
 359          (if (and (simple-vector-p result)
 360                   (simple-vector-p vector-1)
 361                   (simple-vector-p vector-2))
 362              (merge-vectors vector-1 length-1 vector-2 length-2
 363                             result predicate key svref)
 364              (merge-vectors vector-1 length-1 vector-2 length-2
 365                             result predicate key aref))))
 366       ((and (csubtypep type (specifier-type 'sequence))
 367             (find-class result-type nil))
 368        (let* ((vector-1 (coerce sequence1 'vector))
 369               (vector-2 (coerce sequence2 'vector))
 370               (length-1 (length vector-1))
 371               (length-2 (length vector-2))
 372               (temp (make-array (+ length-1 length-2)))
 373               (result (make-sequence result-type (+ length-1 length-2))))
 374          (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
 375          (merge-vectors vector-1 length-1 vector-2 length-2
 376                         temp predicate key aref)
 377          (replace result temp)
 378          result))
 379       (t (bad-sequence-type-error result-type)))))