(in-package "SB!IMPL")
-;;; Like CMU CL, we use HEAPSORT. However, other than that, this code
-;;; isn't really related to the CMU CL code, since instead of trying
-;;; to generalize the CMU CL code to allow START and END values, this
-;;; code has been written from scratch following Chapter 7 of
-;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
-(macrolet ((%index (x) `(truly-the index ,x))
- (%parent (i) `(ash ,i -1))
- (%left (i) `(%index (ash ,i 1)))
- (%right (i) `(%index (1+ (ash ,i 1))))
- (%heapify (i)
- `(do* ((i ,i)
- (left (%left i) (%left i)))
- ((> left current-heap-size))
- (declare (type index i left))
- (let* ((i-elt (%elt i))
- (i-key (funcall keyfun i-elt))
- (left-elt (%elt left))
- (left-key (funcall keyfun left-elt)))
- (multiple-value-bind (large large-elt large-key)
- (if (funcall predicate i-key left-key)
- (values left left-elt left-key)
- (values i i-elt i-key))
- (let ((right (%right i)))
- (multiple-value-bind (largest largest-elt)
- (if (> right current-heap-size)
- (values large large-elt)
- (let* ((right-elt (%elt right))
- (right-key (funcall keyfun right-elt)))
- (if (funcall predicate large-key right-key)
- (values right right-elt)
- (values large large-elt))))
- (cond ((= largest i)
- (return))
- (t
- (setf (%elt i) largest-elt
- (%elt largest) i-elt
- i largest)))))))))
- (%sort-vector (keyfun &optional (vtype 'vector))
- `(macrolet (;; KLUDGE: In SBCL ca. 0.6.10, I had trouble getting
- ;; type inference to propagate all the way
- ;; through this tangled mess of inlining. The
- ;; TRULY-THE here works around that. -- WHN
- (%elt (i)
- `(aref (truly-the ,',vtype vector)
- (%index (+ (%index ,i) start-1)))))
- (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
- (current-heap-size (- end start))
- (keyfun ,keyfun))
- (declare (type (integer -1 #.(1- most-positive-fixnum))
- start-1))
- (declare (type index current-heap-size))
- (declare (type function keyfun))
- (loop for i of-type index
- from (ash current-heap-size -1) downto 1 do
- (%heapify i))
- (loop
- (when (< current-heap-size 2)
- (return))
- (rotatef (%elt 1) (%elt current-heap-size))
- (decf current-heap-size)
- (%heapify 1))))))
-
- (declaim (inline sort-vector))
- (defun sort-vector (vector start end predicate key)
- (declare (type vector vector))
- (declare (type index start end))
- (declare (type function predicate))
- (declare (type (or function null) key))
- ;; This used to be (OPTIMIZE (SPEED 3) (SAFETY 3)), but now
- ;; (0.7.1.39) that (SAFETY 3) means "absolutely safe (including
- ;; expensive things like %DETECT-STACK-EXHAUSTION)" we get closer
- ;; to what we want by using (SPEED 2) (SAFETY 2): "pretty fast,
- ;; pretty safe, and safety is no more important than speed".
- (declare (optimize (speed 2) (safety 2) (debug 1) (space 1)))
- (if (typep vector 'simple-vector)
- ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
- ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
- (if (null key)
- ;; Special-casing the KEY=NIL case lets us avoid some
- ;; function calls.
- (%sort-vector #'identity simple-vector)
- (%sort-vector key simple-vector))
- ;; It's hard to anticipate many speed-critical applications for
- ;; sorting vector types other than (VECTOR T), so we just lump
- ;; them all together in one slow dynamically typed mess.
- (locally
- (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
- (%sort-vector (or key #'identity))))))
+(defun sort-vector (vector start end predicate-fun key-fun-or-nil)
+ (sort-vector vector start end predicate-fun key-fun-or-nil))
;;; This is MAYBE-INLINE because it's not too hard to have an
;;; application where sorting is a major bottleneck, and inlining it
#!+sb-doc
"Destructively sort SEQUENCE. PREDICATE should return non-NIL if
ARG1 is to precede ARG2."
- (let ((predicate-function (%coerce-callable-to-fun predicate))
- (key-function (and key (%coerce-callable-to-fun key))))
+ (let ((predicate-fun (%coerce-callable-to-fun predicate)))
(typecase sequence
- (list (sort-list sequence predicate-function key-function))
+ (list
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity)))
(vector
- (with-array-data ((vector (the vector sequence))
- (start 0)
- (end (length sequence)))
- (sort-vector vector start end predicate-function key-function))
+ (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)
(t
(error 'simple-type-error
(defun stable-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
- (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."
+ (let ((predicate-fun (%coerce-callable-to-fun predicate)))
+ (typecase sequence
+ (simple-vector
+ (stable-sort-simple-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (list
+ (stable-sort-list sequence
+ predicate-fun
+ (if key (%coerce-callable-to-fun key) #'identity)))
+ (vector
+ (stable-sort-vector sequence
+ predicate-fun
+ (and key (%coerce-callable-to-fun key))))
+ (t
+ (error 'simple-type-error
+ :datum sequence
+ :expected-type 'sequence
+ :format-control "~S is not a sequence."
+ :format-arguments (list sequence))))))
+ \f
+;;; APPLY-KEYED-PRED saves us a function call sometimes.
+(eval-when (:compile-toplevel :execute)
+ (sb!xc:defmacro apply-keyed-pred (one two pred key)
+ `(if ,key
+ (funcall ,pred (funcall ,key ,one)
+ (funcall ,key ,two))
+ (funcall ,pred ,one ,two)))
+) ; EVAL-WHEN
+\f
+;;;; stable sort of lists
+
+(defun last-cons-of (list)
+ (loop (let ((rest (rest list)))
+ (if rest
+ (setf list rest)
+ (return 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.
+;;;
+;;; Return (VALUES HEAD TAILTAIL), where HEAD is the same value you'd
+;;; expect from MERGE, and TAILTAIL is the last cons in the list (i.e.
+;;; the last cons in the list which NRECONC calls TAIL).
+(defun merge-lists* (list-1 list-2 pred-fun key-fun)
+ (declare (type list list-1 list-2))
+ (declare (type function pred-fun key-fun))
+ (cond ((null list-1) (values list-2 (last-cons-of list-2)))
+ ((null list-2) (values list-1 (last-cons-of list-1)))
+ (t (let* ((reversed-result-so-far nil)
+ (key-1 (funcall key-fun (car list-1)))
+ (key-2 (funcall key-fun (car list-2))))
+ (loop
+ (macrolet ((frob (list-i key-i other-list)
+ `(progn
+ ;; basically
+ ;; (PUSH (POP ,LIST-I) REVERSED-RESULT-SO-FAR),
+ ;; except doing some fancy footwork to
+ ;; reuse the cons cell:
+ (psetf (cdr ,list-i) reversed-result-so-far
+ reversed-result-so-far ,list-i
+ ,list-i (cdr ,list-i))
+ ;; Now maybe we're done.
+ (if (endp ,list-i)
+ (return (values (nreconc
+ reversed-result-so-far
+ ,other-list)
+ (last-cons-of
+ ,other-list)))
+ (setf ,key-i
+ (funcall key-fun (car ,list-i)))))))
+ ;; Note that by making KEY-2 the first arg to
+ ;; PRED-FUN, we arrange that if PRED-FUN is a function
+ ;; in the #'< style, the outcome is stably sorted.
+ (if (funcall pred-fun key-2 key-1)
+ (frob list-2 key-2 list-1)
+ (frob list-1 key-1 list-2))))))))
-;;; 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
+;;; STABLE-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 to 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.
-
-(defun sort-list (list pred key)
+(defun stable-sort-list (list pred-fun key-fun)
(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))
+ (declare (type function pred-fun key-fun)
+ (type fixnum n))
(loop
- ;; start collecting runs of n at the first element
+ ;; 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
+ ;; 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))
(let ((temp (nthcdr n-1 list-1))
list-2)
(cond (temp
- ;; there are enough elements for a second run
+ ;; 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
+ ;; 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))
+ (merge-lists* list-1 list-2 pred-fun key-fun)
+ (setf (cdr last) merged-head
+ last merged-last))
(if (null unsorted) (return)))
- ;; if there is only one run, then tack it on to the end
+ ;; 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)
;; iteration to realize.
(if (eq list-1 (cdr head))
(return list-1))))))
-
-;;; 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
-
-(defvar *merge-lists-header* (list :header))
-
-;;; 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)))))
-
-;;; stable sort of vectors
+\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
(incf ,target-i)
(incf ,i))
(return))
- ((apply-pred (,source-ref ,source ,j)
- (,source-ref ,source ,i)
- ,pred ,key)
+ ((apply-keyed-pred (,source-ref ,source ,j)
+ (,source-ref ,source ,i)
+ ,pred ,key)
(setf (,target-ref ,target ,target-i)
(,source-ref ,source ,j))
(incf ,j))
(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)
(incf ,result-i)
(incf ,i))
(return ,result-vector))
- ((apply-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
- ,pred ,key)
+ ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i)
+ ,pred ,key)
(setf (,access ,result-vector ,result-i)
(,access ,vector-2 ,j))
(incf ,j))
#!+sb-doc
"Merge the sequences SEQUENCE1 and SEQUENCE2 destructively into a
sequence of type RESULT-TYPE using 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 (aver (typep 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)))))
+ ;; 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*; and walking input lists
+ ;; (because of the call to MERGE-LISTS*, which walks the list to
+ ;; find the last element for its second return value) even in cases
+ ;; like (MERGE 'LIST (LIST 1) (LIST 2 3 4 5 ... 1000)) where one list
+ ;; can be largely ignored. -- 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 (values (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)))
+ (values (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))))
+ (t (bad-sequence-type-error result-type)))))
projects / sbcl.git / blobdiff