X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcode%2Fsort.lisp;h=076a9b9e3f65c71b605786d0abe74164583ccaee;hb=95591ed483dbb8c0846c129953acac1554f28809;hp=1c2198617344fa0baa25a67b4a1fede355f84357;hpb=4898ef32c639b1c7f4ee13a5ba566ce6debd03e6;p=sbcl.git diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 1c21986..076a9b9 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -19,60 +19,48 @@ ;;; 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 &key key) +(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))) - (typecase sequence - (list - (stable-sort-list sequence - predicate-fun - (if key (%coerce-callable-to-fun key) #'identity))) - (vector - (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 - :datum sequence - :expected-type 'sequence - :format-control "~S is not a sequence." - :format-arguments (list sequence)))))) + (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)))) ;;;; stable sorting - -(defun stable-sort (sequence predicate &key key) +(defun stable-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))) - (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. + (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)))) + +;;; FUNCALL-USING-KEY saves us a function call sometimes. (eval-when (:compile-toplevel :execute) - (sb!xc:defmacro apply-keyed-pred (one two pred key) + (sb!xc:defmacro funcall2-using-key (pred key one two) `(if ,key (funcall ,pred (funcall ,key ,one) (funcall ,key ,two)) @@ -222,9 +210,9 @@ (incf ,target-i) (incf ,i)) (return)) - ((apply-keyed-pred (,source-ref ,source ,j) - (,source-ref ,source ,i) - ,pred ,key) + ((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)) @@ -238,78 +226,77 @@ ;;; 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))))) - (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)))))) + (with-unique-names + (vector-len n direction unsorted start-1 end-1 end-2 temp temp-len 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 *merge-sort-temp-vector*) + (,temp-len (length ,temp)) + (,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) + (simple-vector ,temp)) + (when (> ,vector-len ,temp-len) + (setf ,temp (make-array (max ,vector-len + (min (truncate array-dimension-limit 2) + (logand most-positive-fixnum (+ ,temp-len ,temp-len))))) + *merge-sort-temp-vector* ,temp)) + ;; Rebind, in case PRED or KEY calls STABLE-SORT. This is also + ;; interrupt safe: we bind before we put any data of our own in + ;; the temp vector. + (let ((*merge-sort-temp-vector* (vector))) + (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 ,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) + (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 ,temp ,i)))) + (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 (type simple-vector vector) (type function pred) @@ -353,8 +340,8 @@ (incf ,result-i) (incf ,i)) (return ,result-vector)) - ((apply-keyed-pred (,access ,vector-2 ,j) (,access ,vector-1 ,i) - ,pred ,key) + ((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)) @@ -418,8 +405,7 @@ (vector-2 (coerce sequence2 'vector)) (length-1 (length vector-1)) (length-2 (length vector-2)) - (result (make-sequence result-type - (+ length-1 length-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) @@ -429,4 +415,17 @@ 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)))))