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 is the fundamental definition of %WITH-ARRAY-DATA, for use in
  34 ;;; DEFTRANSFORMs and DEFUNs.
  35 (defmacro %with-array-data-macro (array
  36                                   start
  37                                   end
  38                                   &key
  39                                   (element-type '*)
  40                                   unsafe?
  41                                   fail-inline?)
  42   (format t "~&/in %WITH-ARRAY-DATA-MACRO, ELEMENT-TYPE=~S~%" element-type)
  43   (let ((size (gensym "SIZE-"))
  44         (data (gensym "DATA-"))
  45         (cumulative-offset (gensym "CUMULATIVE-OFFSET-")))
  46     `(let* ((,size (array-total-size ,array))
  47             (,end (cond (,end
  48                          (unless (or ,unsafe? (<= ,end ,size))
  49                            ,(if fail-inline?
  50                                 `(error "End ~D is greater than total size ~D."
  51                                         ,end ,size)
  52                                 `(failed-%with-array-data ,array ,start ,end)))
  53                          ,end)
  54                         (t ,size))))
  55        (unless (or ,unsafe? (<= ,start ,end))
  56          ,(if fail-inline?
  57               `(error "Start ~D is greater than end ~D." ,start ,end)
  58               `(failed-%with-array-data ,array ,start ,end)))
  59        (do ((,data ,array (%array-data-vector ,data))
  60             (,cumulative-offset 0
  61                                 (+ ,cumulative-offset
  62                                    (%array-displacement ,data))))
  63            ((not (array-header-p ,data))
  64             (values (the (simple-array ,element-type 1) ,data)
  65                     (the index (+ ,cumulative-offset ,start))
  66                     (the index (+ ,cumulative-offset ,end))
  67                     (the index ,cumulative-offset)))
  68          (declare (type index ,cumulative-offset))))))
  69
  70 (defun upgraded-element-type-specifier-or-give-up (continuation)
  71   (let* ((element-ctype (extract-upgraded-element-type continuation))
  72          (element-type-specifier (type-specifier element-ctype)))
  73     (if (eq element-type-specifier '*)
  74         (give-up-ir1-transform
  75          "upgraded array element type not known at compile time")
  76         element-type-specifier)))
  77
  78 (deftransform %with-array-data ((array start end)
  79                                 ;; Note: This transform is limited to
  80                                 ;; VECTOR only because I happened to
  81                                 ;; create it in order to get sequence
  82                                 ;; function operations to be more
  83                                 ;; efficient. It might very well be
  84                                 ;; reasonable to allow general ARRAY
  85                                 ;; here, I just haven't tried to
  86                                 ;; understand the performance issues
  87                                 ;; involved. -- WHN
  88                                 (vector index (or index null))
  89                                 *
  90                                 :important t
  91                                 :node node
  92                                 :policy (> speed space))
  93   "inline non-SIMPLE-vector-handling logic"
  94   (let ((element-type (upgraded-element-type-specifier-or-give-up array)))
  95     (format t "~&/in DEFTRANSFORM %WITH-ARRAY-DATA, ELEMENT-TYPE=~S~%"
  96             element-type)
  97     `(%with-array-data-macro array start end
  98                              :unsafe? ,(policy node (= safety 0))
  99                              :element-type ,element-type)))
 100
 101 ;;; It'd waste space to expand copies of error handling in every
 102 ;;; inline %WITH-ARRAY-DATA, so we have them call this function
 103 ;;; instead. This is just a wrapper which is known never to return.
 104 (defknown failed-%with-array-data (t t t) nil)
 105 (defun failed-%with-array-data (array start end)
 106   (declare (notinline %with-array-data))
 107   (%with-array-data array start end)
 108   (error "internal error: shouldn't be here with valid parameters"))
 109
 110 (deftransform fill ((seq item &key (start 0) (end (length seq)))
 111                     (vector t &key (:start t) (:end index))
 112                     *
 113                     :policy (> speed space))
 114   "open code"
 115   (let ((element-type (upgraded-element-type-specifier-or-give-up seq)))
 116     `(with-array-data ((data seq)
 117                        (start start)
 118                        (end end))
 119        (declare (type (simple-array ,element-type 1) data))
 120        (do ((i start (1+ i)))
 121            ((= i end) seq)
 122          (declare (type index i))
 123          ;; WITH-ARRAY-DATA does our range checks once and for all, so
 124          ;; it'd be wasteful to check again on every AREF.
 125          (declare (optimize (safety 0)))
 126          (setf (aref data i) item)))))
 127 ;;; TO DO for DEFTRANSFORM FILL:
 128 ;;;   ?? This DEFTRANSFORM, and the old DEFTRANSFORMs, should only
 129 ;;;      apply when SPEED > SPACE.
 130 ;;;   ?? Add test cases.
 131
 132 #+nil ; not tested yet..
 133 (deftransform replace ((seq1 seq2 &key (start1 0) end1 (start2 0) end2)
 134                        (vector vector &key
 135                                (:start1 index) (:end1 (or index null))
 136                                (:start2 index) (:end2 (or index null)))
 137                        *
 138                        ;; This is potentially an awfully big transform
 139                        ;; (if things like (EQ SEQ1 SEQ2) aren't known
 140                        ;; at runtime). We need to make it available
 141                        ;; inline, since otherwise there's no way to do
 142                        ;; it efficiently on all array types, but it
 143                        ;; probably doesn't belong inline all the time.
 144                        :policy (> speed (1+ space)))
 145   "open code"
 146   (let ((et1 (upgraded-element-type-specifier-or-give-up seq1))
 147         (et2 (upgraded-element-type-specifier-or-give-up seq2)))
 148     `(let* ((n-copied (min (- end1 start1) (- end2 start2)))
 149             (effective-end1 (+ start1 n-copied)))
 150        (if (eq seq1 seq2)
 151            (with-array-data ((seq seq1)
 152                              (start (min start1 start2))
 153                              (end (max end1 end2)))
 154              (declare (type (simple-array ,et1 1) seq))
 155              (if (<= start1 start2)
 156                  (let ((index2 start2))
 157                    (declare (type index index2))
 158                    (loop for index1 of-type index
 159                          from start1 below effective-end1 do
 160                          (setf (aref seq index1)
 161                                (aref seq index2))
 162                          (incf index2)))
 163                  (let ((index2 (1- end2)))
 164                    (declare (type (integer -2 #.most-positive-fixnum) index2))
 165                    (loop for index1 of-type index-or-minus-1
 166                          from (1- effective-end1) downto start1 do
 167                          (setf (aref seq index1)
 168                                (aref seq index2))
 169                          (decf index2)))))
 170            (with-array-data ((seq1 seq1) (start1 start1) (end1 end1))
 171              (declare (type (simple-array ,et1 1) seq1))
 172              (with-array-data ((seq2 seq2) (start2 start2) (end2 end2))
 173                (declare (type (simple-array ,et2 1) seq2))
 174                (let ((index2 start2))
 175                  (declare (type index index2))
 176                  (loop for index1 of-type index
 177                        from start1 below effective-end1 do
 178                        (setf (aref seq index1)
 179                              (aref seq index2))
 180                        (incf index2))))))
 181        seq1)))
 182
 183 (setf (function-info-transforms (info :function :info 'coerce)) nil)
 184 (deftransform coerce ((x type) (* *) * :when :both)
 185   (format t "~&/looking at DEFTRANSFORM COERCE~%")
 186   (unless (constant-continuation-p type)
 187     (give-up-ir1-transform))
 188   (let ((tspec (specifier-type (continuation-value type))))
 189     (if (csubtypep (continuation-type x) tspec)
 190         'x
 191         ;; Note: The THE here makes sure that specifiers like
 192         ;; (SINGLE-FLOAT 0.0 1.0) can raise a TYPE-ERROR.
 193         `(the ,(continuation-value type)
 194            ,(cond
 195              ((csubtypep tspec (specifier-type 'double-float))
 196               '(%double-float x))
 197              ;; FIXME: #!+long-float (t ,(error "LONG-FLOAT case needed"))
 198              ((csubtypep tspec (specifier-type 'float))
 199               '(%single-float x))
 200              ((csubtypep tspec (specifier-type 'simple-vector))
 201               '(coerce-to-simple-vector x)) ; FIXME: needs DEFKNOWN return type
 202              (t
 203               (give-up-ir1-transform)))))))
 204 (defun coerce-to-simple-vector (x)
 205   (if (simple-vector-p x)
 206       x
 207       (replace (make-array (length x)) x)))
 208
 209 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 210 ;;;; setting up for POSITION/FIND stuff
 211
 212 (defknown %find-position
 213   (t sequence t index sequence-end function function)
 214   (values t (or index null))
 215   (flushable call))
 216 (defknown %find-position-if
 217   (function sequence t index sequence-end function)
 218   (values t (or index null))
 219   (call))
 220
 221 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 222 ;;;; POSITION, POSITION-IF, FIND, and FIND-IF proper
 223
 224 ;;; FIXME: Blow away old CMU CL implementation:
 225 ;;;  * the section of seq.lisp with VECTOR-LOCATER-MACRO and LOCATER-TEST-NOT
 226 ;;;  * matches to 'find' and 'position' in seq.lisp
 227
 228 ;;; We want to make sure that %FIND-POSITION is inline-expanded into
 229 ;;; %FIND-POSITION-IF only when %FIND-POSITION-IF has an inline
 230 ;;; expansion, so we factor out the condition into this function.
 231 (defun check-inlineability-of-find-position-if (sequence from-end)
 232   (let ((ctype (continuation-type sequence)))
 233     (cond ((csubtypep ctype (specifier-type 'vector))
 234            ;; It's not worth trying to inline vector code unless we know
 235            ;; a fair amount about it at compile time.
 236            (upgraded-element-type-specifier-or-give-up sequence)
 237            (unless (constant-continuation-p from-end)
 238              (give-up-ir1-transform
 239               "FROM-END argument value not known at compile time")))
 240           ((csubtypep ctype (specifier-type 'list))
 241            ;; Inlining on lists is generally worthwhile.
 242            )
 243           (t
 244            (give-up-ir1-transform
 245             "sequence type not known at compile time")))))
 246
 247 ;;; %FIND-POSITION-IF for LIST data
 248 (deftransform %find-position-if ((predicate sequence from-end start end key)
 249                                  (function list t t t function)
 250                                  *
 251                                  :policy (> speed space)
 252                                  :important t)
 253   "expand inline"
 254   '(let ((index 0)
 255          (find nil)
 256          (position nil))
 257      (declare (type index index))
 258      (dolist (i sequence (values find position))
 259        (let ((key-i (funcall key i)))
 260          (when (and end (>= index end))
 261            (return (values find position)))
 262          (when (>= index start)
 263            (when (funcall predicate key-i)
 264              ;; This hack of dealing with non-NIL FROM-END for list data
 265              ;; by iterating forward through the list and keeping track of
 266              ;; the last time we found a match might be more screwy than
 267              ;; what the user expects, but it seems to be allowed by the
 268              ;; ANSI standard. (And if the user is screwy enough to ask
 269              ;; for FROM-END behavior on list data, turnabout is fair play.)
 270              ;;
 271              ;; It's also not enormously efficient, calling PREDICATE and
 272              ;; KEY more often than necessary; but all the alternatives
 273              ;; seem to have their own efficiency problems.
 274              (if from-end
 275                  (setf find i
 276                        position index)
 277                  (return (values i index))))))
 278        (incf index))))
 279
 280 ;;; %FIND-POSITION for LIST data can be expanded into %FIND-POSITION-IF
 281 ;;; without loss of efficiency. (I.e., the optimizer should be able
 282 ;;; to straighten everything out.)
 283 (deftransform %find-position ((item sequence from-end start end key test)
 284                               (t list t t t t t)
 285                               *
 286                               :policy (> speed space)
 287                               :important t)
 288   "expand inline"
 289   '(%find-position-if (let ((test-fun (%coerce-callable-to-function test)))
 290                         (lambda (i)
 291                           (funcall test-fun i item)))
 292                       sequence
 293                       from-end
 294                       start
 295                       end
 296                       (%coerce-callable-to-function key)))
 297
 298 ;;; The inline expansions for the VECTOR case are saved as macros so
 299 ;;; that we can share them between the DEFTRANSFORMs and the default
 300 ;;; cases in the DEFUNs. (This isn't needed for the LIST case, because
 301 ;;; the DEFTRANSFORMs for LIST are less choosy about when to expand.)
 302 (defun %find-position-or-find-position-if-vector-expansion (sequence-arg
 303                                                             from-end
 304                                                             start
 305                                                             end-arg
 306                                                             element
 307                                                             done-p-expr)
 308   (let ((offset (gensym "OFFSET"))
 309         (block (gensym "BLOCK"))
 310         (index (gensym "INDEX"))
 311         (n-sequence (gensym "N-SEQUENCE-"))
 312         (sequence (gensym "SEQUENCE"))
 313         (n-end (gensym "N-END-"))
 314         (end (gensym "END-")))
 315     `(let ((,n-sequence ,sequence-arg)
 316            (,n-end ,end-arg))
 317        ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
 318        ;;(format t "~&/simplicity=~S~%" (typep ,n-sequence 'simple-array))
 319        ;;(describe ,n-sequence)
 320        (with-array-data ((,sequence ,n-sequence :offset-var ,offset)
 321                          (,start ,start)
 322                          (,end (or ,n-end (length ,n-sequence))))
 323          ;;(format t "~&sequence=~S~%start=~S~%end=~S~%" ,sequence ,start ,end)
 324          ;;(format t "~&/n-sequence=~S~%" ,n-sequence)
 325          (block ,block
 326            (macrolet ((maybe-return ()
 327                         '(let ((,element (aref ,sequence ,index)))
 328                            (when ,done-p-expr
 329                              (return-from ,block
 330                                (values ,element
 331                                        (- ,index ,offset)))))))
 332              (if ,from-end
 333                  (loop for ,index
 334                        ;; (If we aren't fastidious about declaring that
 335                        ;; INDEX might be -1, then (FIND 1 #() :FROM-END T)
 336                        ;; can send us off into never-never land, since
 337                        ;; INDEX is initialized to -1.)
 338                        of-type index-or-minus-1
 339                        from (1- ,end) downto ,start do
 340                        (maybe-return))
 341                  (loop for ,index of-type index from ,start below ,end do
 342                        (maybe-return))))
 343            (values nil nil))))))
 344 (defmacro %find-position-vector-macro (item sequence
 345                                             from-end start end key test)
 346   (let ((element (gensym "ELEMENT")))
 347     (%find-position-or-find-position-if-vector-expansion
 348      sequence
 349      from-end
 350      start
 351      end
 352      element
 353      `(funcall ,test ,item (funcall ,key ,element)))))
 354 (defmacro %find-position-if-vector-macro (predicate sequence
 355                                                     from-end start end key)
 356   (let ((element (gensym "ELEMENT")))
 357     (%find-position-or-find-position-if-vector-expansion
 358      sequence
 359      from-end
 360      start
 361      end
 362      element
 363      `(funcall ,predicate (funcall ,key ,element)))))
 364
 365 ;;; %FIND-POSITION and %FIND-POSITION-IF for VECTOR data
 366 (deftransform %find-position-if ((predicate sequence from-end start end key)
 367                                  (function vector t t t function)
 368                                  *
 369                                  :policy (> speed space)
 370                                  :important t)
 371   "expand inline"
 372   (check-inlineability-of-find-position-if sequence from-end)
 373   '(%find-position-if-vector-macro predicate sequence
 374                                    from-end start end key))
 375 (deftransform %find-position ((item sequence from-end start end key test)
 376                               (t vector t t t function function)
 377                               *
 378                               :policy (> speed space)
 379                               :important t)
 380   "expand inline"
 381   (check-inlineability-of-find-position-if sequence from-end)
 382   '(%find-position-vector-macro item sequence
 383                                 from-end start end key test))