(in-package "SB!IMPL")
-(defun sort (sequence predicate &key key)
- #!+sb-doc
- "Destructively sorts sequence. Predicate should return non-Nil if
- Arg1 is to precede Arg2."
- (typecase sequence
- (simple-vector
- (if (> (the fixnum (length (the simple-vector sequence))) 0)
- (sort-simple-vector sequence predicate key)
- sequence))
- (list
- (sort-list sequence predicate key))
- (vector
- (if (> (the fixnum (length sequence)) 0)
- (sort-vector sequence predicate key)
- sequence))
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence)))))
-\f
-;;;; sorting vectors
+(defun sort-vector (vector start end predicate-fun key-fun-or-nil)
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
-;;; 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 stable-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 (truly-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)
+ (end)
+ :check-fill-pointer t)
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
+ sequence)
+ (apply #'sb!sequence:sort sequence predicate args))))
\f
;;;; stable sorting
-
-(defun stable-sort (sequence predicate &key key)
+(defun stable-sort (sequence predicate &rest args &key key)
#!+sb-doc
- "Destructively sorts sequence. Predicate should return non-Nil if
- Arg1 is to precede Arg2."
- (typecase sequence
- (simple-vector
- (stable-sort-simple-vector sequence predicate key))
- (list
- (sort-list sequence predicate key))
- (vector
- (stable-sort-vector sequence predicate key))
- (t
- (error 'simple-type-error
- :datum sequence
- :expected-type 'sequence
- :format-control "~S is not a sequence."
- :format-arguments (list sequence)))))
+ "Destructively sort SEQUENCE. PREDICATE should return non-NIL if
+ ARG1 is to precede ARG2."
+ (declare (truly-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))
+ (if (typep sequence 'simple-vector)
+ (stable-sort-simple-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key)))
+ (stable-sort-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (apply #'sb!sequence:stable-sort sequence predicate args))))
+\f
+;;; FUNCALL-USING-KEY saves us a function call sometimes.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro funcall2-using-key (pred key one two)
+ `(if ,key
+ (funcall ,pred (funcall ,key ,one)
+ (funcall ,key ,two))
+ (funcall ,pred ,one ,two)))
+) ; EVAL-WHEN
+\f
+;;;; stable sort of lists
+(declaim (maybe-inline merge-lists* stable-sort-list))
-;;; stable sort of lists
+;;; Destructively merge LIST-1 with LIST-2 (given that they're already
+;;; sorted w.r.t. PRED-FUN on KEY-FUN, giving output sorted the same
+;;; way). In the resulting list, elements of LIST-1 are guaranteed to
+;;; come before equal elements of LIST-2.
+;;;
+;;; Enqueues the values in the right order in HEAD's cdr, and returns
+;;; the merged list.
+(defun merge-lists* (head list1 list2 test key &aux (tail head))
+ (declare (type cons head list1 list2)
+ (type function test key)
+ (optimize speed))
+ (let ((key1 (funcall key (car list1)))
+ (key2 (funcall key (car list2))))
+ (macrolet ((merge-one (l1 k1 l2)
+ `(progn
+ (setf (cdr tail) ,l1
+ tail ,l1)
+ (let ((rest (cdr ,l1)))
+ (cond (rest
+ (setf ,l1 rest
+ ,k1 (funcall key (first rest))))
+ (t
+ (setf (cdr ,l1) ,l2)
+ (return (cdr head))))))))
+ (loop
+ (if (funcall test key2 ; this way, equivalent
+ key1) ; values are first popped
+ (merge-one list2 key2 list1) ; from list1
+ (merge-one list1 key1 list2))))))
-;;; SORT-LIST uses a bottom up merge sort. First a pass is made over the list
-;;; grabbing one element at a time and merging it with the next one form pairs
-;;; of sorted elements. Then n is doubled, and elements are taken in runs of
-;;; two, merging one run with the next to form quadruples of sorted elements.
-;;; This continues until n is large enough that the inner loop only runs for
-;;; one iteration; that is, there are only two runs that can be merged, the
-;;; first run starting at the beginning of the list, and the second being the
-;;; remaining elements.
+;;; Convenience wrapper for CL:MERGE
+(declaim (inline merge-lists))
+(defun merge-lists (list1 list2 test key)
+ (cond ((null list1)
+ list2)
+ ((null list2)
+ list1)
+ (t
+ (let ((head (cons nil nil)))
+ (declare (dynamic-extent head))
+ (merge-lists* head list1 list2 test key)))))
-(defun sort-list (list pred key)
- (let ((head (cons :header list)) ; head holds on to everything
- (n 1) ; bottom-up size of lists to be merged
- unsorted ; unsorted is the remaining list to be
- ; broken into n size lists and merged
- list-1 ; list-1 is one length n list to be merged
- last) ; last points to the last visited cell
- (declare (fixnum n))
- (loop
- ;; start collecting runs of n at the first element
- (setf unsorted (cdr head))
- ;; tack on the first merge of two n-runs to the head holder
- (setf last head)
- (let ((n-1 (1- n)))
- (declare (fixnum n-1))
- (loop
- (setf list-1 unsorted)
- (let ((temp (nthcdr n-1 list-1))
- list-2)
- (cond (temp
- ;; there are enough elements for a second run
- (setf list-2 (cdr temp))
- (setf (cdr temp) nil)
- (setf temp (nthcdr n-1 list-2))
- (cond (temp
- (setf unsorted (cdr temp))
- (setf (cdr temp) nil))
- ;; the second run goes off the end of the list
- (t (setf unsorted nil)))
- (multiple-value-bind (merged-head merged-last)
- (merge-lists* list-1 list-2 pred key)
- (setf (cdr last) merged-head)
- (setf last merged-last))
- (if (null unsorted) (return)))
- ;; if there is only one run, then tack it on to the end
- (t (setf (cdr last) list-1)
- (return)))))
- (setf n (ash n 1)) ; (+ n n)
- ;; If the inner loop only executed once, then there were only enough
- ;; elements for two runs given n, so all the elements have been merged
- ;; into one list. This may waste one outer iteration to realize.
- (if (eq list-1 (cdr head))
- (return list-1))))))
+;;; Small specialised stable sorts
+(declaim (inline stable-sort-list-2 stable-sort-list-3))
+(defun stable-sort-list-2 (list test key)
+ (declare (type cons list)
+ (type function test key))
+ (let ((second (cdr list)))
+ (declare (type cons second))
+ (when (funcall test (funcall key (car second))
+ (funcall key (car list)))
+ (rotatef (car list) (car second)))
+ (values list second (shiftf (cdr second) nil))))
-;;; APPLY-PRED saves us a function call sometimes.
-(eval-when (:compile-toplevel :execute)
- (sb!xc:defmacro apply-pred (one two pred key)
- `(if ,key
- (funcall ,pred (funcall ,key ,one)
- (funcall ,key ,two))
- (funcall ,pred ,one ,two)))
-) ; EVAL-WHEN
+(defun stable-sort-list-3 (list test key)
+ (declare (type cons list)
+ (type function test key))
+ (let* ((second (cdr list))
+ (third (cdr second))
+ (x (car list))
+ (y (car second))
+ (z (car third)))
+ (declare (type cons second third))
+ (when (funcall test (funcall key y)
+ (funcall key x))
+ (rotatef x y))
+ (let ((key-z (funcall key z)))
+ (when (funcall test key-z
+ (funcall key y))
+ (if (funcall test key-z
+ (funcall key x))
+ (rotatef x z y)
+ (rotatef z y))))
+ (setf (car list) x
+ (car second) y
+ (car third) z)
+ (values list third (shiftf (cdr third) nil))))
-(defvar *merge-lists-header* (list :header))
+;;; STABLE-SORT-LIST implements a top-down merge sort. See the closest
+;;; intro to algorithms book. Benchmarks have shown significantly
+;;; improved performance over the previous (hairier) bottom-up
+;;; implementation, particularly on non-power-of-two sizes: bottom-up
+;;; recursed on power-of-two-sized subsequences, which can result in
+;;; very unbalanced recursion trees.
-;;; MERGE-LISTS* originally written by Jim Large.
-;;; modified to return a pointer to the end of the result
-;;; and to not cons header each time its called.
-;;; It destructively merges list-1 with list-2. In the resulting
-;;; list, elements of list-2 are guaranteed to come after equal elements
-;;; of list-1.
-(defun merge-lists* (list-1 list-2 pred key)
- (do* ((result *merge-lists-header*)
- (P result)) ; points to last cell of result
- ((or (null list-1) (null list-2)) ; done when either list used up
- (if (null list-1) ; in which case, append the
- (rplacd p list-2) ; other list
- (rplacd p list-1))
- (do ((drag p lead)
- (lead (cdr p) (cdr lead)))
- ((null lead)
- (values (prog1 (cdr result) ; Return the result sans header
- (rplacd result nil)) ; (free memory, be careful)
- drag)))) ; and return pointer to last element.
- (cond ((apply-pred (car list-2) (car list-1) pred key)
- (rplacd p list-2) ; Append the lesser list to last cell of
- (setq p (cdr p)) ; result. Note: test must bo done for
- (pop list-2)) ; LIST-2 < LIST-1 so merge will be
- (T (rplacd p list-1) ; stable for LIST-1.
- (setq p (cdr p))
- (pop list-1)))))
+;;; The minimum length at which list merge sort will try and detect
+;;; it can merge disjoint ranges (e.g. sorted inputs) in constant time.
+(defconstant +stable-sort-fast-merge-limit+ 8)
-;;; stable sort of vectors
+(defun stable-sort-list (list test key &aux (head (cons :head list)))
+ (declare (type list list)
+ (type function test key)
+ (dynamic-extent head))
+ (labels ((merge* (size list1 tail1 list2 tail2 rest)
+ (declare (optimize speed)
+ (type (and fixnum unsigned-byte) size)
+ (type cons list1 tail1 list2 tail2))
+ (when (>= size +stable-sort-fast-merge-limit+)
+ (cond ((not (funcall test (funcall key (car list2)) ; stability
+ (funcall key (car tail1)))) ; trickery
+ (setf (cdr tail1) list2)
+ (return-from merge* (values list1 tail2 rest)))
+ ((funcall test (funcall key (car tail2))
+ (funcall key (car list1)))
+ (setf (cdr tail2) list1)
+ (return-from merge* (values list2 tail1 rest)))))
+ (values (merge-lists* head list1 list2 test key)
+ (if (null (cdr tail1))
+ tail1
+ tail2)
+ rest))
+ (recur (list size)
+ (declare (optimize speed)
+ (type cons list)
+ (type (and fixnum unsigned-byte) size))
+ (cond ((> size 3)
+ (let ((half (ash size -1)))
+ (multiple-value-bind (list1 tail1 rest)
+ (recur list half)
+ (multiple-value-bind (list2 tail2 rest)
+ (recur rest (- size half))
+ (merge* size list1 tail1 list2 tail2 rest)))))
+ ((= size 3)
+ (stable-sort-list-3 list test key))
+ ((= size 2)
+ (stable-sort-list-2 list test key))
+ (t ; (= size 1)
+ (values list list (shiftf (cdr list) nil))))))
+ (when list
+ (values (recur list (length list))))))
+\f
+;;;; stable sort of vectors
;;; Stable sorting vectors is done with the same algorithm used for
;;; lists, using a temporary vector to merge back and forth between it
;;; and merges them into a target vector starting at index start-1.
(sb!xc:defmacro stable-sort-merge-vectors* (source target start-1 end-1 end-2
- pred key source-ref
- target-ref)
+ pred key source-ref
+ target-ref)
(let ((i (gensym))
- (j (gensym))
- (target-i (gensym)))
+ (j (gensym))
+ (target-i (gensym)))
`(let ((,i ,start-1)
- (,j ,end-1) ; start-2
- (,target-i ,start-1))
+ (,j ,end-1) ; start-2
+ (,target-i ,start-1))
(declare (fixnum ,i ,j ,target-i))
(loop
- (cond ((= ,i ,end-1)
- (loop (if (= ,j ,end-2) (return))
- (setf (,target-ref ,target ,target-i)
- (,source-ref ,source ,j))
- (incf ,target-i)
- (incf ,j))
- (return))
- ((= ,j ,end-2)
- (loop (if (= ,i ,end-1) (return))
- (setf (,target-ref ,target ,target-i)
- (,source-ref ,source ,i))
- (incf ,target-i)
- (incf ,i))
- (return))
- ((apply-pred (,source-ref ,source ,j)
- (,source-ref ,source ,i)
- ,pred ,key)
- (setf (,target-ref ,target ,target-i)
- (,source-ref ,source ,j))
- (incf ,j))
- (t (setf (,target-ref ,target ,target-i)
- (,source-ref ,source ,i))
- (incf ,i)))
- (incf ,target-i)))))
-
-;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists, but
-;;; it uses a temporary vector. Direction determines whether we are merging
-;;; into the temporary (T) or back into the given vector (NIL).
+ (cond ((= ,i ,end-1)
+ (loop (if (= ,j ,end-2) (return))
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,j))
+ (incf ,target-i)
+ (incf ,j))
+ (return))
+ ((= ,j ,end-2)
+ (loop (if (= ,i ,end-1) (return))
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,i))
+ (incf ,target-i)
+ (incf ,i))
+ (return))
+ ((funcall2-using-key ,pred ,key
+ (,source-ref ,source ,j)
+ (,source-ref ,source ,i))
+ (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,j))
+ (incf ,j))
+ (t (setf (,target-ref ,target ,target-i)
+ (,source-ref ,source ,i))
+ (incf ,i)))
+ (incf ,target-i)))))
+;;; VECTOR-MERGE-SORT is the same algorithm used to stable sort lists,
+;;; but it uses a temporary vector. DIRECTION determines whether we
+;;; are merging into the temporary (T) or back into the given vector
+;;; (NIL).
(sb!xc:defmacro vector-merge-sort (vector pred key vector-ref)
- (let ((vector-len (gensym)) (n (gensym))
- (direction (gensym)) (unsorted (gensym))
- (start-1 (gensym)) (end-1 (gensym))
- (end-2 (gensym)) (temp-len (gensym))
- (i (gensym)))
- `(let ((,vector-len (length (the vector ,vector)))
- (,n 1) ; bottom-up size of contiguous runs to be merged
- (,direction t) ; t vector --> temp nil temp --> vector
- (,temp-len (length (the simple-vector *merge-sort-temp-vector*)))
- (,unsorted 0) ; unsorted..vector-len are the elements that need
- ; to be merged for a given n
- (,start-1 0)) ; one n-len subsequence to be merged with the next
- (declare (fixnum ,vector-len ,n ,temp-len ,unsorted ,start-1))
- (if (> ,vector-len ,temp-len)
- (setf *merge-sort-temp-vector*
- (make-array (max ,vector-len (+ ,temp-len ,temp-len)))))
+ (with-unique-names
+ (vector-len n direction unsorted start-1 end-1 end-2 temp i)
+ `(let* ((,vector-len (length (the vector ,vector)))
+ (,n 1) ; bottom-up size of contiguous runs to be merged
+ (,direction t) ; t vector --> temp nil temp --> vector
+ (,temp (make-array ,vector-len))
+ (,unsorted 0) ; unsorted..vector-len are the elements that need
+ ; to be merged for a given n
+ (,start-1 0)) ; one n-len subsequence to be merged with the next
+ (declare (fixnum ,vector-len ,n ,unsorted ,start-1)
+ (simple-vector ,temp))
(loop
- ;; for each n, we start taking n-runs from the start of the vector
- (setf ,unsorted 0)
- (loop
- (setf ,start-1 ,unsorted)
- (let ((,end-1 (+ ,start-1 ,n)))
- (declare (fixnum ,end-1))
- (cond ((< ,end-1 ,vector-len)
- ;; there are enough elements for a second run
- (let ((,end-2 (+ ,end-1 ,n)))
- (declare (fixnum ,end-2))
- (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
- (setf ,unsorted ,end-2)
- (if ,direction
- (stable-sort-merge-vectors*
- ,vector *merge-sort-temp-vector*
- ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
- (stable-sort-merge-vectors*
- *merge-sort-temp-vector* ,vector
- ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
- (if (= ,unsorted ,vector-len) (return))))
- ;; if there is only one run, copy those elements to the end
- (t (if ,direction
- (do ((,i ,start-1 (1+ ,i)))
- ((= ,i ,vector-len))
- (declare (fixnum ,i))
- (setf (svref *merge-sort-temp-vector* ,i)
- (,vector-ref ,vector ,i)))
- (do ((,i ,start-1 (1+ ,i)))
- ((= ,i ,vector-len))
- (declare (fixnum ,i))
- (setf (,vector-ref ,vector ,i)
- (svref *merge-sort-temp-vector* ,i))))
- (return)))))
- ;; If the inner loop only executed once, then there were only enough
- ;; elements for two subsequences given n, so all the elements have
- ;; been merged into one list. Start-1 will have remained 0 upon exit.
- (when (zerop ,start-1)
- (if ,direction
- ;; if we just merged into the temporary, copy it all back
- ;; to the given vector.
- (dotimes (,i ,vector-len)
- (setf (,vector-ref ,vector ,i)
- (svref *merge-sort-temp-vector* ,i))))
- (return ,vector))
- (setf ,n (ash ,n 1)) ; (* 2 n)
- (setf ,direction (not ,direction))))))
+ ;; for each n, we start taking n-runs from the start of the vector
+ (setf ,unsorted 0)
+ (loop
+ (setf ,start-1 ,unsorted)
+ (let ((,end-1 (+ ,start-1 ,n)))
+ (declare (fixnum ,end-1))
+ (cond ((< ,end-1 ,vector-len)
+ ;; there are enough elements for a second run
+ (let ((,end-2 (+ ,end-1 ,n)))
+ (declare (fixnum ,end-2))
+ (if (> ,end-2 ,vector-len) (setf ,end-2 ,vector-len))
+ (setf ,unsorted ,end-2)
+ (if ,direction
+ (stable-sort-merge-vectors*
+ ,vector ,temp
+ ,start-1 ,end-1 ,end-2 ,pred ,key ,vector-ref svref)
+ (stable-sort-merge-vectors*
+ ,temp ,vector
+ ,start-1 ,end-1 ,end-2 ,pred ,key svref ,vector-ref))
+ (if (= ,unsorted ,vector-len) (return))))
+ ;; if there is only one run, copy those elements to the end
+ (t (if ,direction
+ (do ((,i ,start-1 (1+ ,i)))
+ ((= ,i ,vector-len))
+ (declare (fixnum ,i))
+ (setf (svref ,temp ,i) (,vector-ref ,vector ,i)))
+ (do ((,i ,start-1 (1+ ,i)))
+ ((= ,i ,vector-len))
+ (declare (fixnum ,i))
+ (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
+ (return)))))
+ ;; If the inner loop only executed once, then there were only enough
+ ;; elements for two subsequences given n, so all the elements have
+ ;; been merged into one list. Start-1 will have remained 0 upon exit.
+ (when (zerop ,start-1)
+ (when ,direction
+ ;; if we just merged into the temporary, copy it all back
+ ;; to the given vector.
+ (dotimes (,i ,vector-len)
+ (setf (,vector-ref ,vector ,i) (svref ,temp ,i))))
+ ;; Kill the new vector to prevent garbage from being retained.
+ (%shrink-vector ,temp 0)
+ (return ,vector))
+ (setf ,n (ash ,n 1)) ; (* 2 n)
+ (setf ,direction (not ,direction))))))
) ; EVAL-when
-;;; Temporary vector for stable sorting vectors.
-(defvar *merge-sort-temp-vector*
- (make-array 50))
-
-(declaim (simple-vector *merge-sort-temp-vector*))
-
(defun stable-sort-simple-vector (vector pred key)
- (declare (simple-vector vector))
+ (declare (type simple-vector vector)
+ (type function pred)
+ (type (or null function) key))
(vector-merge-sort vector pred key svref))
(defun stable-sort-vector (vector pred key)
+ (declare (type function pred)
+ (type (or null function) key))
(vector-merge-sort vector pred key aref))
-
+\f
;;;; merging
(eval-when (:compile-toplevel :execute)
;;; MERGE-VECTORS returns a new vector which contains an interleaving
-;;; of the elements of vector-1 and vector-2. Elements from vector-2 are
-;;; chosen only if they are strictly less than elements of vector-1,
-;;; (pred elt-2 elt-1), as specified in the manual.
-
+;;; of the elements of VECTOR-1 and VECTOR-2. Elements from VECTOR-2
+;;; are chosen only if they are strictly less than elements of
+;;; VECTOR-1, (PRED ELT-2 ELT-1), as specified in the manual.
(sb!xc:defmacro merge-vectors (vector-1 length-1 vector-2 length-2
- result-vector pred key access)
+ result-vector pred key access)
(let ((result-i (gensym))
- (i (gensym))
- (j (gensym)))
+ (i (gensym))
+ (j (gensym)))
`(let* ((,result-i 0)
- (,i 0)
- (,j 0))
+ (,i 0)
+ (,j 0))
(declare (fixnum ,result-i ,i ,j))
(loop
- (cond ((= ,i ,length-1)
- (loop (if (= ,j ,length-2) (return))
- (setf (,access ,result-vector ,result-i)
- (,access ,vector-2 ,j))
- (incf ,result-i)
- (incf ,j))
- (return ,result-vector))
- ((= ,j ,length-2)
- (loop (if (= ,i ,length-1) (return))
- (setf (,access ,result-vector ,result-i)
- (,access ,vector-1 ,i))
- (incf ,result-i)
- (incf ,i))
- (return ,result-vector))
- ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
- ,pred ,key)
- (setf (,access ,result-vector ,result-i)
- (,access ,vector-2 ,j))
- (incf ,j))
- (t (setf (,access ,result-vector ,result-i)
- (,access ,vector-1 ,i))
- (incf ,i)))
- (incf ,result-i)))))
+ (cond ((= ,i ,length-1)
+ (loop (if (= ,j ,length-2) (return))
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-2 ,j))
+ (incf ,result-i)
+ (incf ,j))
+ (return ,result-vector))
+ ((= ,j ,length-2)
+ (loop (if (= ,i ,length-1) (return))
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-1 ,i))
+ (incf ,result-i)
+ (incf ,i))
+ (return ,result-vector))
+ ((funcall2-using-key ,pred ,key
+ (,access ,vector-2 ,j) (,access ,vector-1 ,i))
+ (setf (,access ,result-vector ,result-i)
+ (,access ,vector-2 ,j))
+ (incf ,j))
+ (t (setf (,access ,result-vector ,result-i)
+ (,access ,vector-1 ,i))
+ (incf ,i)))
+ (incf ,result-i)))))
) ; EVAL-WHEN
(defun merge (result-type sequence1 sequence2 predicate &key key)
#!+sb-doc
- "The sequences Sequence1 and Sequence2 are destructively merged into
- a sequence of type Result-Type using the Predicate to order the elements."
- (if (eq result-type 'list)
- (let ((result (merge-lists* (coerce sequence1 'list)
- (coerce sequence2 'list)
- predicate key)))
- result)
- (let* ((vector-1 (coerce sequence1 'vector))
- (vector-2 (coerce sequence2 'vector))
- (length-1 (length vector-1))
- (length-2 (length vector-2))
- (result (make-sequence-of-type result-type (+ length-1 length-2))))
- (declare (vector vector-1 vector-2)
- (fixnum length-1 length-2))
-
- #!+high-security
- (check-type-var result result-type)
- (if (and (simple-vector-p result)
- (simple-vector-p vector-1)
- (simple-vector-p vector-2))
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key svref)
- (merge-vectors vector-1 length-1 vector-2 length-2
- result predicate key aref)))))
+ "Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
+ sequence of type RESULT-TYPE using PREDICATE to order the elements."
+ ;; FIXME: This implementation is remarkably inefficient in various
+ ;; ways. In decreasing order of estimated user astonishment, I note:
+ ;; full calls to SPECIFIER-TYPE at runtime; copying input vectors
+ ;; to lists before doing MERGE-LISTS -- WHN 2003-01-05
+ (let ((type (specifier-type result-type)))
+ (cond
+ ((csubtypep type (specifier-type 'list))
+ ;; the VECTOR clause, below, goes through MAKE-SEQUENCE, so
+ ;; benefits from the error checking there. Short of
+ ;; reimplementing everything, we can't do the same for the LIST
+ ;; case, so do relevant length checking here:
+ (let ((s1 (coerce sequence1 'list))
+ (s2 (coerce sequence2 'list))
+ (pred-fun (%coerce-callable-to-fun predicate))
+ (key-fun (if key
+ (%coerce-callable-to-fun key)
+ #'identity)))
+ (when (type= type (specifier-type 'list))
+ (return-from merge (merge-lists s1 s2 pred-fun key-fun)))
+ (when (eq type *empty-type*)
+ (bad-sequence-type-error nil))
+ (when (type= type (specifier-type 'null))
+ (if (and (null s1) (null s2))
+ (return-from merge 'nil)
+ ;; FIXME: This will break on circular lists (as,
+ ;; indeed, will the whole MERGE function).
+ (sequence-type-length-mismatch-error type
+ (+ (length s1)
+ (length s2)))))
+ (if (cons-type-p type)
+ (multiple-value-bind (min exactp)
+ (sb!kernel::cons-type-length-info type)
+ (let ((length (+ (length s1) (length s2))))
+ (if exactp
+ (unless (= length min)
+ (sequence-type-length-mismatch-error type length))
+ (unless (>= length min)
+ (sequence-type-length-mismatch-error type length)))
+ (merge-lists s1 s2 pred-fun key-fun)))
+ (sequence-type-too-hairy result-type))))
+ ((csubtypep type (specifier-type 'vector))
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (result (make-sequence result-type (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2)
+ (fixnum length-1 length-2))
+ (if (and (simple-vector-p result)
+ (simple-vector-p vector-1)
+ (simple-vector-p vector-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key svref)
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ result predicate key aref))))
+ ((and (csubtypep type (specifier-type 'sequence))
+ (find-class result-type nil))
+ (let* ((vector-1 (coerce sequence1 'vector))
+ (vector-2 (coerce sequence2 'vector))
+ (length-1 (length vector-1))
+ (length-2 (length vector-2))
+ (temp (make-array (+ length-1 length-2)))
+ (result (make-sequence result-type (+ length-1 length-2))))
+ (declare (vector vector-1 vector-2) (fixnum length-1 length-2))
+ (merge-vectors vector-1 length-1 vector-2 length-2
+ temp predicate key aref)
+ (replace result temp)
+ result))
+ (t (bad-sequence-type-error result-type)))))
projects / sbcl.git / blobdiff