;;; 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))))))
- ;; FIXME: Oh dear.
- (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 key)
+ (sort-vector vector start end predicate key))
;;; This is MAYBE-INLINE because it's not too hard to have an
;;; application where sorting is a major bottleneck, and inlining it
projects / sbcl.git / blobdiff