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 ;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
  15 ;;; isn't really related to the CMU CL code, since instead of trying
  16 ;;; to generalize the CMU CL code to allow START and END values, this
  17 ;;; code has been written from scratch following Chapter 7 of
  18 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
  19 (macrolet ((%index (x) `(truly-the index ,x))
  20            (%parent (i) `(ash ,i -1))
  21            (%left (i) `(%index (ash ,i 1)))
  22            (%right (i) `(%index (1+ (ash ,i 1))))
  23            (%heapify (i)
  24              `(do* ((i ,i)
  25                     (left (%left i) (%left i)))
  26                   ((> left current-heap-size))
  27                 (declare (type index i left))
  28                 (let* ((i-elt (%elt i))
  29                        (i-key (funcall keyfun i-elt))
  30                        (left-elt (%elt left))
  31                        (left-key (funcall keyfun left-elt)))
  32                   (multiple-value-bind (large large-elt large-key)
  33                       (if (funcall predicate i-key left-key)
  34                           (values left left-elt left-key)
  35                           (values i i-elt i-key))
  36                     (let ((right (%right i)))
  37                       (multiple-value-bind (largest largest-elt)
  38                           (if (> right current-heap-size)
  39                               (values large large-elt)
  40                               (let* ((right-elt (%elt right))
  41                                      (right-key (funcall keyfun right-elt)))
  42                                 (if (funcall predicate large-key right-key)
  43                                     (values right right-elt)
  44                                     (values large large-elt))))
  45                         (cond ((= largest i)
  46                                (return))
  47                               (t
  48                                (setf (%elt i) largest-elt
  49                                      (%elt largest) i-elt
  50                                      i largest)))))))))
  51            (%sort-vector (keyfun &optional (vtype 'vector))
  52              `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
  53                          ;; type inference to propagate all the way
  54                          ;; through this tangled mess of inlining. The
  55                          ;; TRULY-THE here works around that. -- WHN
  56                          (%elt (i)
  57                            `(aref (truly-the ,',vtype vector)
  58                                   (%index (+ (%index ,i) start-1)))))
  59                 (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
  60                       (current-heap-size (- end start))
  61                       (keyfun ,keyfun))
  62                   (declare (type (integer -1 #.(1- most-positive-fixnum))
  63                                  start-1))
  64                   (declare (type index current-heap-size))
  65                   (declare (type function keyfun))
  66                   (loop for i of-type index
  67                         from (ash current-heap-size -1) downto 1 do
  68                         (%heapify i))
  69                   (loop
  70                    (when (< current-heap-size 2)
  71                      (return))
  72                    (rotatef (%elt 1) (%elt current-heap-size))
  73                    (decf current-heap-size)
  74                    (%heapify 1))))))
  75
  76   (declaim (inline sort-vector))
  77   (defun sort-vector (vector start end predicate key)
  78     (declare (type vector vector))
  79     (declare (type index start end))
  80     (declare (type function predicate))
  81     (declare (type (or function null) key))
  82     ;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now
  83     ;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including
  84     ;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer
  85     ;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast,
  86     ;; pretty safe, and safety is no more important than speed".
  87     (declare (optimize (speed 2) (safety 2) (debug 1) (space 1)))
  88     (if (typep vector 'simple-vector)
  89         ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
  90         ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
  91         (if (null key)
  92             ;; Special-casing the KEY=NIL case lets us avoid some
  93             ;; function calls.
  94             (%sort-vector #'identity simple-vector)
  95             (%sort-vector key simple-vector))
  96         ;; It's hard to anticipate many speed-critical applications for
  97         ;; sorting vector types other than (VECTOR T), so we just lump
  98         ;; them all together in one slow dynamically typed mess.
  99         (locally
 100           (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
 101           (%sort-vector (or key #'identity))))))
 102
 103 ;;; This is MAYBE-INLINE because it's not too hard to have an
 104 ;;; application where sorting is a major bottleneck, and inlining it
 105 ;;; allows the compiler to make enough optimizations that it might be
 106 ;;; worth the (large) cost in space.
 107 (declaim (maybe-inline sort))
 108 (defun sort (sequence predicate &key key)
 109   #!+sb-doc
 110   "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
 111    ARG1 is to precede ARG2."
 112   (let ((predicate-function (%coerce-callable-to-fun predicate))
 113         (key-function (and key (%coerce-callable-to-fun key))))
 114     (typecase sequence
 115       (list (sort-list sequence predicate-function key-function))
 116       (vector
 117        (with-array-data ((vector (the vector sequence))
 118                          (start 0)
 119                          (end (length sequence)))
 120          (sort-vector vector start end predicate-function key-function))
 121        sequence)
 122       (t
 123        (error 'simple-type-error
 124               :datum sequence
 125               :expected-type 'sequence
 126               :format-control "~S is not a sequence."
 127               :format-arguments (list sequence))))))
 128 \f
 129 ;;;; stable sorting
 130
 131 (defun stable-sort (sequence predicate &key key)
 132   #!+sb-doc
 133   "Destructively sorts sequence. Predicate should return non-Nil if
 134    Arg1 is to precede Arg2."
 135   (typecase sequence
 136     (simple-vector
 137      (stable-sort-simple-vector sequence predicate key))
 138     (list
 139      (sort-list sequence predicate key))
 140     (vector
 141      (stable-sort-vector sequence predicate key))
 142     (t
 143      (error 'simple-type-error
 144             :datum sequence
 145             :expected-type 'sequence
 146             :format-control "~S is not a sequence."
 147             :format-arguments (list sequence)))))
 148
 149 ;;; stable sort of lists
 150
 151 ;;; SORT-LIST uses a bottom up merge sort. First a pass is made over
 152 ;;; the list grabbing one element at a time and merging it with the
 153 ;;; next one form pairs of sorted elements. Then n is doubled, and
 154 ;;; elements are taken in runs of two, merging one run with the next
 155 ;;; to form quadruples of sorted elements. This continues until n is
 156 ;;; large enough that the inner loop only runs for one iteration; that
 157 ;;; is, there are only two runs that can be merged, the first run
 158 ;;; starting at the beginning of the list, and the second being the
 159 ;;; remaining elements.
 160
 161 (defun sort-list (list pred key)
 162   (let ((head (cons :header list))  ; head holds on to everything
 163         (n 1)                       ; bottom-up size of lists to be merged
 164         unsorted                    ; unsorted is the remaining list to be
 165                                     ;   broken into n size lists and merged
 166         list-1                      ; list-1 is one length n list to be merged
 167         last)                       ; last points to the last visited cell
 168     (declare (fixnum n))
 169     (loop
 170      ;; start collecting runs of n at the first element
 171      (setf unsorted (cdr head))
 172      ;; tack on the first merge of two n-runs to the head holder
 173      (setf last head)
 174      (let ((n-1 (1- n)))
 175        (declare (fixnum n-1))
 176        (loop
 177         (setf list-1 unsorted)
 178         (let ((temp (nthcdr n-1 list-1))
 179               list-2)
 180           (cond (temp
 181                  ;; there are enough elements for a second run
 182                  (setf list-2 (cdr temp))
 183                  (setf (cdr temp) nil)
 184                  (setf temp (nthcdr n-1 list-2))
 185                  (cond (temp
 186                         (setf unsorted (cdr temp))
 187                         (setf (cdr temp) nil))
 188                        ;; the second run goes off the end of the list
 189                        (t (setf unsorted nil)))
 190                  (multiple-value-bind (merged-head merged-last)
 191                      (merge-lists* list-1 list-2 pred key)
 192                    (setf (cdr last) merged-head)
 193                    (setf last merged-last))
 194                  (if (null unsorted) (return)))
 195                 ;; if there is only one run, then tack it on to the end
 196                 (t (setf (cdr last) list-1)
 197                    (return)))))
 198        (setf n (ash n 1)) ; (+ n n)
 199        ;; If the inner loop only executed once, then there were only
 200        ;; enough elements for two runs given n, so all the elements
 201        ;; have been merged into one list. This may waste one outer
 202        ;; iteration to realize.
 203        (if (eq list-1 (cdr head))
 204            (return list-1))))))
 205
 206 ;;; APPLY-PRED saves us a function call sometimes.
 207 (eval-when (:compile-toplevel :execute)
 208   (sb!xc:defmacro apply-pred (one two pred key)
 209     `(if ,key
 210          (funcall ,pred (funcall ,key ,one)
 211                   (funcall ,key  ,two))
 212          (funcall ,pred ,one ,two)))
 213 ) ; EVAL-WHEN
 214
 215 (defvar *merge-lists-header* (list :header))
 216
 217 ;;; MERGE-LISTS*   originally written by Jim Large.
 218 ;;;                modified to return a pointer to the end of the result
 219 ;;;                   and to not cons header each time its called.
 220 ;;; It destructively merges list-1 with list-2. In the resulting
 221 ;;; list, elements of list-2 are guaranteed to come after equal elements
 222 ;;; of list-1.
 223 (defun merge-lists* (list-1 list-2 pred key)
 224   (do* ((result *merge-lists-header*)
 225         (P result))                  ; points to last cell of result
 226        ((or (null list-1) (null list-2)) ; done when either list used up
 227         (if (null list-1)              ; in which case, append the
 228             (rplacd p list-2)      ;   other list
 229             (rplacd p list-1))
 230         (do ((drag p lead)
 231              (lead (cdr p) (cdr lead)))
 232             ((null lead)
 233              (values (prog1 (cdr result) ; Return the result sans header
 234                             (rplacd result nil)) ; (free memory, be careful)
 235                      drag))))      ;   and return pointer to last element.
 236     (cond ((apply-pred (car list-2) (car list-1) pred key)
 237            (rplacd p list-2)       ; Append the lesser list to last cell of
 238            (setq p (cdr p))         ;   result. Note: test must bo done for
 239            (pop list-2))               ;   LIST-2 < LIST-1 so merge will be
 240           (T (rplacd p list-1)   ;   stable for LIST-1.
 241              (setq p (cdr p))
 242              (pop list-1)))))
 243
 244 ;;; stable sort of vectors
 245
 246 ;;; Stable sorting vectors is done with the same algorithm used for
 247 ;;; lists, using a temporary vector to merge back and forth between it
 248 ;;; and the given vector to sort.
 249
 250 (eval-when (:compile-toplevel :execute)
 251
 252 ;;; STABLE-SORT-MERGE-VECTORS* takes a source vector with subsequences,
 253 ;;;    start-1 (inclusive) ... end-1 (exclusive) and
 254 ;;;    end-1 (inclusive) ... end-2 (exclusive),
 255 ;;; and merges them into a target vector starting at index start-1.
 256
 257 (sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
 258                                                      pred key source-ref
 259                                                      target-ref)
 260   (let ((i (gensym))
 261         (j (gensym))
 262         (target-i (gensym)))
 263     `(let ((,i ,start-1)
 264            (,j ,end-1) ; start-2
 265            (,target-i ,start-1))
 266        (declare (fixnum ,i ,j ,target-i))
 267        (loop
 268         (cond ((= ,i ,end-1)
 269                (loop (if (= ,j ,end-2) (return))
 270                      (setf (,target-ref ,target ,target-i)
 271                            (,source-ref ,source ,j))
 272                      (incf ,target-i)
 273                      (incf ,j))
 274                (return))
 275               ((= ,j ,end-2)
 276                (loop (if (= ,i ,end-1) (return))
 277                      (setf (,target-ref ,target ,target-i)
 278                            (,source-ref ,source ,i))
 279                      (incf ,target-i)
 280                      (incf ,i))
 281                (return))
 282               ((apply-pred (,source-ref ,source ,j)
 283                            (,source-ref ,source ,i)
 284                            ,pred ,key)
 285                (setf (,target-ref ,target ,target-i)
 286                      (,source-ref ,source ,j))
 287                (incf ,j))
 288               (t (setf (,target-ref ,target ,target-i)
 289                        (,source-ref ,source ,i))
 290                  (incf ,i)))
 291         (incf ,target-i)))))
 292
 293 ;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
 294 ;;; but it uses a temporary vector. DIRECTION determines whether we
 295 ;;; are merging into the temporary (T) or back into the given vector
 296 ;;; (NIL).
 297 (sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
 298   (let ((vector-len (gensym)) (n (gensym))
 299         (direction (gensym))  (unsorted (gensym))
 300         (start-1 (gensym))    (end-1 (gensym))
 301         (end-2 (gensym))      (temp-len (gensym))
 302         (i (gensym)))
 303     `(let ((,vector-len (length (the vector ,vector)))
 304            (,n 1)        ; bottom-up size of contiguous runs to be merged
 305            (,direction t) ; t vector --> temp    nil temp --> vector
 306            (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
 307            (,unsorted 0)  ; unsorted..vector-len are the elements that need
 308                           ; to be merged for a given n
 309            (,start-1 0))  ; one n-len subsequence to be merged with the next
 310        (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
 311        (if (> ,vector-len ,temp-len)
 312            (setf *merge-sort-temp-vector*
 313                  (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
 314        (loop
 315         ;; for each n, we start taking n-runs from the start of the vector
 316         (setf ,unsorted 0)
 317         (loop
 318          (setf ,start-1 ,unsorted)
 319          (let ((,end-1 (+ ,start-1 ,n)))
 320            (declare (fixnum ,end-1))
 321            (cond ((< ,end-1 ,vector-len)
 322                   ;; there are enough elements for a second run
 323                   (let ((,end-2 (+ ,end-1 ,n)))
 324                     (declare (fixnum ,end-2))
 325                     (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
 326                     (setf ,unsorted ,end-2)
 327                     (if ,direction
 328                         (stable-sort-merge-vectors*
 329                          ,vector *merge-sort-temp-vector*
 330                          ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
 331                         (stable-sort-merge-vectors*
 332                          *merge-sort-temp-vector* ,vector
 333                          ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
 334                     (if (= ,unsorted ,vector-len) (return))))
 335                  ;; if there is only one run, copy those elements to the end
 336                  (t (if ,direction
 337                         (do ((,i ,start-1 (1+ ,i)))
 338                             ((= ,i ,vector-len))
 339                           (declare (fixnum ,i))
 340                           (setf (svref *merge-sort-temp-vector* ,i)
 341                                 (,vector-ref ,vector ,i)))
 342                         (do ((,i ,start-1 (1+ ,i)))
 343                             ((= ,i ,vector-len))
 344                           (declare (fixnum ,i))
 345                           (setf (,vector-ref ,vector ,i)
 346                                 (svref *merge-sort-temp-vector* ,i))))
 347                     (return)))))
 348         ;; If the inner loop only executed once, then there were only enough
 349         ;; elements for two subsequences given n, so all the elements have
 350         ;; been merged into one list. Start-1 will have remained 0 upon exit.
 351         (when (zerop ,start-1)
 352           (if ,direction
 353               ;; if we just merged into the temporary, copy it all back
 354               ;; to the given vector.
 355               (dotimes (,i ,vector-len)
 356                 (setf (,vector-ref ,vector ,i)
 357                       (svref *merge-sort-temp-vector* ,i))))
 358           (return ,vector))
 359         (setf ,n (ash ,n 1)) ; (* 2 n)
 360         (setf ,direction (not ,direction))))))
 361
 362 ) ; EVAL-when
 363
 364 ;;; temporary vector for stable sorting vectors
 365 (defvar *merge-sort-temp-vector*
 366   (make-array 50))
 367
 368 (declaim (simple-vector *merge-sort-temp-vector*))
 369
 370 (defun stable-sort-simple-vector (vector pred key)
 371   (declare (simple-vector vector))
 372   (vector-merge-sort vector pred key svref))
 373
 374 (defun stable-sort-vector (vector pred key)
 375   (vector-merge-sort vector pred key aref))
 376
 377 ;;;; merging
 378
 379 (eval-when (:compile-toplevel :execute)
 380
 381 ;;; MERGE-VECTORS returns a new vector which contains an interleaving
 382 ;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
 383 ;;; are chosen only if they are strictly less than elements of
 384 ;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
 385 (sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
 386                                result-vector pred key access)
 387   (let ((result-i (gensym))
 388         (i (gensym))
 389         (j (gensym)))
 390     `(let* ((,result-i 0)
 391             (,i 0)
 392             (,j 0))
 393        (declare (fixnum ,result-i ,i ,j))
 394        (loop
 395         (cond ((= ,i ,length-1)
 396                (loop (if (= ,j ,length-2) (return))
 397                      (setf (,access ,result-vector ,result-i)
 398                            (,access ,vector-2 ,j))
 399                      (incf ,result-i)
 400                      (incf ,j))
 401                (return ,result-vector))
 402               ((= ,j ,length-2)
 403                (loop (if (= ,i ,length-1) (return))
 404                      (setf (,access ,result-vector ,result-i)
 405                            (,access ,vector-1 ,i))
 406                      (incf ,result-i)
 407                      (incf ,i))
 408                (return ,result-vector))
 409               ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
 410                            ,pred ,key)
 411                (setf (,access ,result-vector ,result-i)
 412                      (,access ,vector-2 ,j))
 413                (incf ,j))
 414               (t (setf (,access ,result-vector ,result-i)
 415                        (,access ,vector-1 ,i))
 416                  (incf ,i)))
 417         (incf ,result-i)))))
 418
 419 ) ; EVAL-WHEN
 420
 421 (defun merge (result-type sequence1 sequence2 predicate &key key)
 422   #!+sb-doc
 423   "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
 424    sequence of type RESULT-TYPE using PREDICATE to order the elements."
 425   (if (eq result-type 'list)
 426       (let ((result (merge-lists* (coerce sequence1 'list)
 427                                   (coerce sequence2 'list)
 428                                   predicate key)))
 429         result)
 430       (let* ((vector-1 (coerce sequence1 'vector))
 431              (vector-2 (coerce sequence2 'vector))
 432              (length-1 (length vector-1))
 433              (length-2 (length vector-2))
 434              (result (make-sequence-of-type result-type
 435                                             (+ length-1 length-2))))
 436         (declare (vector vector-1 vector-2)
 437                  (fixnum length-1 length-2))
 438
 439         #!+high-security (aver (typep result result-type))
 440         (if (and (simple-vector-p result)
 441                  (simple-vector-p vector-1)
 442                  (simple-vector-p vector-2))
 443             (merge-vectors vector-1 length-1 vector-2 length-2
 444                            result predicate key svref)
 445             (merge-vectors vector-1 length-1 vector-2 length-2
 446                            result predicate key aref)))))