-;;; Make simple-vector and miscellaneous vector sorting functions.
-(macrolet (;; BUILD-HEAP rearranges seq elements into a heap to start heap
- ;; sorting.
- (build-heap (seq type len-1 pred key)
- (let ((i (gensym)))
- `(do ((,i (floor ,len-1 2) (1- ,i)))
- ((minusp ,i) ,seq)
- (declare (fixnum ,i))
- (heapify ,seq ,type ,i ,len-1 ,pred ,key))))
- ;; HEAPIFY, assuming both sons of root are heaps, percolates the
- ;; root element through the sons to form a heap at root. Root and
- ;; max are zero based coordinates, but the heap algorithm only works
- ;; on arrays indexed from 1 through N (not 0 through N-1); This is
- ;; because a root at I has sons at 2*I and 2*I+1 which does not work
- ;; for a root at 0. Because of this, boundaries, roots, and
- ;; termination are computed using 1..N indexes.
- (heapify (seq vector-ref root max pred key)
- (let ((heap-root (gensym))
- (heap-max (gensym))
- (root-ele (gensym))
- (root-key (gensym))
- (heap-max/2 (gensym))
- (heap-l-son (gensym))
- (one-son (gensym))
- (one-son-ele (gensym))
- (one-son-key (gensym))
- (r-son-ele (gensym))
- (r-son-key (gensym))
- (var-root (gensym)))
- `(let* ((,var-root ,root) ; (necessary to not clobber calling
- ; root var)
- (,heap-root (1+ ,root))
- (,heap-max (1+ ,max))
- (,root-ele (,vector-ref ,seq ,root))
- (,root-key (apply-key ,key ,root-ele))
- (,heap-max/2 (ash ,heap-max -1))) ; (floor heap-max 2)
- (declare (fixnum ,var-root ,heap-root ,heap-max ,heap-max/2))
- (loop
- (if (> ,heap-root ,heap-max/2) (return))
- (let* ((,heap-l-son (ash ,heap-root 1)) ; (* 2 heap-root)
- ;; l-son index in seq (0..N-1) is one less than heap
- ;; computation.
- (,one-son (1- ,heap-l-son))
- (,one-son-ele (,vector-ref ,seq ,one-son))
- (,one-son-key (apply-key ,key ,one-son-ele)))
- (declare (fixnum ,heap-l-son ,one-son))
- (if (< ,heap-l-son ,heap-max)
- ;; There is a right son.
- (let* ((,r-son-ele (,vector-ref ,seq ,heap-l-son))
- (,r-son-key (apply-key ,key ,r-son-ele)))
- ;; Choose the greater of the two sons.
- (when (funcall ,pred ,one-son-key ,r-son-key)
- (setf ,one-son ,heap-l-son)
- (setf ,one-son-ele ,r-son-ele)
- (setf ,one-son-key ,r-son-key))))
- ;; If greater son is less than root, then we've formed a
- ;; heap again..
- (if (funcall ,pred ,one-son-key ,root-key) (return))
- ;; ..else put greater son at root and make greater son
- ;; node be the root.
- (setf (,vector-ref ,seq ,var-root) ,one-son-ele)
- (setf ,heap-root (1+ ,one-son)) ; (one plus to be in heap coordinates)
- (setf ,var-root ,one-son))) ; actual index into vector for root ele
- ;; Now really put percolated value into heap at the
- ;; appropriate root node.
- (setf (,vector-ref ,seq ,var-root) ,root-ele))))
- (def-vector-sort-fun (fun-name vector-ref)
- `(defun ,fun-name (seq pred key)
- (let ((len-1 (1- (length (the vector seq)))))
- (declare (fixnum len-1))
- (build-heap seq ,vector-ref len-1 pred key)
- (do* ((i len-1 i-1)
- (i-1 (1- i) (1- i-1)))
- ((zerop i) seq)
- (declare (fixnum i i-1))
- (rotatef (,vector-ref seq 0) (,vector-ref seq i))
- (heapify seq ,vector-ref 0 i-1 pred key))))))
- (def-vector-sort-fun sort-vector aref)
- (def-vector-sort-fun sort-simple-vector svref))
+;;; This is MAYBE-INLINE because it's not too hard to have an
+;;; application where sorting is a major bottleneck, and inlining it
+;;; allows the compiler to make enough optimizations that it might be
+;;; worth the (large) cost in space.
+(declaim (maybe-inline sort))
+(defun sort (sequence predicate &rest args &key key)
+ #!+sb-doc
+ "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
+ ARG1 is to precede ARG2."
+ (declare (dynamic-extent args))
+ (let ((predicate-fun (%coerce-callable-to-fun predicate)))
+ (seq-dispatch sequence
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity))
+ (let ((key-fun-or-nil (and key (%coerce-callable-to-fun key))))
+ (with-array-data ((vector (the vector sequence))
+ (start 0)
+ (end (length sequence)))
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
+ sequence)
+ (apply #'sb!sequence:sort sequence predicate args))))