contrib/code-extras.lisp

   1 ;;;; (See the comments at the head of the file compiler-extras.lisp.)
   2
   3 (in-package "SB-IMPL")
   4
   5 (declaim (optimize (speed 3) (space 1)))
   6
   7 (defun %with-array-data (array start end)
   8   (%with-array-data-macro array start end :fail-inline? t))
   9
  10 ;;; Like CMU CL, we use HEAPSORT. However, instead of trying to
  11 ;;; generalize the CMU CL code to allow START and END values, this
  12 ;;; code has been written from scratch following Chapter 7 of
  13 ;;; _Introduction to Algorithms_ by Corman, Rivest, and Shamir.
  14 (macrolet ((%index (x) `(truly-the index ,x))
  15            (%parent (i) `(ash ,i -1))
  16            (%left (i) `(%index (ash ,i 1)))
  17            (%right (i) `(%index (1+ (ash ,i 1))))
  18            (%heapify (i)
  19              `(do* ((i ,i)
  20                     (left (%left i) (%left i)))
  21                   ((> left current-heap-size))
  22                 (declare (type index i left))
  23                 (let* ((i-elt (%elt i))
  24                        (i-key (funcall keyfun i-elt))
  25                        (left-elt (%elt left))
  26                        (left-key (funcall keyfun left-elt)))
  27                   (multiple-value-bind (large large-elt large-key)
  28                       (if (funcall predicate i-key left-key)
  29                           (values left left-elt left-key)
  30                           (values i i-elt i-key))
  31                     (let ((right (%right i)))
  32                       (multiple-value-bind (largest largest-elt)
  33                           (if (> right current-heap-size)
  34                               (values large large-elt)
  35                               (let* ((right-elt (%elt right))
  36                                      (right-key (funcall keyfun right-elt)))
  37                                 (if (funcall predicate large-key right-key)
  38                                     (values right right-elt)
  39                                     (values large large-elt))))
  40                         (cond ((= largest i)
  41                                (return))
  42                               (t
  43                                (setf (%elt i) largest-elt
  44                                      (%elt largest) i-elt
  45                                      i largest)))))))))
  46            (%srt-vector (keyfun &optional (vtype 'vector))
  47              `(macrolet (;; In SBCL ca. 0.6.10, I had trouble getting
  48                          ;; type inference to propagate all the way
  49                          ;; through this tangled mess of inlining. The
  50                          ;; TRULY-THE here works around that. -- WHN
  51                          (%elt (i)
  52                            `(aref (truly-the ,',vtype vector)
  53                                   (%index (+ (%index ,i) start-1)))))
  54                 (let ((start-1 (1- start)) ; Heaps prefer 1-based addressing.
  55                       (current-heap-size (- end start))
  56                       (keyfun ,keyfun))
  57                   (declare (type (integer -1 #.(1- most-positive-fixnum))
  58                                  start-1))
  59                   (declare (type index current-heap-size))
  60                   (declare (type function keyfun))
  61                   (/noshow "doing SRT-VECTOR" keyfun)
  62                   (loop for i of-type index
  63                         from (ash current-heap-size -1) downto 1 do
  64                         (/noshow vector "about to %HEAPIFY" i)
  65                         (%heapify i))
  66                   (loop
  67                    (/noshow current-heap-size vector)
  68                    (when (< current-heap-size 2)
  69                      (/noshow "returning")
  70                      (return))
  71                    (/noshow "setting" current-heap-size "element to" (%elt 1))
  72                    (rotatef (%elt 1) (%elt current-heap-size))
  73                    (decf current-heap-size)
  74                    (%heapify 1))
  75                   (/noshow "falling out of %SRT-VECTOR")))))
  76
  77   (declaim (inline srt-vector))
  78   (defun srt-vector (vector start end predicate key)
  79     (declare (type vector vector))
  80     (declare (type index start end))
  81     (declare (type function predicate))
  82     (declare (type (or function null) key))
  83     (declare (optimize (speed 3) (safety 3) (debug 1) (space 1)))
  84     (if (typep vector 'simple-vector)
  85         ;; (VECTOR T) is worth optimizing for, and SIMPLE-VECTOR is
  86         ;; what we get from (VECTOR T) inside WITH-ARRAY-DATA.
  87         (if (null key)
  88             ;; Special-casing the KEY=NIL case lets us avoid some
  89             ;; function calls.
  90             (%srt-vector #'identity simple-vector)
  91             (%srt-vector key simple-vector))
  92         ;; It's hard to imagine many important applications for
  93         ;; sorting vector types other than (VECTOR T), so we just lump
  94         ;; them all together in one slow dynamically typed mess.
  95         (locally
  96           (declare (optimize (speed 2) (space 2) (inhibit-warnings 3)))
  97           (error "stub: suppressed to hide notes")
  98           #+nil (%srt-vector (or key #'identity))))))
  99
 100 (declaim (maybe-inline sort))
 101 (defun sort (sequence predicate &key key)
 102   (let ((predicate-function (%coerce-callable-to-function predicate))
 103         (key-function (and key (%coerce-callable-to-function key))))
 104     (typecase sequence
 105       (list (sort-list sequence predicate-function key-function))
 106       (vector
 107        (with-array-data ((vector (the vector sequence))
 108                          (start 0)
 109                          (end (length sequence)))
 110          (srt-vector vector start end predicate-function key-function))
 111        (/noshow "back from SRT-VECTOR" sequence)
 112        sequence)
 113       (t
 114        (error 'simple-type-error
 115               :datum sequence
 116               :expected-type 'sequence
 117               :format-control "~S is not a sequence."
 118               :format-arguments (list sequence))))))
 119
 120 (defun vector-push-extend (new-element
 121                            vector
 122                            &optional
 123                            (extension nil extension-p))
 124   (declare (type vector vector))
 125   (let ((old-fill-pointer (fill-pointer vector)))
 126     (declare (type index old-fill-pointer))
 127     (when (= old-fill-pointer (%array-available-elements vector))
 128       (adjust-array vector (+ old-fill-pointer
 129                               (if extension-p
 130                                   (the (integer 1 #.most-positive-fixnum)
 131                                     extension)
 132                                   (1+ old-fill-pointer)))))
 133     (setf (%array-fill-pointer vector)
 134           (1+ old-fill-pointer))
 135     ;; Wrapping the type test and the AREF in the same WITH-ARRAY-DATA
 136     ;; saves some time.
 137     (with-array-data ((v vector) (i old-fill-pointer) (end)
 138                       :force-inline t)
 139       (declare (ignore end) (optimize (safety 0)))
 140       (if (simple-vector-p v) ; if common special case
 141           (setf (aref v i) new-element)
 142           (setf (aref v i) new-element)))
 143     old-fill-pointer))
 144
 145 ;;; FIXME: should DEFUN REPLACE in terms of same expansion as
 146 ;;; DEFTRANSFORM
 147 #+nil
 148 (defun replace (..)
 149   (cond ((and (typep seq1 'simple-vector)
 150               (typep seq2 'simple-vector))
 151          (%replace-vector-vector ..))
 152         ((and (typep seq1 'simple-string)
 153               (typep seq2 'simple-string))
 154          (%replace-vector-vector ..))
 155         (t
 156          ..)))
 157
 158 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 159 ;;;; POSITION/FIND stuff
 160
 161 #+sb-xc-host
 162 (eval-when (:compile-toplevel :load-toplevel :execute)
 163   ;; FIXME: Report seq.impure.lisp test failures to cmucl-imp@cons.org.
 164   ;; FIXME: Add BUGS entry for the way that inline expansions offunctions
 165   ;; like FIND cause compiler warnings when the system can't prove that
 166   ;; NIL is never returned; and give (NEED (FIND ..)) workaround.
 167   (error "need to fix FIXMEs"))
 168
 169 ;;; logic to unravel :TEST, :TEST-NOT, and :KEY options in FIND,
 170 ;;; POSITION-IF, etc.
 171 (declaim (inline effective-find-position-test effective-find-position-key))
 172 (defun effective-find-position-test (test test-not)
 173   (cond ((and test test-not)
 174          (error "can't specify both :TEST and :TEST-NOT"))
 175         (test (%coerce-callable-to-function test))
 176         (test-not
 177          ;; (Without DYNAMIC-EXTENT, this is potentially horribly
 178          ;; inefficient, but since the TEST-NOT option is deprecated
 179          ;; anyway, we don't care.)
 180          (complement (%coerce-callable-to-function test-not)))
 181         (t #'eql)))
 182 (defun effective-find-position-key (key)
 183   (if key
 184       (%coerce-callable-to-function key)
 185       #'identity))
 186
 187 ;;; shared guts of out-of-line FIND, POSITION, FIND-IF, and POSITION-IF
 188 (macrolet (;; shared logic for defining %FIND-POSITION and
 189            ;; %FIND-POSITION-IF in terms of various inlineable cases
 190            ;; of the expression defined in FROB and VECTOR*-FROB
 191            (frobs ()
 192              `(etypecase sequence-arg
 193                 (list (frob sequence-arg from-end))
 194                 (vector
 195                  (with-array-data ((sequence sequence-arg :offset-var offset)
 196                                    (start start)
 197                                    (end (or end (length sequence-arg))))
 198                    (multiple-value-bind (f p)
 199                        (macrolet ((frob2 () '(if from-end
 200                                                  (frob sequence t)
 201                                                  (frob sequence nil))))
 202                          (typecase sequence
 203                            (simple-vector (frob2))
 204                            (simple-string (frob2))
 205                            (t (vector*-frob sequence))))
 206                      (declare (type (or index null) p))
 207                      (values f (and p (the index (+ p offset))))))))))
 208   (defun %find-position (item sequence-arg from-end start end key test)
 209     (macrolet ((frob (sequence from-end)
 210                  `(%find-position item ,sequence
 211                                   ,from-end start end key test))
 212                (vector*-frob (sequence)
 213                  `(%find-position-vector-macro item ,sequence
 214                                                from-end start end key test)))
 215       (frobs)))
 216   (defun %find-position-if (predicate sequence-arg from-end start end key)
 217     (macrolet ((frob (sequence from-end)
 218                  `(%find-position-if predicate ,sequence
 219                                      ,from-end start end key))
 220                (vector*-frob (sequence)
 221                  `(%find-position-if-vector-macro predicate ,sequence
 222                                                   from-end start end key)))
 223       (frobs))))
 224
 225 ;;; the user interface to FIND and POSITION: Get all our ducks in a row,
 226 ;;; then call %FIND-POSITION
 227 (declaim (inline find position))
 228 (macrolet ((def-find-position (fun-name values-index)
 229              `(defun ,fun-name (item
 230                                 sequence
 231                                 &key
 232                                 from-end
 233                                 (start 0)
 234                                 end
 235                                 key
 236                                 test
 237                                 test-not)
 238                 (nth-value
 239                  ,values-index
 240                  (%find-position item
 241                                  sequence
 242                                  from-end
 243                                  start
 244                                  end
 245                                  (effective-find-position-key key)
 246                                  (effective-find-position-test test
 247                                                                test-not))))))
 248   (def-find-position find 0)
 249   (def-find-position position 1))
 250
 251 ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous
 252 ;;; to the interface to FIND and POSITION
 253 (declaim (inline find-if position-if))
 254 (macrolet ((def-find-position-if (fun-name values-index)
 255              `(defun ,fun-name (predicate sequence
 256                                 &key from-end (start 0) end key)
 257                 (nth-value
 258                  ,values-index
 259                  (%find-position-if (%coerce-callable-to-function predicate)
 260                                     sequence
 261                                     from-end
 262                                     start
 263                                     end
 264                                     (effective-find-position-key key))))))
 265
 266   (def-find-position-if find-if 0)
 267   (def-find-position-if position-if 1))
 268
 269 ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT
 270 (macrolet ((def-find-position-if-not (fun-name values-index)
 271              `(defun ,fun-name (predicate sequence
 272                                 &key from-end (start 0) end key)
 273                 (nth-value
 274                  ,values-index
 275                  (%find-position-if (complement (%coerce-callable-to-function
 276                                                  predicate))
 277                                     sequence
 278                                     from-end
 279                                     start
 280                                     end
 281                                     (effective-find-position-key key))))))
 282   (def-find-position-if-not find-if-not 0)
 283   (def-find-position-if-not position-if-not 1))
 284 ;;; FIXME: Remove uses of these deprecated functions, and of :TEST-NOT too.
 285