contrib/compiler-extras.lisp

   1 ;;;; The files
   2 ;;;;   compiler-extras.lisp
   3 ;;;;   code-extras.lisp
   4 ;;;; hold things that I (WHN) am working on which are sufficiently
   5 ;;;; closely tied to the system that they want to be under the same
   6 ;;;; revision control, but which aren't yet ready for prime time.
   7 ;;;;
   8 ;;;; As of around sbcl-0.6.10, these are mostly performance fixes.
   9 ;;;; Fixes for logical bugs tend to go straight into the system, but
  10 ;;;; fixes for performance problems can easily introduce logical bugs,
  11 ;;;; and no one's going to thank me for replacing old slow correct
  12 ;;;; code with new fast wrong code.
  13 ;;;;
  14 ;;;; Unless you want to live *very* dangerously, you don't want to be
  15 ;;;; running these. There might be some small value to looking at
  16 ;;;; these files to see whether I'm working on optimizing something
  17 ;;;; whose performance you care about, so that you can patch it, or
  18 ;;;; write test cases for it, or pester me to release it, or whatever.
  19
  20 (in-package "SB-KERNEL")
  21 (eval-when (:compile-toplevel :load-toplevel :execute)
  22   (export '(index-or-minus-1
  23             %find-position %find-position-vector-macro
  24             %find-position-if %find-position-if-vector-macro)))
  25
  26 (in-package "SB-C")
  27
  28 (deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum)))
  29
  30 (declaim (optimize (speed 1) (space 2)))
  31
  32 (deftransform fill ((seq item &key (start 0) (end (length seq)))
  33                     (vector t &key (:start t) (:end index))
  34                     *
  35                     :policy (> speed space))
  36   "open code"
  37   (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
  38     `(with-array-data ((data seq)
  39                        (start start)
  40                        (end end))
  41        (declare (type (simple-array ,element-type 1) data))
  42        (do ((i start (1+ i)))
  43            ((= i end) seq)
  44          (declare (type index i))
  45          ;; WITH-ARRAY-DATA does our range checks once and for all, so
  46          ;; it'd be wasteful to check again on every AREF.
  47          (declare (optimize (safety 0)))
  48          (setf (aref data i) item)))))
  49 ;;; TO DO for DEFTRANSFORM FILL:
  50 ;;;   ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
  51 ;;;      apply when SPEED > SPACE.
  52 ;;;   ?? Add test cases.
  53
  54 #+nil ; not tested yet..
  55 (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
  56                        (vector vector &key
  57                                (:start1 index) (:end1 (or index null))
  58                                (:start2 index) (:end2 (or index null)))
  59                        *
  60                        ;; This is potentially an awfully big transform
  61                        ;; (if things like (EQ SEQ1 SEQ2) aren't known
  62                        ;; at runtime). We need to make it available
  63                        ;; inline, since otherwise there's no way to do
  64                        ;; it efficiently on all array types, but it
  65                        ;; probably doesn't belong inline all the time.
  66                        :policy (> speed (1+ space)))
  67   "open code"
  68   (let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
  69         (et2 (upgraded-element-type-specifier-or-give-up seq2)))
  70     `(let* ((n-copied (min (- end1 start1) (- end2 start2)))
  71             (effective-end1 (+ start1 n-copied)))
  72        (if (eq seq1 seq2)
  73            (with-array-data ((seq seq1)
  74                              (start (min start1 start2))
  75                              (end (max end1 end2)))
  76              (declare (type (simple-array ,et1 1) seq))
  77              (if (<= start1 start2)
  78                  (let ((index2 start2))
  79                    (declare (type index index2))
  80                    (loop for index1 of-type index
  81                          from start1 below effective-end1 do
  82                          (setf (aref seq index1)
  83                                (aref seq index2))
  84                          (incf index2)))
  85                  (let ((index2 (1- end2)))
  86                    (declare (type (integer -2 #.most-positive-fixnum) index2))
  87                    (loop for index1 of-type index-or-minus-1
  88                          from (1- effective-end1) downto start1 do
  89                          (setf (aref seq index1)
  90                                (aref seq index2))
  91                          (decf index2)))))
  92            (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
  93              (declare (type (simple-array ,et1 1) seq1))
  94              (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
  95                (declare (type (simple-array ,et2 1) seq2))
  96                (let ((index2 start2))
  97                  (declare (type index index2))
  98                  (loop for index1 of-type index
  99                        from start1 below effective-end1 do
 100                        (setf (aref seq index1)
 101                              (aref seq index2))
 102                        (incf index2))))))
 103        seq1)))
 104
 105 (setf (function-info-transforms (info :function :info 'coerce)) nil)
 106 (deftransform coerce ((x type) (* *) * :when :both)
 107   (unless (constant-continuation-p type)
 108     (give-up-ir1-transform))
 109   (let ((tspec (specifier-type (continuation-value type))))
 110     (if (csubtypep (continuation-type x) tspec)
 111         'x
 112         ;; Note: The THE here makes sure that specifiers like
 113         ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
 114         `(the ,(continuation-value type)
 115            ,(cond
 116              ((csubtypep tspec (specifier-type 'double-float))
 117               '(%double-float x))
 118              ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
 119              ((csubtypep tspec (specifier-type 'float))
 120               '(%single-float x))
 121              ((csubtypep tspec (specifier-type 'simple-vector))
 122               '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type
 123              (t
 124               (give-up-ir1-transform)))))))
 125 (defun coerce-to-simple-vector (x)
 126   (if (simple-vector-p x)
 127       x
 128       (replace (make-array (length x)) x)))
 129
 130 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 131 ;;;; setting up for POSITION/FIND stuff
 132
 133 (defknown %find-position
 134   (t sequence t index sequence-end function function)
 135   (values t (or index null))
 136   (flushable call))
 137 (defknown %find-position-if
 138   (function sequence t index sequence-end function)
 139   (values t (or index null))
 140   (call))
 141
 142 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 143 ;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper
 144
 145 ;;; FIXME: Blow away old CMU CL implementation:
 146 ;;;  * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT
 147 ;;;  * matches to 'find' and 'position' in seq.lisp
 148
 149 ;;; We want to make sure that %FIND-POSITION is inline-expanded into
 150 ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
 151 ;;; expansion, so we factor out the condition into this function.
 152 (defun check-inlineability-of-find-position-if (sequence from-end)
 153   (let ((ctype (continuation-type sequence)))
 154     (cond ((csubtypep ctype (specifier-type 'vector))
 155            ;; It's not worth trying to inline vector code unless we know
 156            ;; a fair amount about it at compile time.
 157            (upgraded-element-type-specifier-or-give-up sequence)
 158            (unless (constant-continuation-p from-end)
 159              (give-up-ir1-transform
 160               "FROM-END argument value not known at compile time")))
 161           ((csubtypep ctype (specifier-type 'list))
 162            ;; Inlining on lists is generally worthwhile.
 163            )
 164           (t
 165            (give-up-ir1-transform
 166             "sequence type not known at compile time")))))
 167
 168 ;;; %FIND-POSITION-IF for LIST data
 169 (deftransform %find-position-if ((predicate sequence from-end start end key)
 170                                  (function list t t t function)
 171                                  *
 172                                  :policy (> speed space)
 173                                  :important t)
 174   "expand inline"
 175   '(let ((index 0)
 176          (find nil)
 177          (position nil))
 178      (declare (type index index))
 179      (dolist (i sequence (values find position))
 180        (let ((key-i (funcall key i)))
 181          (when (and end (>= index end))
 182            (return (values find position)))
 183          (when (>= index start)
 184            (when (funcall predicate key-i)
 185              ;; This hack of dealing with non-NIL FROM-END for list data
 186              ;; by iterating forward through the list and keeping track of
 187              ;; the last time we found a match might be more screwy than
 188              ;; what the user expects, but it seems to be allowed by the
 189              ;; ANSI standard. (And if the user is screwy enough to ask
 190              ;; for FROM-END behavior on list data, turnabout is fair play.)
 191              ;;
 192              ;; It's also not enormously efficient, calling PREDICATE and
 193              ;; KEY more often than necessary; but all the alternatives
 194              ;; seem to have their own efficiency problems.
 195              (if from-end
 196                  (setf find i
 197                        position index)
 198                  (return (values i index))))))
 199        (incf index))))
 200
 201 ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
 202 ;;; without loss of efficiency. (I.e., the optimizer should be able
 203 ;;; to straighten everything out.)
 204 (deftransform %find-position ((item sequence from-end start end key test)
 205                               (t list t t t t t)
 206                               *
 207                               :policy (> speed space)
 208                               :important t)
 209   "expand inline"
 210   '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
 211                         (lambda (i)
 212                           (funcall test-fun i item)))
 213                       sequence
 214                       from-end
 215                       start
 216                       end
 217                       (%coerce-callable-to-function key)))
 218
 219 ;;; The inline expansions for the VECTOR case are saved as macros so
 220 ;;; that we can share them between the DEFTRANSFORMs and the default
 221 ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
 222 ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
 223 (defun %find-position-or-find-position-if-vector-expansion (sequence-arg
 224                                                             from-end
 225                                                             start
 226                                                             end-arg
 227                                                             element
 228                                                             done-p-expr)
 229   (let ((offset (gensym "OFFSET"))
 230         (block (gensym "BLOCK"))
 231         (index (gensym "INDEX"))
 232         (n-sequence (gensym "N-SEQUENCE-"))
 233         (sequence (gensym "SEQUENCE"))
 234         (n-end (gensym "N-END-"))
 235         (end (gensym "END-")))
 236     `(let ((,n-sequence ,sequence-arg)
 237            (,n-end ,end-arg))
 238        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
 239                          (,start ,start)
 240                          (,end (or ,n-end (length ,n-sequence))))
 241          (block ,block
 242            (macrolet ((maybe-return ()
 243                         '(let ((,element (aref ,sequence ,index)))
 244                            (when ,done-p-expr
 245                              (return-from ,block
 246                                (values ,element
 247                                        (- ,index ,offset)))))))
 248              (if ,from-end
 249                  (loop for ,index
 250                        ;; (If we aren't fastidious about declaring that
 251                        ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
 252                        ;; can send us off into never-never land, since
 253                        ;; INDEX is initialized to -1.)
 254                        of-type index-or-minus-1
 255                        from (1- ,end) downto ,start do
 256                        (maybe-return))
 257                  (loop for ,index of-type index from ,start below ,end do
 258                        (maybe-return))))
 259            (values nil nil))))))
 260 (defmacro %find-position-vector-macro (item sequence
 261                                             from-end start end key test)
 262   (let ((element (gensym "ELEMENT")))
 263     (%find-position-or-find-position-if-vector-expansion
 264      sequence
 265      from-end
 266      start
 267      end
 268      element
 269      `(funcall ,test ,item (funcall ,key ,element)))))
 270 (defmacro %find-position-if-vector-macro (predicate sequence
 271                                                     from-end start end key)
 272   (let ((element (gensym "ELEMENT")))
 273     (%find-position-or-find-position-if-vector-expansion
 274      sequence
 275      from-end
 276      start
 277      end
 278      element
 279      `(funcall ,predicate (funcall ,key ,element)))))
 280
 281 ;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
 282 (deftransform %find-position-if ((predicate sequence from-end start end key)
 283                                  (function vector t t t function)
 284                                  *
 285                                  :policy (> speed space)
 286                                  :important t)
 287   "expand inline"
 288   (check-inlineability-of-find-position-if sequence from-end)
 289   '(%find-position-if-vector-macro predicate sequence
 290                                    from-end start end key))
 291 (deftransform %find-position ((item sequence from-end start end key test)
 292                               (t vector t t t function function)
 293                               *
 294                               :policy (> speed space)
 295                               :important t)
 296   "expand inline"
 297   (check-inlineability-of-find-position-if sequence from-end)
 298   '(%find-position-vector-macro item sequence
 299                                 from-end start end key test))
 300 \f
 301 ;;;; optimizations for floating point FLOOR, CEILING, TRUNCATE, and
 302 ;;;; ROUND, lifted from CMU CL 18c
 303 ;;;;
 304 ;;;; (Without these optimizations, these functions cons!)
 305
 306 ;;; Convert (TRUNCATE x y) to the obvious implementation.  We only want
 307 ;;; this when under certain conditions and let the generic TRUNCATE
 308 ;;; handle the rest.  (Note: if Y = 1, the divide and multiply by Y
 309 ;;; should be removed by other DEFTRANSFORMs.)
 310 (deftransform truncate ((x &optional y)
 311                         (float &optional (or float integer)))
 312   '(let ((res (%unary-truncate (/ x y))))
 313      (values res (- x (* y res)))))
 314
 315 (deftransform floor ((number &optional divisor)
 316                      (float &optional (or integer float)))
 317   '(multiple-value-bind (tru rem) (truncate number divisor)
 318     (if (and (not (zerop rem))
 319              (if (minusp divisor)
 320                  (plusp number)
 321                  (minusp number)))
 322         (values (1- tru) (+ rem divisor))
 323         (values tru rem))))
 324
 325 (deftransform ceiling ((number &optional divisor)
 326                        (float &optional (or integer float)))
 327   '(multiple-value-bind (tru rem) (truncate number divisor)
 328     (if (and (not (zerop rem))
 329              (if (minusp divisor)
 330                  (minusp number)
 331                  (plusp number)))
 332         (values (1+ tru) (- rem divisor))
 333         (values tru rem))))