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 '(%with-array-data-macro
  23             index-or-minus-1
  24             %find-position %find-position-vector-macro
  25             %find-position-if %find-position-if-vector-macro)))
  26
  27 (in-package "SB-C")
  28
  29 (deftype index-or-minus-1 () `(integer -1 ,(1- most-positive-fixnum)))
  30
  31 (declaim (optimize (speed 1) (space 2)))
  32
  33 ;;; This checks to see whether the array is simple and the start and
  34 ;;; end are in bounds. If so, it proceeds with those values.
  35 ;;; Otherwise, it calls %WITH-ARRAY-DATA. Note that %WITH-ARRAY-DATA
  36 ;;; may be further optimized.
  37 ;;;
  38 ;;; Given any ARRAY, bind DATA-VAR to the array's data vector and
  39 ;;; START-VAR and END-VAR to the start and end of the designated
  40 ;;; portion of the data vector. SVALUE and EVALUE are any start and
  41 ;;; end specified to the original operation, and are factored into the
  42 ;;; bindings of START-VAR and END-VAR. OFFSET-VAR is the cumulative
  43 ;;; offset of all displacements encountered, and does not include
  44 ;;; SVALUE.
  45 ;;;
  46 ;;; When FORCE-INLINE is set, the underlying %WITH-ARRAY-DATA form is
  47 ;;; forced to be inline, overriding the ordinary judgment of the
  48 ;;; %WITH-ARRAY-DATA DEFTRANSFORMs. Ordinarily the DEFTRANSFORMs are
  49 ;;; fairly picky about their arguments, figuring that if you haven't
  50 ;;; bothered to get all your ducks in a row, you probably don't care
  51 ;;; that much about speed anyway! But in some cases it makes sense to
  52 ;;; do type testing inside %WITH-ARRAY-DATA instead of outside, and
  53 ;;; the DEFTRANSFORM can't tell that that's going on, so it can make
  54 ;;; sense to use FORCE-INLINE option in that case.
  55 (defmacro with-array-data (((data-var array &key offset-var)
  56                             (start-var &optional (svalue 0))
  57                             (end-var &optional (evalue nil))
  58                             &key force-inline)
  59                            &body forms)
  60   (once-only ((n-array array)
  61               (n-svalue `(the index ,svalue))
  62               (n-evalue `(the (or index null) ,evalue)))
  63     `(multiple-value-bind (,data-var
  64                            ,start-var
  65                            ,end-var
  66                            ,@(when offset-var `(,offset-var)))
  67          (if (not (array-header-p ,n-array))
  68              (let ((,n-array ,n-array))
  69                (declare (type (simple-array * (*)) ,n-array))
  70                ,(once-only ((n-len `(length ,n-array))
  71                             (n-end `(or ,n-evalue ,n-len)))
  72                   `(if (<= ,n-svalue ,n-end ,n-len)
  73                        ;; success
  74                        (values ,n-array ,n-svalue ,n-end 0)
  75                        ;; failure: Make a NOTINLINE call to
  76                        ;; %WITH-ARRAY-DATA with our bad data
  77                        ;; to cause the error to be signalled.
  78                        (locally
  79                          (declare (notinline %with-array-data))
  80                          (%with-array-data ,n-array ,n-svalue ,n-evalue)))))
  81              (,(if force-inline '%with-array-data-macro '%with-array-data)
  82               ,n-array ,n-svalue ,n-evalue))
  83        ,@forms)))
  84
  85 ;;; This is the fundamental definition of %WITH-ARRAY-DATA, for use in
  86 ;;; DEFTRANSFORMs and DEFUNs.
  87 (defmacro %with-array-data-macro (array
  88                                   start
  89                                   end
  90                                   &key
  91                                   (element-type '*)
  92                                   unsafe?
  93                                   fail-inline?)
  94   (let ((size (gensym "SIZE-"))
  95         (data (gensym "DATA-"))
  96         (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
  97     `(let* ((,size (array-total-size ,array))
  98             (,end (cond (,end
  99                          (unless (or ,unsafe? (<= ,end ,size))
 100                            ,(if fail-inline?
 101                                 `(error "End ~D is greater than total size ~D."
 102                                         ,end ,size)
 103                                 `(failed-%with-array-data ,array ,start ,end)))
 104                          ,end)
 105                         (t ,size))))
 106        (unless (or ,unsafe? (<= ,start ,end))
 107          ,(if fail-inline?
 108               `(error "Start ~D is greater than end ~D." ,start ,end)
 109               `(failed-%with-array-data ,array ,start ,end)))
 110        (do ((,data ,array (%array-data-vector ,data))
 111             (,cumulative-offset 0
 112                                 (+ ,cumulative-offset
 113                                    (%array-displacement ,data))))
 114            ((not (array-header-p ,data))
 115             (values (the (simple-array ,element-type 1) ,data)
 116                     (the index (+ ,cumulative-offset ,start))
 117                     (the index (+ ,cumulative-offset ,end))
 118                     (the index ,cumulative-offset)))
 119          (declare (type index ,cumulative-offset))))))
 120
 121 (defun upgraded-element-type-specifier-or-give-up (continuation)
 122   (let* ((element-ctype (extract-upgraded-element-type continuation))
 123          (element-type-specifier (type-specifier element-ctype)))
 124     (if (eq element-type-specifier '*)
 125         (give-up-ir1-transform
 126          "upgraded array element type not known at compile time")
 127         element-type-specifier)))
 128
 129 (deftransform %with-array-data ((array start end)
 130                                 ;; Note: This transform is limited to
 131                                 ;; VECTOR only because I happened to
 132                                 ;; create it in order to get sequence
 133                                 ;; function operations to be more
 134                                 ;; efficient. It might very well be
 135                                 ;; reasonable to allow general ARRAY
 136                                 ;; here, I just haven't tried to
 137                                 ;; understand the performance issues
 138                                 ;; involved. -- WHN
 139                                 (vector index (or index null))
 140                                 *
 141                                 :important t
 142                                 :node node
 143                                 :policy (> speed space))
 144   "inline non-SIMPLE-vector-handling logic"
 145   (let ((element-type (upgraded-element-type-specifier-or-give-up array)))
 146     `(%with-array-data-macro array start end
 147                              :unsafe? ,(policy node (= safety 0))
 148                              :element-type ,element-type)))
 149
 150 ;;; It'd waste space to expand copies of error handling in every
 151 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
 152 ;;; instead. This is just a wrapper which is known never to return.
 153 (defknown failed-%with-array-data (t t t) nil)
 154 (defun failed-%with-array-data (array start end)
 155   (declare (notinline %with-array-data))
 156   (%with-array-data array start end)
 157   (error "internal error: shouldn't be here with valid parameters"))
 158
 159 (deftransform fill ((seq item &key (start 0) (end (length seq)))
 160                     (vector t &key (:start t) (:end index))
 161                     *
 162                     :policy (> speed space))
 163   "open code"
 164   (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
 165     `(with-array-data ((data seq)
 166                        (start start)
 167                        (end end))
 168        (declare (type (simple-array ,element-type 1) data))
 169        (do ((i start (1+ i)))
 170            ((= i end) seq)
 171          (declare (type index i))
 172          ;; WITH-ARRAY-DATA does our range checks once and for all, so
 173          ;; it'd be wasteful to check again on every AREF.
 174          (declare (optimize (safety 0)))
 175          (setf (aref data i) item)))))
 176 ;;; TO DO for DEFTRANSFORM FILL:
 177 ;;;   ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
 178 ;;;      apply when SPEED > SPACE.
 179 ;;;   ?? Add test cases.
 180
 181 #+nil ; not tested yet..
 182 (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
 183                        (vector vector &key
 184                                (:start1 index) (:end1 (or index null))
 185                                (:start2 index) (:end2 (or index null)))
 186                        *
 187                        ;; This is potentially an awfully big transform
 188                        ;; (if things like (EQ SEQ1 SEQ2) aren't known
 189                        ;; at runtime). We need to make it available
 190                        ;; inline, since otherwise there's no way to do
 191                        ;; it efficiently on all array types, but it
 192                        ;; probably doesn't belong inline all the time.
 193                        :policy (> speed (1+ space)))
 194   "open code"
 195   (let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
 196         (et2 (upgraded-element-type-specifier-or-give-up seq2)))
 197     `(let* ((n-copied (min (- end1 start1) (- end2 start2)))
 198             (effective-end1 (+ start1 n-copied)))
 199        (if (eq seq1 seq2)
 200            (with-array-data ((seq seq1)
 201                              (start (min start1 start2))
 202                              (end (max end1 end2)))
 203              (declare (type (simple-array ,et1 1) seq))
 204              (if (<= start1 start2)
 205                  (let ((index2 start2))
 206                    (declare (type index index2))
 207                    (loop for index1 of-type index
 208                          from start1 below effective-end1 do
 209                          (setf (aref seq index1)
 210                                (aref seq index2))
 211                          (incf index2)))
 212                  (let ((index2 (1- end2)))
 213                    (declare (type (integer -2 #.most-positive-fixnum) index2))
 214                    (loop for index1 of-type index-or-minus-1
 215                          from (1- effective-end1) downto start1 do
 216                          (setf (aref seq index1)
 217                                (aref seq index2))
 218                          (decf index2)))))
 219            (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
 220              (declare (type (simple-array ,et1 1) seq1))
 221              (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
 222                (declare (type (simple-array ,et2 1) seq2))
 223                (let ((index2 start2))
 224                  (declare (type index index2))
 225                  (loop for index1 of-type index
 226                        from start1 below effective-end1 do
 227                        (setf (aref seq index1)
 228                              (aref seq index2))
 229                        (incf index2))))))
 230        seq1)))
 231
 232 (setf (function-info-transforms (info :function :info 'coerce)) nil)
 233 (deftransform coerce ((x type) (* *) * :when :both)
 234   (unless (constant-continuation-p type)
 235     (give-up-ir1-transform))
 236   (let ((tspec (specifier-type (continuation-value type))))
 237     (if (csubtypep (continuation-type x) tspec)
 238         'x
 239         ;; Note: The THE here makes sure that specifiers like
 240         ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
 241         `(the ,(continuation-value type)
 242            ,(cond
 243              ((csubtypep tspec (specifier-type 'double-float))
 244               '(%double-float x))
 245              ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
 246              ((csubtypep tspec (specifier-type 'float))
 247               '(%single-float x))
 248              ((csubtypep tspec (specifier-type 'simple-vector))
 249               '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type
 250              (t
 251               (give-up-ir1-transform)))))))
 252 (defun coerce-to-simple-vector (x)
 253   (if (simple-vector-p x)
 254       x
 255       (replace (make-array (length x)) x)))
 256
 257 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 258 ;;;; setting up for POSITION/FIND stuff
 259
 260 (defknown %find-position
 261   (t sequence t index sequence-end function function)
 262   (values t (or index null))
 263   (flushable call))
 264 (defknown %find-position-if
 265   (function sequence t index sequence-end function)
 266   (values t (or index null))
 267   (call))
 268
 269 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 270 ;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper
 271
 272 ;;; FIXME: Blow away old CMU CL implementation:
 273 ;;;  * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT
 274 ;;;  * matches to 'find' and 'position' in seq.lisp
 275
 276 ;;; We want to make sure that %FIND-POSITION is inline-expanded into
 277 ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
 278 ;;; expansion, so we factor out the condition into this function.
 279 (defun check-inlineability-of-find-position-if (sequence from-end)
 280   (let ((ctype (continuation-type sequence)))
 281     (cond ((csubtypep ctype (specifier-type 'vector))
 282            ;; It's not worth trying to inline vector code unless we know
 283            ;; a fair amount about it at compile time.
 284            (upgraded-element-type-specifier-or-give-up sequence)
 285            (unless (constant-continuation-p from-end)
 286              (give-up-ir1-transform
 287               "FROM-END argument value not known at compile time")))
 288           ((csubtypep ctype (specifier-type 'list))
 289            ;; Inlining on lists is generally worthwhile.
 290            )
 291           (t
 292            (give-up-ir1-transform
 293             "sequence type not known at compile time")))))
 294
 295 ;;; %FIND-POSITION-IF for LIST data
 296 (deftransform %find-position-if ((predicate sequence from-end start end key)
 297                                  (function list t t t function)
 298                                  *
 299                                  :policy (> speed space)
 300                                  :important t)
 301   "expand inline"
 302   '(let ((index 0)
 303          (find nil)
 304          (position nil))
 305      (declare (type index index))
 306      (dolist (i sequence (values find position))
 307        (let ((key-i (funcall key i)))
 308          (when (and end (>= index end))
 309            (return (values find position)))
 310          (when (>= index start)
 311            (when (funcall predicate key-i)
 312              ;; This hack of dealing with non-NIL FROM-END for list data
 313              ;; by iterating forward through the list and keeping track of
 314              ;; the last time we found a match might be more screwy than
 315              ;; what the user expects, but it seems to be allowed by the
 316              ;; ANSI standard. (And if the user is screwy enough to ask
 317              ;; for FROM-END behavior on list data, turnabout is fair play.)
 318              ;;
 319              ;; It's also not enormously efficient, calling PREDICATE and
 320              ;; KEY more often than necessary; but all the alternatives
 321              ;; seem to have their own efficiency problems.
 322              (if from-end
 323                  (setf find i
 324                        position index)
 325                  (return (values i index))))))
 326        (incf index))))
 327
 328 ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
 329 ;;; without loss of efficiency. (I.e., the optimizer should be able
 330 ;;; to straighten everything out.)
 331 (deftransform %find-position ((item sequence from-end start end key test)
 332                               (t list t t t t t)
 333                               *
 334                               :policy (> speed space)
 335                               :important t)
 336   "expand inline"
 337   '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
 338                         (lambda (i)
 339                           (funcall test-fun i item)))
 340                       sequence
 341                       from-end
 342                       start
 343                       end
 344                       (%coerce-callable-to-function key)))
 345
 346 ;;; The inline expansions for the VECTOR case are saved as macros so
 347 ;;; that we can share them between the DEFTRANSFORMs and the default
 348 ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
 349 ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
 350 (defun %find-position-or-find-position-if-vector-expansion (sequence-arg
 351                                                             from-end
 352                                                             start
 353                                                             end-arg
 354                                                             element
 355                                                             done-p-expr)
 356   (let ((offset (gensym "OFFSET"))
 357         (block (gensym "BLOCK"))
 358         (index (gensym "INDEX"))
 359         (n-sequence (gensym "N-SEQUENCE-"))
 360         (sequence (gensym "SEQUENCE"))
 361         (n-end (gensym "N-END-"))
 362         (end (gensym "END-")))
 363     `(let ((,n-sequence ,sequence-arg)
 364            (,n-end ,end-arg))
 365        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
 366                          (,start ,start)
 367                          (,end (or ,n-end (length ,n-sequence))))
 368          (block ,block
 369            (macrolet ((maybe-return ()
 370                         '(let ((,element (aref ,sequence ,index)))
 371                            (when ,done-p-expr
 372                              (return-from ,block
 373                                (values ,element
 374                                        (- ,index ,offset)))))))
 375              (if ,from-end
 376                  (loop for ,index
 377                        ;; (If we aren't fastidious about declaring that
 378                        ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
 379                        ;; can send us off into never-never land, since
 380                        ;; INDEX is initialized to -1.)
 381                        of-type index-or-minus-1
 382                        from (1- ,end) downto ,start do
 383                        (maybe-return))
 384                  (loop for ,index of-type index from ,start below ,end do
 385                        (maybe-return))))
 386            (values nil nil))))))
 387 (defmacro %find-position-vector-macro (item sequence
 388                                             from-end start end key test)
 389   (let ((element (gensym "ELEMENT")))
 390     (%find-position-or-find-position-if-vector-expansion
 391      sequence
 392      from-end
 393      start
 394      end
 395      element
 396      `(funcall ,test ,item (funcall ,key ,element)))))
 397 (defmacro %find-position-if-vector-macro (predicate sequence
 398                                                     from-end start end key)
 399   (let ((element (gensym "ELEMENT")))
 400     (%find-position-or-find-position-if-vector-expansion
 401      sequence
 402      from-end
 403      start
 404      end
 405      element
 406      `(funcall ,predicate (funcall ,key ,element)))))
 407
 408 ;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
 409 (deftransform %find-position-if ((predicate sequence from-end start end key)
 410                                  (function vector t t t function)
 411                                  *
 412                                  :policy (> speed space)
 413                                  :important t)
 414   "expand inline"
 415   (check-inlineability-of-find-position-if sequence from-end)
 416   '(%find-position-if-vector-macro predicate sequence
 417                                    from-end start end key))
 418 (deftransform %find-position ((item sequence from-end start end key test)
 419                               (t vector t t t function function)
 420                               *
 421                               :policy (> speed space)
 422                               :important t)
 423   "expand inline"
 424   (check-inlineability-of-find-position-if sequence from-end)
 425   '(%find-position-vector-macro item sequence
 426                                 from-end start end key test))
 427 \f
 428 ;;;; optimizations for floating point FLOOR, CEILING, TRUNCATE, and
 429 ;;;; ROUND, lifted from CMU CL 18c
 430 ;;;;
 431 ;;;; (Without these optimizations, these functions cons!)
 432
 433 ;;; Convert (TRUNCATE x y) to the obvious implementation.  We only want
 434 ;;; this when under certain conditions and let the generic TRUNCATE
 435 ;;; handle the rest.  (Note: if Y = 1, the divide and multiply by Y
 436 ;;; should be removed by other DEFTRANSFORMs.)
 437 (deftransform truncate ((x &optional y)
 438                         (float &optional (or float integer)))
 439   '(let ((res (%unary-truncate (/ x y))))
 440      (values res (- x (* y res)))))
 441
 442 (deftransform floor ((number &optional divisor)
 443                      (float &optional (or integer float)))
 444   '(multiple-value-bind (tru rem) (truncate number divisor)
 445     (if (and (not (zerop rem))
 446              (if (minusp divisor)
 447                  (plusp number)
 448                  (minusp number)))
 449         (values (1- tru) (+ rem divisor))
 450         (values tru rem))))
 451
 452 (deftransform ceiling ((number &optional divisor)
 453                        (float &optional (or integer float)))
 454   '(multiple-value-bind (tru rem) (truncate number divisor)
 455     (if (and (not (zerop rem))
 456              (if (minusp divisor)
 457                  (minusp number)
 458                  (plusp number)))
 459         (values (1+ tru) (- rem divisor))
 460         (values tru rem))))