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