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))
  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 (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 0)
  35                           (end (length sequence)))
  36           (sort-vector vector start end predicate-fun key-fun-or-nil))
  37         sequence)
  38       (apply #'sb!sequence:sort sequence predicate args))))
  39 \f
  40 ;;;; stable sorting
  41 (defun stable-sort (sequence predicate &rest args &key key)
  42   #!+sb-doc
  43   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
  44    ARG1 is to precede ARG2."
  45   (declare (dynamic-extent args))
  46   (let ((predicate-fun (%coerce-callable-to-fun predicate)))
  47     (seq-dispatch sequence
  48       (stable-sort-list sequence
  49                         predicate-fun
  50                         (if key (%coerce-callable-to-fun key) #'identity))
  51       (if (typep sequence 'simple-vector)
  52           (stable-sort-simple-vector sequence
  53                                      predicate-fun
  54                                      (and key (%coerce-callable-to-fun key)))
  55           (stable-sort-vector sequence
  56                               predicate-fun
  57                               (and key (%coerce-callable-to-fun key))))
  58       (apply #'sb!sequence:stable-sort sequence predicate args))))
  59 \f
  60 ;;; FUNCALL-USING-KEY saves us a function call sometimes.
  61 (eval-when (:compile-toplevel :execute)
  62   (sb!xc:defmacro funcall2-using-key (pred key one two)
  63     `(if ,key
  64          (funcall ,pred (funcall ,key ,one)
  65                   (funcall ,key  ,two))
  66          (funcall ,pred ,one ,two)))
  67 ) ; EVAL-WHEN
  68 \f
  69 ;;;; stable sort of lists
  70
  71 (defun last-cons-of (list)
  72   (loop (let ((rest (rest list)))
  73           (if rest
  74               (setf list rest)
  75               (return list)))))
  76
  77 ;;; Destructively merge LIST-1 with LIST-2 (given that they're already
  78 ;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
  79 ;;; way). In the resulting list, elements of LIST-1 are guaranteed to
  80 ;;; come before equal elements of LIST-2.
  81 ;;;
  82 ;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
  83 ;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
  84 ;;; the last cons in the list which NRECONC calls TAIL).
  85 (defun merge-lists* (list-1 list-2 pred-fun key-fun)
  86   (declare (type list list-1 list-2))
  87   (declare (type function pred-fun key-fun))
  88   (cond ((null list-1) (values list-2 (last-cons-of list-2)))
  89         ((null list-2) (values list-1 (last-cons-of list-1)))
  90         (t (let* ((reversed-result-so-far nil)
  91                   (key-1 (funcall key-fun (car list-1)))
  92                   (key-2 (funcall key-fun (car list-2))))
  93              (loop
  94               (macrolet ((frob (list-i key-i other-list)
  95                            `(progn
  96                               ;; basically
  97                               ;;   (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
  98                               ;; except doing some fancy footwork to
  99                               ;; reuse the cons cell:
 100                               (psetf (cdr ,list-i) reversed-result-so-far
 101                                      reversed-result-so-far ,list-i
 102                                      ,list-i (cdr ,list-i))
 103                               ;; Now maybe we're done.
 104                               (if (endp ,list-i)
 105                                   (return (values (nreconc
 106                                                    reversed-result-so-far
 107                                                    ,other-list)
 108                                                   (last-cons-of
 109                                                    ,other-list)))
 110                                   (setf ,key-i
 111                                         (funcall key-fun (car ,list-i)))))))
 112                 ;; Note that by making KEY-2 the first arg to
 113                 ;; PRED-FUN, we arrange that if PRED-FUN is a function
 114                 ;; in the #'< style, the outcome is stably sorted.
 115                 (if (funcall pred-fun key-2 key-1)
 116                     (frob list-2 key-2 list-1)
 117                     (frob list-1 key-1 list-2))))))))
 118
 119 ;;; STABLE-SORT-LIST uses a bottom-up merge sort. First a pass is made
 120 ;;; over the list grabbing one element at a time and merging it with
 121 ;;; the next one to form pairs of sorted elements. Then N is doubled,
 122 ;;; and elements are taken in runs of two, merging one run with the
 123 ;;; next to form quadruples of sorted elements. This continues until N
 124 ;;; is large enough that the inner loop only runs for one iteration;
 125 ;;; that is, there are only two runs that can be merged, the first run
 126 ;;; starting at the beginning of the list, and the second being the
 127 ;;; remaining elements.
 128 (defun stable-sort-list (list pred-fun key-fun)
 129   (let ((head (cons :header list))  ; head holds on to everything
 130         (n 1)                       ; bottom-up size of lists to be merged
 131         unsorted                    ; unsorted is the remaining list to be
 132                                     ;   broken into n size lists and merged
 133         list-1                      ; list-1 is one length n list to be merged
 134         last)                       ; last points to the last visited cell
 135     (declare (type function pred-fun key-fun)
 136              (type fixnum n))
 137     (loop
 138      ;; Start collecting runs of N at the first element.
 139      (setf unsorted (cdr head))
 140      ;; Tack on the first merge of two N-runs to the head holder.
 141      (setf last head)
 142      (let ((n-1 (1- n)))
 143        (declare (fixnum n-1))
 144        (loop
 145         (setf list-1 unsorted)
 146         (let ((temp (nthcdr n-1 list-1))
 147               list-2)
 148           (cond (temp
 149                  ;; There are enough elements for a second run.
 150                  (setf list-2 (cdr temp))
 151                  (setf (cdr temp) nil)
 152                  (setf temp (nthcdr n-1 list-2))
 153                  (cond (temp
 154                         (setf unsorted (cdr temp))
 155                         (setf (cdr temp) nil))
 156                        ;; The second run goes off the end of the list.
 157                        (t (setf unsorted nil)))
 158                  (multiple-value-bind (merged-head merged-last)
 159                      (merge-lists* list-1 list-2 pred-fun key-fun)
 160                    (setf (cdr last) merged-head
 161                          last merged-last))
 162                  (if (null unsorted) (return)))
 163                 ;; If there is only one run, then tack it on to the end.
 164                 (t (setf (cdr last) list-1)
 165                    (return)))))
 166        (setf n (ash n 1)) ; (+ n n)
 167        ;; If the inner loop only executed once, then there were only
 168        ;; enough elements for two runs given n, so all the elements
 169        ;; have been merged into one list. This may waste one outer
 170        ;; iteration to realize.
 171        (if (eq list-1 (cdr head))
 172            (return list-1))))))
 173 \f
 174 ;;;; stable sort of vectors
 175
 176 ;;; Stable sorting vectors is done with the same algorithm used for
 177 ;;; lists, using a temporary vector to merge back and forth between it
 178 ;;; and the given vector to sort.
 179
 180 (eval-when (:compile-toplevel :execute)
 181
 182 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 183 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 184 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 185 ;;; and merges them into a target vector starting at index start-1.
 186
 187 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 188                                                      pred key source-ref
 189                                                      target-ref)
 190   (let ((i (gensym))
 191         (j (gensym))
 192         (target-i (gensym)))
 193     `(let ((,i ,start-1)
 194            (,j ,end-1) ; start-2
 195            (,target-i ,start-1))
 196        (declare (fixnum ,i ,j ,target-i))
 197        (loop
 198         (cond ((= ,i ,end-1)
 199                (loop (if (= ,j ,end-2) (return))
 200                      (setf (,target-ref ,target ,target-i)
 201                            (,source-ref ,source ,j))
 202                      (incf ,target-i)
 203                      (incf ,j))
 204                (return))
 205               ((= ,j ,end-2)
 206                (loop (if (= ,i ,end-1) (return))
 207                      (setf (,target-ref ,target ,target-i)
 208                            (,source-ref ,source ,i))
 209                      (incf ,target-i)
 210                      (incf ,i))
 211                (return))
 212               ((funcall2-using-key ,pred ,key
 213                                    (,source-ref ,source ,j)
 214                                    (,source-ref ,source ,i))
 215                (setf (,target-ref ,target ,target-i)
 216                      (,source-ref ,source ,j))
 217                (incf ,j))
 218               (t (setf (,target-ref ,target ,target-i)
 219                        (,source-ref ,source ,i))
 220                  (incf ,i)))
 221         (incf ,target-i)))))
 222
 223 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 224 ;;; but it uses a temporary vector. DIRECTION determines whether we
 225 ;;; are merging into the temporary (T) or back into the given vector
 226 ;;; (NIL).
 227 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 228   (with-unique-names
 229       (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len i)
 230     `(let* ((,vector-len (length (the vector ,vector)))
 231             (,n 1)        ; bottom-up size of contiguous runs to be merged
 232             (,direction t) ; t vector --> temp    nil temp --> vector
 233             (,temp *merge-sort-temp-vector*)
 234             (,temp-len (length ,temp))
 235             (,unsorted 0)  ; unsorted..vector-len are the elements that need
 236                            ; to be merged for a given n
 237             (,start-1 0))  ; one n-len subsequence to be merged with the next
 238        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1)
 239                 (simple-vector ,temp))
 240        (when (> ,vector-len ,temp-len)
 241          (setf ,temp (make-array (max ,vector-len
 242                                       (min most-positive-fixnum
 243                                            (+ ,temp-len ,temp-len))))
 244                *merge-sort-temp-vector* ,temp))
 245        ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also
 246        ;; interrupt safe: we bind before we put any data of our own in
 247        ;; the temp vector.
 248        (let ((*merge-sort-temp-vector* (vector)))
 249          (loop
 250             ;; for each n, we start taking n-runs from the start of the vector
 251             (setf ,unsorted 0)
 252             (loop
 253                (setf ,start-1 ,unsorted)
 254                (let ((,end-1 (+ ,start-1 ,n)))
 255                  (declare (fixnum ,end-1))
 256                  (cond ((< ,end-1 ,vector-len)
 257                         ;; there are enough elements for a second run
 258                         (let ((,end-2 (+ ,end-1 ,n)))
 259                           (declare (fixnum ,end-2))
 260                           (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 261                           (setf ,unsorted ,end-2)
 262                           (if ,direction
 263                               (stable-sort-merge-vectors*
 264                                ,vector ,temp
 265                                ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 266                               (stable-sort-merge-vectors*
 267                                ,temp ,vector
 268                                ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 269                           (if (= ,unsorted ,vector-len) (return))))
 270                        ;; if there is only one run, copy those elements to the end
 271                        (t (if ,direction
 272                               (do ((,i ,start-1 (1+ ,i)))
 273                                   ((= ,i ,vector-len))
 274                                 (declare (fixnum ,i))
 275                                (setf (svref ,temp ,i)
 276                                      (,vector-ref ,vector ,i)))
 277                              (do ((,i ,start-1 (1+ ,i)))
 278                                  ((= ,i ,vector-len))
 279                                (declare (fixnum ,i))
 280                                (setf (,vector-ref ,vector ,i)
 281                                      (svref ,temp ,i))))
 282                          (return)))))
 283            ;; If the inner loop only executed once, then there were only enough
 284            ;; elements for two subsequences given n, so all the elements have
 285            ;; been merged into one list. Start-1 will have remained 0 upon exit.
 286            (when (zerop ,start-1)
 287              (if ,direction
 288                  ;; if we just merged into the temporary, copy it all back
 289                  ;; to the given vector.
 290                  (dotimes (,i ,vector-len)
 291                    (setf (,vector-ref ,vector ,i)
 292                          (svref ,temp ,i))))
 293              (return ,vector))
 294            (setf ,n (ash ,n 1))         ; (* 2 n)
 295            (setf ,direction (not ,direction)))))))
 296
 297 ) ; EVAL-when
 298
 299 ;;; temporary vector for stable sorting vectors, allocated for each new thread
 300 (defvar *merge-sort-temp-vector* (vector))
 301 (declaim (simple-vector *merge-sort-temp-vector*))
 302
 303 (defun stable-sort-simple-vector (vector pred key)
 304   (declare (type simple-vector vector)
 305            (type function pred)
 306            (type (or null function) key))
 307   (vector-merge-sort vector pred key svref))
 308
 309 (defun stable-sort-vector (vector pred key)
 310   (declare (type function pred)
 311            (type (or null function) key))
 312   (vector-merge-sort vector pred key aref))
 313 \f
 314 ;;;; merging
 315
 316 (eval-when (:compile-toplevel :execute)
 317
 318 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 319 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 320 ;;; are chosen only if they are strictly less than elements of
 321 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 322 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 323                                result-vector pred key access)
 324   (let ((result-i (gensym))
 325         (i (gensym))
 326         (j (gensym)))
 327     `(let* ((,result-i 0)
 328             (,i 0)
 329             (,j 0))
 330        (declare (fixnum ,result-i ,i ,j))
 331        (loop
 332         (cond ((= ,i ,length-1)
 333                (loop (if (= ,j ,length-2) (return))
 334                      (setf (,access ,result-vector ,result-i)
 335                            (,access ,vector-2 ,j))
 336                      (incf ,result-i)
 337                      (incf ,j))
 338                (return ,result-vector))
 339               ((= ,j ,length-2)
 340                (loop (if (= ,i ,length-1) (return))
 341                      (setf (,access ,result-vector ,result-i)
 342                            (,access ,vector-1 ,i))
 343                      (incf ,result-i)
 344                      (incf ,i))
 345                (return ,result-vector))
 346               ((funcall2-using-key ,pred ,key
 347                                    (,access ,vector-2 ,j) (,access ,vector-1 ,i))
 348                (setf (,access ,result-vector ,result-i)
 349                      (,access ,vector-2 ,j))
 350                (incf ,j))
 351               (t (setf (,access ,result-vector ,result-i)
 352                        (,access ,vector-1 ,i))
 353                  (incf ,i)))
 354         (incf ,result-i)))))
 355
 356 ) ; EVAL-WHEN
 357
 358 (defun merge (result-type sequence1 sequence2 predicate &key key)
 359   #!+sb-doc
 360   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 361    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 362   ;; FIXME: This implementation is remarkably inefficient in various
 363   ;; ways. In decreasing order of estimated user astonishment, I note:
 364   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
 365   ;; to lists before doing MERGE-LISTS*; and walking input lists
 366   ;; (because of the call to MERGE-LISTS*, which walks the list to
 367   ;; find the last element for its second return value) even in cases
 368   ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
 369   ;; can be largely ignored. -- WHN 2003-01-05
 370   (let ((type (specifier-type result-type)))
 371     (cond
 372       ((csubtypep type (specifier-type 'list))
 373        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
 374        ;; benefits from the error checking there. Short of
 375        ;; reimplementing everything, we can't do the same for the LIST
 376        ;; case, so do relevant length checking here:
 377        (let ((s1 (coerce sequence1 'list))
 378              (s2 (coerce sequence2 'list))
 379              (pred-fun (%coerce-callable-to-fun predicate))
 380              (key-fun (if key
 381                           (%coerce-callable-to-fun key)
 382                           #'identity)))
 383          (when (type= type (specifier-type 'list))
 384            (return-from merge (values (merge-lists* s1 s2 pred-fun key-fun))))
 385          (when (eq type *empty-type*)
 386            (bad-sequence-type-error nil))
 387          (when (type= type (specifier-type 'null))
 388            (if (and (null s1) (null s2))
 389                (return-from merge 'nil)
 390                ;; FIXME: This will break on circular lists (as,
 391                ;; indeed, will the whole MERGE function).
 392                (sequence-type-length-mismatch-error type
 393                                                     (+ (length s1)
 394                                                        (length s2)))))
 395          (if (cons-type-p type)
 396              (multiple-value-bind (min exactp)
 397                  (sb!kernel::cons-type-length-info type)
 398                (let ((length (+ (length s1) (length s2))))
 399                  (if exactp
 400                      (unless (= length min)
 401                        (sequence-type-length-mismatch-error type length))
 402                      (unless (>= length min)
 403                        (sequence-type-length-mismatch-error type length)))
 404                  (values (merge-lists* s1 s2 pred-fun key-fun))))
 405              (sequence-type-too-hairy result-type))))
 406       ((csubtypep type (specifier-type 'vector))
 407        (let* ((vector-1 (coerce sequence1 'vector))
 408               (vector-2 (coerce sequence2 'vector))
 409               (length-1 (length vector-1))
 410               (length-2 (length vector-2))
 411               (result (make-sequence result-type (+ length-1 length-2))))
 412          (declare (vector vector-1 vector-2)
 413                   (fixnum length-1 length-2))
 414          (if (and (simple-vector-p result)
 415                   (simple-vector-p vector-1)
 416                   (simple-vector-p vector-2))
 417              (merge-vectors vector-1 length-1 vector-2 length-2
 418                             result predicate key svref)
 419              (merge-vectors vector-1 length-1 vector-2 length-2
 420                             result predicate key aref))))
 421       ((and (csubtypep type (specifier-type 'sequence))
 422             (find-class result-type nil))
 423        (let* ((vector-1 (coerce sequence1 'vector))
 424               (vector-2 (coerce sequence2 'vector))
 425               (length-1 (length vector-1))
 426               (length-2 (length vector-2))
 427               (temp (make-array (+ length-1 length-2)))
 428               (result (make-sequence result-type (+ length-1 length-2))))
 429          (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
 430          (merge-vectors vector-1 length-1 vector-2 length-2
 431                         temp predicate key aref)
 432          (replace result temp)
 433          result))
 434       (t (bad-sequence-type-error result-type)))))