X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsort.lisp;h=636c417594cb323b1b3cf977221374847fca961a;hb=bfe145acc01eb7a43790173db4f08610ae9cb07a;hp=d1337f3ee9eaabca194eb91fa4c3c0f4dff3a30a;hpb=09d7974601df2aaaa820ca576026b9b4f03e6ab1;p=sbcl.git diff --git a/src/code/sort.lisp b/src/code/sort.lisp index d1337f3..636c417 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -11,13 +11,8 @@ (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. -(defun sort-vector (vector start end predicate key) - (sort-vector vector start end predicate key)) +(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 @@ -28,15 +23,18 @@ #!+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 @@ -49,46 +47,110 @@ (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)))))) + +;;; 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 + +;;;; 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)) @@ -97,21 +159,21 @@ (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) @@ -121,46 +183,8 @@ ;; 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 be 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 + +;;;; 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 @@ -198,9 +222,9 @@ (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)) @@ -287,12 +311,16 @@ (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)) - + ;;;; merging (eval-when (:compile-toplevel :execute) @@ -325,8 +353,8 @@ (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)) @@ -341,6 +369,14 @@ #!+sb-doc "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*; 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)) @@ -349,9 +385,13 @@ ;; 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))) + (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 predicate key)))) + (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)) @@ -362,10 +402,16 @@ (sequence-type-length-mismatch-error type (+ (length s1) (length s2))))) - (if (csubtypep (specifier-type '(cons nil t)) type) - (if (and (null s1) (null s2)) - (sequence-type-length-mismatch-error type 0) - (values (merge-lists* s1 s2 predicate key))) + (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))