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   (let ((key1 (funcall key (car list1)))
  85         (key2 (funcall key (car list2))))
  86     (macrolet ((merge-one (l1 k1 l2)
  87                  `(progn
  88                     (setf (cdr tail) ,l1
  89                           tail       ,l1)
  90                     (let ((rest (cdr ,l1)))
  91                       (cond (rest
  92                              (setf ,l1 rest
  93                                    ,k1 (funcall key (first rest))))
  94                             (t
  95                              (setf (cdr ,l1) ,l2)
  96                              (return (cdr head))))))))
  97       (loop
  98        (if (funcall test key2           ; this way, equivalent
  99                          key1)          ; values are first popped
 100            (merge-one list2 key2 list1) ; from list1
 101            (merge-one list1 key1 list2))))))
 102
 103 ;;; Convenience wrapper for CL:MERGE
 104 (declaim (inline merge-lists))
 105 (defun merge-lists (list1 list2 test key)
 106   (cond ((null list1)
 107          list2)
 108         ((null list2)
 109          list1)
 110         (t
 111          (let ((head (cons nil nil)))
 112            (declare (dynamic-extent head))
 113            (merge-lists* head list1 list2 test key)))))
 114
 115 ;;; Small specialised stable sorts
 116 (declaim (inline stable-sort-list-2 stable-sort-list-3))
 117 (defun stable-sort-list-2 (list test key)
 118   (declare (type cons list)
 119            (type function test key))
 120   (let ((second (cdr list)))
 121     (declare (type cons second))
 122     (when (funcall test (funcall key (car second))
 123                         (funcall key (car list)))
 124       (rotatef (car list) (car second)))
 125     (values list second (shiftf (cdr second) nil))))
 126
 127 (defun stable-sort-list-3 (list test key)
 128   (declare (type cons list)
 129            (type function test key))
 130   (let* ((second (cdr list))
 131          (third  (cdr second))
 132          (x (car list))
 133          (y (car second))
 134          (z (car third)))
 135     (declare (type cons second third))
 136     (when (funcall test (funcall key y)
 137                         (funcall key x))
 138       (rotatef x y))
 139     (let ((key-z (funcall key z)))
 140       (when (funcall test key-z
 141                           (funcall key y))
 142         (if (funcall test key-z
 143                           (funcall key x))
 144             (rotatef x z y)
 145             (rotatef z y))))
 146     (setf (car list)   x
 147           (car second) y
 148           (car third)  z)
 149     (values list third (shiftf (cdr third) nil))))
 150
 151 ;;; STABLE-SORT-LIST implements a top-down merge sort. See the closest
 152 ;;; intro to algorithms book.  Benchmarks have shown significantly
 153 ;;; improved performance over the previous (hairier) bottom-up
 154 ;;; implementation, particularly on non-power-of-two sizes: bottom-up
 155 ;;; recursed on power-of-two-sized subsequences, which can result in
 156 ;;; very unbalanced recursion trees.
 157
 158 ;;; The minimum length at which list merge sort will try and detect
 159 ;;; it can merge disjoint ranges (e.g. sorted inputs) in constant time.
 160 (defconstant +stable-sort-fast-merge-limit+ 8)
 161
 162 (defun stable-sort-list (list test key &aux (head (cons :head list)))
 163   (declare (type list list)
 164            (type function test key)
 165            (dynamic-extent head))
 166   (declare (explicit-check))
 167   (labels ((merge* (size list1 tail1 list2 tail2 rest)
 168              (declare (optimize speed)
 169                       (type (and fixnum unsigned-byte) size)
 170                       (type cons list1 tail1 list2 tail2))
 171              (when (>= size +stable-sort-fast-merge-limit+)
 172                (cond ((not (funcall test (funcall key (car list2))   ; stability
 173                                          (funcall key (car tail1)))) ; trickery
 174                       (setf (cdr tail1) list2)
 175                       (return-from merge* (values list1 tail2 rest)))
 176                      ((funcall test (funcall key (car tail2))
 177                                     (funcall key (car list1)))
 178                       (setf (cdr tail2) list1)
 179                       (return-from merge* (values list2 tail1 rest)))))
 180                (values (merge-lists* head list1 list2 test key)
 181                        (if (null (cdr tail1))
 182                            tail1
 183                            tail2)
 184                        rest))
 185            (recur (list size)
 186              (declare (optimize speed)
 187                       (type cons list)
 188                       (type (and fixnum unsigned-byte) size))
 189              (cond ((> size 3)
 190                     (let ((half (ash size -1)))
 191                       (multiple-value-bind (list1 tail1 rest)
 192                           (recur list half)
 193                         (multiple-value-bind (list2 tail2 rest)
 194                             (recur rest (- size half))
 195                           (merge* size list1 tail1 list2 tail2 rest)))))
 196                    ((= size 3)
 197                     (stable-sort-list-3 list test key))
 198                    ((= size 2)
 199                     (stable-sort-list-2 list test key))
 200                    (t ; (= size 1)
 201                     (values list list (shiftf (cdr list) nil))))))
 202     (when list
 203       (values (recur list (length list))))))
 204 \f
 205 ;;;; stable sort of vectors
 206
 207 ;;; Stable sorting vectors is done with the same algorithm used for
 208 ;;; lists, using a temporary vector to merge back and forth between it
 209 ;;; and the given vector to sort.
 210
 211 (eval-when (:compile-toplevel :execute)
 212
 213 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 214 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 215 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 216 ;;; and merges them into a target vector starting at index start-1.
 217
 218 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 219                                                      pred key source-ref
 220                                                      target-ref)
 221   (let ((i (gensym))
 222         (j (gensym))
 223         (target-i (gensym)))
 224     `(let ((,i ,start-1)
 225            (,j ,end-1) ; start-2
 226            (,target-i ,start-1))
 227        (declare (fixnum ,i ,j ,target-i))
 228        (loop
 229         (cond ((= ,i ,end-1)
 230                (loop (if (= ,j ,end-2) (return))
 231                      (setf (,target-ref ,target ,target-i)
 232                            (,source-ref ,source ,j))
 233                      (incf ,target-i)
 234                      (incf ,j))
 235                (return))
 236               ((= ,j ,end-2)
 237                (loop (if (= ,i ,end-1) (return))
 238                      (setf (,target-ref ,target ,target-i)
 239                            (,source-ref ,source ,i))
 240                      (incf ,target-i)
 241                      (incf ,i))
 242                (return))
 243               ((funcall2-using-key ,pred ,key
 244                                    (,source-ref ,source ,j)
 245                                    (,source-ref ,source ,i))
 246                (setf (,target-ref ,target ,target-i)
 247                      (,source-ref ,source ,j))
 248                (incf ,j))
 249               (t (setf (,target-ref ,target ,target-i)
 250                        (,source-ref ,source ,i))
 251                  (incf ,i)))
 252         (incf ,target-i)))))
 253
 254 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 255 ;;; but it uses a temporary vector. DIRECTION determines whether we
 256 ;;; are merging into the temporary (T) or back into the given vector
 257 ;;; (NIL).
 258 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 259   (with-unique-names
 260       (vector-len n direction unsorted start-1 end-1 end-2 temp i)
 261     `(let* ((,vector-len (length (the vector ,vector)))
 262             (,n 1)            ; bottom-up size of contiguous runs to be merged
 263             (,direction t)    ; t vector --> temp    nil temp --> vector
 264             (,temp (make-array ,vector-len))
 265             (,unsorted 0)   ; unsorted..vector-len are the elements that need
 266                                         ; to be merged for a given n
 267             (,start-1 0))   ; one n-len subsequence to be merged with the next
 268        (declare (fixnum ,vector-len ,n ,unsorted ,start-1)
 269                 (simple-vector ,temp))
 270        (loop
 271          ;; for each n, we start taking n-runs from the start of the vector
 272          (setf ,unsorted 0)
 273          (loop
 274            (setf ,start-1 ,unsorted)
 275            (let ((,end-1 (+ ,start-1 ,n)))
 276              (declare (fixnum ,end-1))
 277              (cond ((< ,end-1 ,vector-len)
 278                     ;; there are enough elements for a second run
 279                     (let ((,end-2 (+ ,end-1 ,n)))
 280                       (declare (fixnum ,end-2))
 281                       (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 282                       (setf ,unsorted ,end-2)
 283                       (if ,direction
 284                           (stable-sort-merge-vectors*
 285                            ,vector ,temp
 286                            ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 287                           (stable-sort-merge-vectors*
 288                            ,temp ,vector
 289                            ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 290                       (if (= ,unsorted ,vector-len) (return))))
 291                    ;; if there is only one run, copy those elements to the end
 292                    (t (if ,direction
 293                           (do ((,i ,start-1 (1+ ,i)))
 294                               ((= ,i ,vector-len))
 295                             (declare (fixnum ,i))
 296                             (setf (svref ,temp ,i) (,vector-ref ,vector ,i)))
 297                           (do ((,i ,start-1 (1+ ,i)))
 298                               ((= ,i ,vector-len))
 299                             (declare (fixnum ,i))
 300                             (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
 301                       (return)))))
 302          ;; If the inner loop only executed once, then there were only enough
 303          ;; elements for two subsequences given n, so all the elements have
 304          ;; been merged into one list. Start-1 will have remained 0 upon exit.
 305          (when (zerop ,start-1)
 306            (when ,direction
 307              ;; if we just merged into the temporary, copy it all back
 308              ;; to the given vector.
 309              (dotimes (,i ,vector-len)
 310                (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
 311            ;; Kill the new vector to prevent garbage from being retained.
 312            (%shrink-vector ,temp 0)
 313            (return ,vector))
 314          (setf ,n (ash ,n 1))           ; (* 2 n)
 315          (setf ,direction (not ,direction))))))
 316
 317 ) ; EVAL-when
 318
 319 (defun stable-sort-simple-vector (vector pred key)
 320   (declare (type simple-vector vector)
 321            (type function pred)
 322            (type (or null function) key))
 323   (declare (explicit-check))
 324   (vector-merge-sort vector pred key svref))
 325
 326 (defun stable-sort-vector (vector pred key)
 327   (declare (type function pred)
 328            (type (or null function) key))
 329   (declare (explicit-check))
 330   (vector-merge-sort vector pred key aref))
 331 \f
 332 ;;;; merging
 333
 334 (eval-when (:compile-toplevel :execute)
 335
 336 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 337 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 338 ;;; are chosen only if they are strictly less than elements of
 339 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 340 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 341                                result-vector pred key access)
 342   (let ((result-i (gensym))
 343         (i (gensym))
 344         (j (gensym)))
 345     `(let* ((,result-i 0)
 346             (,i 0)
 347             (,j 0))
 348        (declare (fixnum ,result-i ,i ,j))
 349        (loop
 350         (cond ((= ,i ,length-1)
 351                (loop (if (= ,j ,length-2) (return))
 352                      (setf (,access ,result-vector ,result-i)
 353                            (,access ,vector-2 ,j))
 354                      (incf ,result-i)
 355                      (incf ,j))
 356                (return ,result-vector))
 357               ((= ,j ,length-2)
 358                (loop (if (= ,i ,length-1) (return))
 359                      (setf (,access ,result-vector ,result-i)
 360                            (,access ,vector-1 ,i))
 361                      (incf ,result-i)
 362                      (incf ,i))
 363                (return ,result-vector))
 364               ((funcall2-using-key ,pred ,key
 365                                    (,access ,vector-2 ,j) (,access ,vector-1 ,i))
 366                (setf (,access ,result-vector ,result-i)
 367                      (,access ,vector-2 ,j))
 368                (incf ,j))
 369               (t (setf (,access ,result-vector ,result-i)
 370                        (,access ,vector-1 ,i))
 371                  (incf ,i)))
 372         (incf ,result-i)))))
 373
 374 ) ; EVAL-WHEN
 375
 376 (defun merge (result-type sequence1 sequence2 predicate &key key)
 377   #!+sb-doc
 378   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 379    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 380   ;; FIXME: This implementation is remarkably inefficient in various
 381   ;; ways. In decreasing order of estimated user astonishment, I note:
 382   ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
 383   ;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
 384   (declare (explicit-check))
 385   (let ((type (specifier-type result-type))
 386         (pred-fun (%coerce-callable-to-fun predicate))
 387         ;; Avoid coercing NIL to a function since 2 out of 3 branches of the
 388         ;; COND below optimize for NIL as the key function. Additionally
 389         ;; recognize the reverse - when you said #'IDENTITY which can be
 390         ;; turned into NIL. Also, in the generic case, don't defer a
 391         ;; type error to the method (even though it also coerces to fun).
 392         (key-fun (when (and key (neq key #'identity))
 393                    (%coerce-callable-to-fun key))))
 394     (cond
 395       ((csubtypep type (specifier-type 'list))
 396        ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
 397        ;; benefits from the error checking there. Short of
 398        ;; reimplementing everything, we can't do the same for the LIST
 399        ;; case, so do relevant length checking here:
 400        (let ((s1 (coerce sequence1 'list))
 401              (s2 (coerce sequence2 'list))
 402              ;; MERGE-LISTS* does not contain special code for KEY = NIL.
 403              (key-fun (or key-fun #'identity)))
 404          (when (type= type (specifier-type 'list))
 405            (return-from merge (merge-lists s1 s2 pred-fun key-fun)))
 406          (when (eq type *empty-type*)
 407            (bad-sequence-type-error nil))
 408          (when (type= type (specifier-type 'null))
 409            (if (and (null s1) (null s2))
 410                (return-from merge 'nil)
 411                ;; FIXME: This will break on circular lists (as,
 412                ;; indeed, will the whole MERGE function).
 413                (sequence-type-length-mismatch-error type
 414                                                     (+ (length s1)
 415                                                        (length s2)))))
 416          (if (cons-type-p type)
 417              (multiple-value-bind (min exactp)
 418                  (sb!kernel::cons-type-length-info type)
 419                (let ((length (+ (length s1) (length s2))))
 420                  (if exactp
 421                      (unless (= length min)
 422                        (sequence-type-length-mismatch-error type length))
 423                      (unless (>= length min)
 424                        (sequence-type-length-mismatch-error type length)))
 425                  (merge-lists s1 s2 pred-fun key-fun)))
 426              (sequence-type-too-hairy result-type))))
 427       ((csubtypep type (specifier-type 'vector))
 428        (let* ((vector-1 (coerce sequence1 'vector))
 429               (vector-2 (coerce sequence2 'vector))
 430               (length-1 (length vector-1))
 431               (length-2 (length vector-2))
 432               (result (make-sequence result-type (+ length-1 length-2))))
 433          (declare (vector vector-1 vector-2) ; FIXME: this looks redundant,
 434                   (fixnum length-1 length-2)) ; as does this.
 435          (if (and (simple-vector-p result)
 436                   (simple-vector-p vector-1)
 437                   (simple-vector-p vector-2))
 438              (merge-vectors vector-1 length-1 vector-2 length-2
 439                             result pred-fun key-fun svref)
 440              ;; Some things that could improve the fancy vector case:
 441              ;; - recognize when the only fancy aspect of both inputs
 442              ;;   is that they have fill pointers.
 443              ;; - use the specialized reffer for inputs + output
 444              (merge-vectors vector-1 length-1 vector-2 length-2
 445                             result pred-fun key-fun aref))))
 446       ((when-extended-sequence-type
 447            (result-type type :expandedp nil :prototype prototype)
 448          ;; This function has the EXPLICIT-CHECK declaration, so we
 449          ;; manually assert that it returns a SEQUENCE.
 450          (the extended-sequence
 451               ;; GF dispatch deals with the erroneous situation
 452               ;; wherein either of SEQUENCE1 or SEQUENCE2 is not a
 453               ;; sequence.  Note that the one builtin method optimizes
 454               ;; for NIL as the key fun, and we correctly preserve a
 455               ;; NIL here.
 456               (sb!sequence:merge
 457                prototype sequence1 sequence2 pred-fun :key key-fun))))
 458       (t (bad-sequence-type-error result-type)))))