src/compiler/generic/vm-tran.lisp

   1 ;;;; implementation-dependent transforms
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!C")
  13
  14 ;;; We need to define these predicates, since the TYPEP source
  15 ;;; transform picks whichever predicate was defined last when there
  16 ;;; are multiple predicates for equivalent types.
  17 (define-source-transform short-float-p (x) `(single-float-p ,x))
  18 #!-long-float
  19 (define-source-transform long-float-p (x) `(double-float-p ,x))
  20
  21 (define-source-transform compiled-function-p (x)
  22   #!-sb-eval
  23   `(functionp ,x)
  24   #!+sb-eval
  25   (once-only ((x x))
  26     `(and (functionp ,x)
  27           (not (sb!eval:interpreted-function-p ,x)))))
  28
  29 (define-source-transform char-int (x)
  30   `(char-code ,x))
  31
  32 (deftransform abs ((x) (rational))
  33   '(if (< x 0) (- x) x))
  34
  35 ;;; We don't want to clutter the bignum code.
  36 #!+(or x86 x86-64)
  37 (define-source-transform sb!bignum:%bignum-ref (bignum index)
  38   ;; KLUDGE: We use TRULY-THE here because even though the bignum code
  39   ;; is (currently) compiled with (SAFETY 0), the compiler insists on
  40   ;; inserting CAST nodes to ensure that INDEX is of the correct type.
  41   ;; These CAST nodes do not generate any type checks, but they do
  42   ;; interfere with the operation of FOLD-INDEX-ADDRESSING, below.
  43   ;; This scenario is a problem for the more user-visible case of
  44   ;; folding as well.  --njf, 2006-12-01
  45   `(sb!bignum:%bignum-ref-with-offset ,bignum
  46                                       (truly-the bignum-index ,index) 0))
  47
  48 #!+(or x86 x86-64)
  49 (defun fold-index-addressing (fun-name element-size lowtag data-offset
  50                               index offset &optional setter-p)
  51   (multiple-value-bind (func index-args) (extract-fun-args index '(+ -) 2)
  52     (destructuring-bind (x constant) index-args
  53       (unless (and (constant-lvar-p constant)
  54                    ;; we lose if the remaining argument isn't a fixnum
  55                    (csubtypep (lvar-type x) (specifier-type 'fixnum)))
  56         (give-up-ir1-transform))
  57       (let ((value (lvar-value constant))
  58             new-offset)
  59         (unless (and (integerp value)
  60                      (sb!vm::foldable-constant-offset-p
  61                       element-size lowtag data-offset
  62                       (setf new-offset (funcall func (lvar-value offset)
  63                                                 value))))
  64           (give-up-ir1-transform "constant is too large for inlining"))
  65         (splice-fun-args index func 2)
  66         `(lambda (thing index off1 off2 ,@(when setter-p
  67                                             '(value)))
  68            (declare (ignore off1 off2))
  69            (,fun-name thing index ',new-offset ,@(when setter-p
  70                                                    '(value))))))))
  71
  72 #!+(or x86 x86-64)
  73 (deftransform sb!bignum:%bignum-ref-with-offset
  74     ((bignum index offset) * * :node node)
  75   (fold-index-addressing 'sb!bignum:%bignum-ref-with-offset
  76                          sb!vm:n-word-bits sb!vm:other-pointer-lowtag
  77                          sb!vm:bignum-digits-offset
  78                          index offset))
  79
  80 ;;; The layout is stored in slot 0.
  81 (define-source-transform %instance-layout (x)
  82   `(truly-the layout (%instance-ref ,x 0)))
  83 (define-source-transform %set-instance-layout (x val)
  84   `(%instance-set ,x 0 (the layout ,val)))
  85 (define-source-transform %funcallable-instance-layout (x)
  86   `(truly-the layout (%funcallable-instance-info ,x 0)))
  87 (define-source-transform %set-funcallable-instance-layout (x val)
  88   `(setf (%funcallable-instance-info ,x 0) (the layout ,val)))
  89 \f
  90 ;;;; simplifying HAIRY-DATA-VECTOR-REF and HAIRY-DATA-VECTOR-SET
  91
  92 (deftransform hairy-data-vector-ref ((string index) (simple-string t))
  93   (let ((ctype (lvar-type string)))
  94     (if (array-type-p ctype)
  95         ;; the other transform will kick in, so that's OK
  96         (give-up-ir1-transform)
  97         `(etypecase string
  98           ((simple-array character (*))
  99            (data-vector-ref string index))
 100           #!+sb-unicode
 101           ((simple-array base-char (*))
 102            (data-vector-ref string index))
 103           ((simple-array nil (*))
 104            (data-vector-ref string index))))))
 105
 106 ;;; This and the corresponding -SET transform work equally well on non-simple
 107 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
 108 ;;; where it actually helped with non-simple arrays -- to the contrary, it
 109 ;;; only made for bigger and up to 100% slower code.
 110 (deftransform hairy-data-vector-ref ((array index) (simple-array t) *)
 111   "avoid runtime dispatch on array element type"
 112   (let* ((type (lvar-type array))
 113          (element-ctype (array-type-upgraded-element-type type))
 114          (declared-element-ctype (array-type-declared-element-type type)))
 115     (declare (type ctype element-ctype))
 116     (when (eq *wild-type* element-ctype)
 117       (give-up-ir1-transform
 118        "Upgraded element type of array is not known at compile time."))
 119     ;; (The expansion here is basically a degenerate case of
 120     ;; WITH-ARRAY-DATA. Since WITH-ARRAY-DATA is implemented as a
 121     ;; macro, and macros aren't expanded in transform output, we have
 122     ;; to hand-expand it ourselves.)
 123     (let* ((element-type-specifier (type-specifier element-ctype)))
 124       `(multiple-value-bind (array index)
 125            (%data-vector-and-index array index)
 126          (declare (type (simple-array ,element-type-specifier 1) array))
 127          ,(let ((bare-form '(data-vector-ref array index)))
 128             (if (type= element-ctype declared-element-ctype)
 129                 bare-form
 130                 `(the ,(type-specifier declared-element-ctype)
 131                       ,bare-form)))))))
 132
 133 ;;; Transform multi-dimensional array to one dimensional data vector
 134 ;;; access.
 135 (deftransform data-vector-ref ((array index) (simple-array t))
 136   (let ((array-type (lvar-type array)))
 137     (unless (array-type-p array-type)
 138       (give-up-ir1-transform))
 139     (let ((dims (array-type-dimensions array-type)))
 140       (when (or (atom dims) (= (length dims) 1))
 141         (give-up-ir1-transform))
 142       (let ((el-type (array-type-specialized-element-type array-type))
 143             (total-size (if (member '* dims)
 144                             '*
 145                             (reduce #'* dims))))
 146         `(data-vector-ref (truly-the (simple-array ,(type-specifier el-type)
 147                                                    (,total-size))
 148                                      (%array-data-vector array))
 149                           index)))))
 150
 151 ;;; Transform data vector access to a form that opens up optimization
 152 ;;; opportunities. On platforms that support DATA-VECTOR-REF-WITH-OFFSET
 153 ;;; DATA-VECTOR-REF is not supported at all.
 154 #!+(or x86 x86-64)
 155 (define-source-transform data-vector-ref (array index)
 156   `(data-vector-ref-with-offset ,array ,index 0))
 157
 158 #!+(or x86 x86-64)
 159 (deftransform data-vector-ref-with-offset ((array index offset))
 160   (let ((array-type (lvar-type array)))
 161     (when (or (not (array-type-p array-type))
 162               (eql (array-type-specialized-element-type array-type)
 163                    *wild-type*))
 164       (give-up-ir1-transform))
 165     ;; It shouldn't be possible to get here with anything but a non-complex
 166     ;; vector.
 167     (aver (not (array-type-complexp array-type)))
 168     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
 169            (saetp (find-saetp element-type)))
 170       (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
 171         (give-up-ir1-transform))
 172       (fold-index-addressing 'data-vector-ref-with-offset
 173                              (sb!vm:saetp-n-bits saetp)
 174                              sb!vm:other-pointer-lowtag
 175                              sb!vm:vector-data-offset
 176                              index offset))))
 177
 178 (deftransform hairy-data-vector-set ((string index new-value)
 179                                      (simple-string t t))
 180   (let ((ctype (lvar-type string)))
 181     (if (array-type-p ctype)
 182         ;; the other transform will kick in, so that's OK
 183         (give-up-ir1-transform)
 184         `(etypecase string
 185           ((simple-array character (*))
 186            (data-vector-set string index new-value))
 187           #!+sb-unicode
 188           ((simple-array base-char (*))
 189            (data-vector-set string index new-value))
 190           ((simple-array nil (*))
 191            (data-vector-set string index new-value))))))
 192
 193 ;;; This and the corresponding -REF transform work equally well on non-simple
 194 ;;; arrays, but after benchmarking (on x86), Nikodemus didn't find any cases
 195 ;;; where it actually helped with non-simple arrays -- to the contrary, it
 196 ;;; only made for bigger and up 1o 100% slower code.
 197 (deftransform hairy-data-vector-set ((array index new-value)
 198                                      (simple-array t t)
 199                                      *)
 200   "avoid runtime dispatch on array element type"
 201   (let* ((type (lvar-type array))
 202          (element-ctype (array-type-upgraded-element-type type))
 203          (declared-element-ctype (array-type-declared-element-type type)))
 204     (declare (type ctype element-ctype))
 205     (when (eq *wild-type* element-ctype)
 206       (give-up-ir1-transform
 207        "Upgraded element type of array is not known at compile time."))
 208     (let ((element-type-specifier (type-specifier element-ctype)))
 209       `(multiple-value-bind (array index)
 210            (%data-vector-and-index array index)
 211          (declare (type (simple-array ,element-type-specifier 1) array)
 212                   (type ,element-type-specifier new-value))
 213          ,(if (type= element-ctype declared-element-ctype)
 214               '(data-vector-set array index new-value)
 215               `(truly-the ,(type-specifier declared-element-ctype)
 216                  (data-vector-set array index
 217                   (the ,(type-specifier declared-element-ctype)
 218                        new-value))))))))
 219
 220 ;;; Transform multi-dimensional array to one dimensional data vector
 221 ;;; access.
 222 (deftransform data-vector-set ((array index new-value)
 223                                (simple-array t t))
 224   (let ((array-type (lvar-type array)))
 225     (unless (array-type-p array-type)
 226       (give-up-ir1-transform))
 227     (let ((dims (array-type-dimensions array-type)))
 228       (when (or (atom dims) (= (length dims) 1))
 229         (give-up-ir1-transform))
 230       (let ((el-type (array-type-specialized-element-type array-type))
 231             (total-size (if (member '* dims)
 232                             '*
 233                             (reduce #'* dims))))
 234         `(data-vector-set (truly-the (simple-array ,(type-specifier el-type)
 235                                                    (,total-size))
 236                                      (%array-data-vector array))
 237                           index
 238                           new-value)))))
 239
 240 ;;; Transform data vector access to a form that opens up optimization
 241 ;;; opportunities.
 242 #!+(or x86 x86-64)
 243 (define-source-transform data-vector-set (array index new-value)
 244   `(data-vector-set-with-offset ,array ,index 0 ,new-value))
 245
 246 #!+(or x86 x86-64)
 247 (deftransform data-vector-set-with-offset ((array index offset new-value))
 248   (let ((array-type (lvar-type array)))
 249     (when (or (not (array-type-p array-type))
 250               (eql (array-type-specialized-element-type array-type)
 251                    *wild-type*))
 252       ;; We don't yet know the exact element type, but will get that
 253       ;; knowledge after some more type propagation.
 254       (give-up-ir1-transform))
 255     (aver (not (array-type-complexp array-type)))
 256     (let* ((element-type (type-specifier (array-type-specialized-element-type array-type)))
 257            (saetp (find-saetp element-type)))
 258       (when (< (sb!vm:saetp-n-bits saetp) sb!vm:n-byte-bits)
 259         (give-up-ir1-transform))
 260       (fold-index-addressing 'data-vector-set-with-offset
 261                              (sb!vm:saetp-n-bits saetp)
 262                              sb!vm:other-pointer-lowtag
 263                              sb!vm:vector-data-offset
 264                              index offset t))))
 265
 266 (defun maybe-array-data-vector-type-specifier (array-lvar)
 267   (let ((atype (lvar-type array-lvar)))
 268     (when (array-type-p atype)
 269       (let ((dims (array-type-dimensions atype)))
 270         (if (or (array-type-complexp atype)
 271                 (eq '* dims)
 272                 (notevery #'integerp dims))
 273            `(simple-array ,(type-specifier
 274                             (array-type-specialized-element-type atype))
 275                           (*))
 276            `(simple-array ,(type-specifier
 277                             (array-type-specialized-element-type atype))
 278                           (,(apply #'* dims))))))))
 279
 280 (macrolet ((def (name)
 281              `(defoptimizer (,name derive-type) ((array-lvar))
 282                 (let ((spec (maybe-array-data-vector-type-specifier array-lvar)))
 283                   (when spec
 284                     (specifier-type spec))))))
 285   (def %array-data-vector)
 286   (def array-storage-vector))
 287
 288 (defoptimizer (%data-vector-and-index derive-type) ((array index))
 289   (let ((spec (maybe-array-data-vector-type-specifier array)))
 290     (when spec
 291       (values-specifier-type `(values ,spec index)))))
 292
 293 (deftransform %data-vector-and-index ((%array %index)
 294                                       (simple-array t)
 295                                       *)
 296   ;; KLUDGE: why the percent signs?  Well, ARRAY and INDEX are
 297   ;; respectively exported from the CL and SB!INT packages, which
 298   ;; means that they're visible to all sorts of things.  If the
 299   ;; compiler can prove that the call to ARRAY-HEADER-P, below, either
 300   ;; returns T or NIL, it will delete the irrelevant branch.  However,
 301   ;; user code might have got here with a variable named CL:ARRAY, and
 302   ;; quite often compiler code with a variable named SB!INT:INDEX, so
 303   ;; this can generate code deletion notes for innocuous user code:
 304   ;; (DEFUN F (ARRAY I) (DECLARE (SIMPLE-VECTOR ARRAY)) (AREF ARRAY I))
 305   ;; -- CSR, 2003-04-01
 306
 307   ;; We do this solely for the -OR-GIVE-UP side effect, since we want
 308   ;; to know that the type can be figured out in the end before we
 309   ;; proceed, but we don't care yet what the type will turn out to be.
 310   (upgraded-element-type-specifier-or-give-up %array)
 311
 312   '(if (array-header-p %array)
 313        (values (%array-data-vector %array) %index)
 314        (values %array %index)))
 315 \f
 316 ;;;; BIT-VECTOR hackery
 317
 318 ;;; SIMPLE-BIT-VECTOR bit-array operations are transformed to a word
 319 ;;; loop that does 32 bits at a time.
 320 ;;;
 321 ;;; FIXME: This is a lot of repeatedly macroexpanded code. It should
 322 ;;; be a function call instead.
 323 (macrolet ((def (bitfun wordfun)
 324              `(deftransform ,bitfun ((bit-array-1 bit-array-2 result-bit-array)
 325                                      (simple-bit-vector
 326                                       simple-bit-vector
 327                                       simple-bit-vector)
 328                                      *
 329                                      :node node :policy (>= speed space))
 330                 `(progn
 331                    ,@(unless (policy node (zerop safety))
 332                              '((unless (= (length bit-array-1)
 333                                           (length bit-array-2)
 334                                           (length result-bit-array))
 335                                  (error "Argument and/or result bit arrays are not the same length:~
 336                          ~%  ~S~%  ~S  ~%  ~S"
 337                                         bit-array-1
 338                                         bit-array-2
 339                                         result-bit-array))))
 340                   (let ((length (length result-bit-array)))
 341                     (if (= length 0)
 342                         ;; We avoid doing anything to 0-length
 343                         ;; bit-vectors, or rather, the memory that
 344                         ;; follows them. Other divisible-by-32 cases
 345                         ;; are handled by the (1- length), below.
 346                         ;; CSR, 2002-04-24
 347                         result-bit-array
 348                         (do ((index 0 (1+ index))
 349                              ;; bit-vectors of length 1-32 need
 350                              ;; precisely one (SETF %VECTOR-RAW-BITS),
 351                              ;; done here in the epilogue. - CSR,
 352                              ;; 2002-04-24
 353                              (end-1 (truncate (truly-the index (1- length))
 354                                               sb!vm:n-word-bits)))
 355                             ((>= index end-1)
 356                              (setf (%vector-raw-bits result-bit-array index)
 357                                    (,',wordfun (%vector-raw-bits bit-array-1 index)
 358                                                (%vector-raw-bits bit-array-2 index)))
 359                              result-bit-array)
 360                           (declare (optimize (speed 3) (safety 0))
 361                                    (type index index end-1))
 362                           (setf (%vector-raw-bits result-bit-array index)
 363                                 (,',wordfun (%vector-raw-bits bit-array-1 index)
 364                                             (%vector-raw-bits bit-array-2 index))))))))))
 365  (def bit-and word-logical-and)
 366  (def bit-ior word-logical-or)
 367  (def bit-xor word-logical-xor)
 368  (def bit-eqv word-logical-eqv)
 369  (def bit-nand word-logical-nand)
 370  (def bit-nor word-logical-nor)
 371  (def bit-andc1 word-logical-andc1)
 372  (def bit-andc2 word-logical-andc2)
 373  (def bit-orc1 word-logical-orc1)
 374  (def bit-orc2 word-logical-orc2))
 375
 376 (deftransform bit-not
 377               ((bit-array result-bit-array)
 378                (simple-bit-vector simple-bit-vector) *
 379                :node node :policy (>= speed space))
 380   `(progn
 381      ,@(unless (policy node (zerop safety))
 382          '((unless (= (length bit-array)
 383                       (length result-bit-array))
 384              (error "Argument and result bit arrays are not the same length:~
 385                      ~%  ~S~%  ~S"
 386                     bit-array result-bit-array))))
 387     (let ((length (length result-bit-array)))
 388       (if (= length 0)
 389           ;; We avoid doing anything to 0-length bit-vectors, or rather,
 390           ;; the memory that follows them. Other divisible-by
 391           ;; n-word-bits cases are handled by the (1- length), below.
 392           ;; CSR, 2002-04-24
 393           result-bit-array
 394           (do ((index 0 (1+ index))
 395                ;; bit-vectors of length 1 to n-word-bits need precisely
 396                ;; one (SETF %VECTOR-RAW-BITS), done here in the
 397                ;; epilogue. - CSR, 2002-04-24
 398                (end-1 (truncate (truly-the index (1- length))
 399                                 sb!vm:n-word-bits)))
 400               ((>= index end-1)
 401                (setf (%vector-raw-bits result-bit-array index)
 402                      (word-logical-not (%vector-raw-bits bit-array index)))
 403                result-bit-array)
 404             (declare (optimize (speed 3) (safety 0))
 405                      (type index index end-1))
 406             (setf (%vector-raw-bits result-bit-array index)
 407                   (word-logical-not (%vector-raw-bits bit-array index))))))))
 408
 409 (deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
 410   `(and (= (length x) (length y))
 411         (let ((length (length x)))
 412           (or (= length 0)
 413               (do* ((i 0 (+ i 1))
 414                     (end-1 (floor (1- length) sb!vm:n-word-bits)))
 415                    ((>= i end-1)
 416                     (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
 417                            (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
 418                                       (- extra sb!vm:n-word-bits)))
 419                            (numx
 420                             (logand
 421                              (ash mask
 422                                   ,(ecase sb!c:*backend-byte-order*
 423                                      (:little-endian 0)
 424                                      (:big-endian
 425                                       '(- sb!vm:n-word-bits extra))))
 426                              (%vector-raw-bits x i)))
 427                            (numy
 428                             (logand
 429                              (ash mask
 430                                   ,(ecase sb!c:*backend-byte-order*
 431                                      (:little-endian 0)
 432                                      (:big-endian
 433                                       '(- sb!vm:n-word-bits extra))))
 434                              (%vector-raw-bits y i))))
 435                       (declare (type (integer 1 #.sb!vm:n-word-bits) extra)
 436                                (type sb!vm:word mask numx numy))
 437                       (= numx numy)))
 438                 (declare (type index i end-1))
 439                 (let ((numx (%vector-raw-bits x i))
 440                       (numy (%vector-raw-bits y i)))
 441                   (declare (type sb!vm:word numx numy))
 442                   (unless (= numx numy)
 443                     (return nil))))))))
 444
 445 (deftransform count ((item sequence) (bit simple-bit-vector) *
 446                      :policy (>= speed space))
 447   `(let ((length (length sequence)))
 448     (if (zerop length)
 449         0
 450         (do ((index 0 (1+ index))
 451              (count 0)
 452              (end-1 (truncate (truly-the index (1- length))
 453                               sb!vm:n-word-bits)))
 454             ((>= index end-1)
 455              (let* ((extra (1+ (mod (1- length) sb!vm:n-word-bits)))
 456                     (mask (ash #.(1- (ash 1 sb!vm:n-word-bits))
 457                                (- extra sb!vm:n-word-bits)))
 458                     (bits (logand (ash mask
 459                                        ,(ecase sb!c:*backend-byte-order*
 460                                                (:little-endian 0)
 461                                                (:big-endian
 462                                                 '(- sb!vm:n-word-bits extra))))
 463                                   (%vector-raw-bits sequence index))))
 464                (declare (type (integer 1 #.sb!vm:n-word-bits) extra))
 465                (declare (type sb!vm:word mask bits))
 466                (incf count (logcount bits))
 467                ,(if (constant-lvar-p item)
 468                     (if (zerop (lvar-value item))
 469                         '(- length count)
 470                         'count)
 471                     '(if (zerop item)
 472                          (- length count)
 473                          count))))
 474           (declare (type index index count end-1)
 475                    (optimize (speed 3) (safety 0)))
 476           (incf count (logcount (%vector-raw-bits sequence index)))))))
 477
 478 (deftransform fill ((sequence item) (simple-bit-vector bit) *
 479                     :policy (>= speed space))
 480   (let ((value (if (constant-lvar-p item)
 481                    (if (= (lvar-value item) 0)
 482                        0
 483                        #.(1- (ash 1 sb!vm:n-word-bits)))
 484                    `(if (= item 0) 0 #.(1- (ash 1 sb!vm:n-word-bits))))))
 485     `(let ((length (length sequence))
 486            (value ,value))
 487        (if (= length 0)
 488            sequence
 489            (do ((index 0 (1+ index))
 490                 ;; bit-vectors of length 1 to n-word-bits need precisely
 491                 ;; one (SETF %VECTOR-RAW-BITS), done here in the
 492                 ;; epilogue. - CSR, 2002-04-24
 493                 (end-1 (truncate (truly-the index (1- length))
 494                                  sb!vm:n-word-bits)))
 495                ((>= index end-1)
 496                 (setf (%vector-raw-bits sequence index) value)
 497                 sequence)
 498              (declare (optimize (speed 3) (safety 0))
 499                       (type index index end-1))
 500              (setf (%vector-raw-bits sequence index) value))))))
 501
 502 (deftransform fill ((sequence item) (simple-base-string base-char) *
 503                     :policy (>= speed space))
 504   (let ((value (if (constant-lvar-p item)
 505                    (let* ((char (lvar-value item))
 506                           (code (sb!xc:char-code char))
 507                           (accum 0))
 508                      (dotimes (i sb!vm:n-word-bytes accum)
 509                        (setf accum (logior accum (ash code (* 8 i))))))
 510                    `(let ((code (sb!xc:char-code item)))
 511                      (logior ,@(loop for i from 0 below sb!vm:n-word-bytes
 512                                      collect `(ash code ,(* 8 i))))))))
 513     `(let ((length (length sequence))
 514            (value ,value))
 515       (multiple-value-bind (times rem)
 516           (truncate length sb!vm:n-word-bytes)
 517         (do ((index 0 (1+ index))
 518              (end times))
 519             ((>= index end)
 520              (let ((place (* times sb!vm:n-word-bytes)))
 521                (declare (fixnum place))
 522                (dotimes (j rem sequence)
 523                  (declare (index j))
 524                  (setf (schar sequence (the index (+ place j))) item))))
 525           (declare (optimize (speed 3) (safety 0))
 526                    (type index index))
 527           (setf (%vector-raw-bits sequence index) value))))))
 528 \f
 529 ;;;; %BYTE-BLT
 530
 531 ;;; FIXME: The old CMU CL code used various COPY-TO/FROM-SYSTEM-AREA
 532 ;;; stuff (with all the associated bit-index cruft and overflow
 533 ;;; issues) even for byte moves. In SBCL, we're converting to byte
 534 ;;; moves as problems are discovered with the old code, and this is
 535 ;;; currently (ca. sbcl-0.6.12.30) the main interface for code in
 536 ;;; SB!KERNEL and SB!SYS (e.g. i/o code). It's not clear that it's the
 537 ;;; ideal interface, though, and it probably deserves some thought.
 538 (deftransform %byte-blt ((src src-start dst dst-start dst-end)
 539                          ((or (simple-unboxed-array (*)) system-area-pointer)
 540                           index
 541                           (or (simple-unboxed-array (*)) system-area-pointer)
 542                           index
 543                           index))
 544   ;; FIXME: CMU CL had a hairier implementation of this (back when it
 545   ;; was still called (%PRIMITIVE BYTE-BLT). It had the small problem
 546   ;; that it didn't work for large (>16M) values of SRC-START or
 547   ;; DST-START. However, it might have been more efficient. In
 548   ;; particular, I don't really know how much the foreign function
 549   ;; call costs us here. My guess is that if the overhead is
 550   ;; acceptable for SQRT and COS, it's acceptable here, but this
 551   ;; should probably be checked. -- WHN
 552   '(flet ((sapify (thing)
 553             (etypecase thing
 554               (system-area-pointer thing)
 555               ;; FIXME: The code here rather relies on the simple
 556               ;; unboxed array here having byte-sized entries. That
 557               ;; should be asserted explicitly, I just haven't found
 558               ;; a concise way of doing it. (It would be nice to
 559               ;; declare it in the DEFKNOWN too.)
 560               ((simple-unboxed-array (*)) (vector-sap thing)))))
 561      (declare (inline sapify))
 562     (with-pinned-objects (dst src)
 563       (memmove (sap+ (sapify dst) dst-start)
 564                (sap+ (sapify src) src-start)
 565                (- dst-end dst-start)))
 566      (values)))
 567 \f
 568 ;;;; transforms for EQL of floating point values
 569 #!-float-eql-vops
 570 (deftransform eql ((x y) (single-float single-float))
 571   '(= (single-float-bits x) (single-float-bits y)))
 572
 573 #!-float-eql-vops
 574 (deftransform eql ((x y) (double-float double-float))
 575   '(and (= (double-float-low-bits x) (double-float-low-bits y))
 576         (= (double-float-high-bits x) (double-float-high-bits y))))
 577
 578 \f
 579 ;;;; modular functions
 580 ;;;
 581 ;;; FIXME: I think that the :GOODness of a modular function boils down
 582 ;;; to whether the normal definition can be used in the middle of a
 583 ;;; modular arrangement.  LOGAND and LOGIOR can be for all unsigned
 584 ;;; modular implementations, I believe, because for all unsigned
 585 ;;; arguments of a given size the result of the ordinary definition is
 586 ;;; the right one.  This should follow through to other logical
 587 ;;; functions, such as LOGXOR, should it not?  -- CSR, 2007-12-29,
 588 ;;; trying to understand a comment he wrote over four years
 589 ;;; previously: "FIXME: XOR? ANDC1, ANDC2?  -- CSR, 2003-09-16"
 590 (define-good-modular-fun logand :untagged nil)
 591 (define-good-modular-fun logior :untagged nil)
 592 (define-good-modular-fun logxor :untagged nil)
 593 (macrolet ((define-good-signed-modular-funs (&rest funs)
 594              (let (result)
 595                `(progn
 596                  ,@(dolist (fun funs (nreverse result))
 597                      (push `(define-good-modular-fun ,fun :untagged t) result)
 598                      (push `(define-good-modular-fun ,fun :tagged t) result))))))
 599   (define-good-signed-modular-funs
 600       logand logandc1 logandc2 logeqv logior lognand lognor lognot
 601       logorc1 logorc2 logxor))
 602
 603 (macrolet
 604     ((def (name kind width signedp)
 605        (let ((type (ecase signedp
 606                      ((nil) 'unsigned-byte)
 607                      ((t) 'signed-byte))))
 608          `(progn
 609             (defknown ,name (integer (integer 0)) (,type ,width)
 610                       (foldable flushable movable))
 611             (define-modular-fun-optimizer ash ((integer count) ,kind ,signedp :width width)
 612               (when (and (<= width ,width)
 613                          (or (and (constant-lvar-p count)
 614                                   (plusp (lvar-value count)))
 615                              (csubtypep (lvar-type count)
 616                                         (specifier-type '(and unsigned-byte fixnum)))))
 617                 (cut-to-width integer ,kind width ,signedp)
 618                 ',name))
 619             (setf (gethash ',name (modular-class-versions (find-modular-class ',kind ',signedp)))
 620                   `(ash ,',width))))))
 621   ;; This should really be dependent on SB!VM:N-WORD-BITS, but since we
 622   ;; don't have a true Alpha64 port yet, we'll have to stick to
 623   ;; SB!VM:N-MACHINE-WORD-BITS for the time being.  --njf, 2004-08-14
 624   #.`(progn
 625        #!+(or x86 x86-64)
 626        (def sb!vm::ash-left-modfx
 627            :tagged ,(- sb!vm:n-word-bits sb!vm:n-fixnum-tag-bits) t)
 628        (def ,(intern (format nil "ASH-LEFT-MOD~D" sb!vm:n-machine-word-bits)
 629                      "SB!VM")
 630            :untagged ,sb!vm:n-machine-word-bits nil)))
 631 \f
 632 ;;;; word-wise logical operations
 633
 634 ;;; These transforms assume the presence of modular arithmetic to
 635 ;;; generate efficient code.
 636
 637 (define-source-transform word-logical-not (x)
 638   `(logand (lognot (the sb!vm:word ,x)) #.(1- (ash 1 sb!vm:n-word-bits))))
 639
 640 (deftransform word-logical-and ((x y))
 641   '(logand x y))
 642
 643 (deftransform word-logical-nand ((x y))
 644   '(logand (lognand x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 645
 646 (deftransform word-logical-or ((x y))
 647   '(logior x y))
 648
 649 (deftransform word-logical-nor ((x y))
 650   '(logand (lognor x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 651
 652 (deftransform word-logical-xor ((x y))
 653   '(logxor x y))
 654
 655 (deftransform word-logical-eqv ((x y))
 656   '(logand (logeqv x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 657
 658 (deftransform word-logical-orc1 ((x y))
 659   '(logand (logorc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 660
 661 (deftransform word-logical-orc2 ((x y))
 662   '(logand (logorc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 663
 664 (deftransform word-logical-andc1 ((x y))
 665   '(logand (logandc1 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 666
 667 (deftransform word-logical-andc2 ((x y))
 668   '(logand (logandc2 x y) #.(1- (ash 1 sb!vm:n-word-bits))))
 669
 670 \f
 671 ;;; There are two different ways the multiplier can be recoded. The
 672 ;;; more obvious is to shift X by the correct amount for each bit set
 673 ;;; in Y and to sum the results. But if there is a string of bits that
 674 ;;; are all set, you can add X shifted by one more then the bit
 675 ;;; position of the first set bit and subtract X shifted by the bit
 676 ;;; position of the last set bit. We can't use this second method when
 677 ;;; the high order bit is bit 31 because shifting by 32 doesn't work
 678 ;;; too well.
 679 (defun ub32-strength-reduce-constant-multiply (arg num)
 680   (declare (type (unsigned-byte 32) num))
 681   (let ((adds 0) (shifts 0)
 682         (result nil) first-one)
 683     (labels ((add (next-factor)
 684                (setf result
 685                      (if result
 686                          (progn (incf adds) `(+ ,result ,next-factor))
 687                          next-factor))))
 688       (declare (inline add))
 689       (dotimes (bitpos 32)
 690         (if first-one
 691             (when (not (logbitp bitpos num))
 692               (add (if (= (1+ first-one) bitpos)
 693                        ;; There is only a single bit in the string.
 694                        (progn (incf shifts) `(ash ,arg ,first-one))
 695                        ;; There are at least two.
 696                        (progn
 697                          (incf adds)
 698                          (incf shifts 2)
 699                          `(- (ash ,arg ,bitpos)
 700                              (ash ,arg ,first-one)))))
 701               (setf first-one nil))
 702             (when (logbitp bitpos num)
 703               (setf first-one bitpos))))
 704       (when first-one
 705         (cond ((= first-one 31))
 706               ((= first-one 30) (incf shifts) (add `(ash ,arg 30)))
 707               (t
 708                (incf shifts 2)
 709                (incf adds)
 710                (add `(- (ash ,arg 31)
 711                         (ash ,arg ,first-one)))))
 712         (incf shifts)
 713         (add `(ash ,arg 31))))
 714     (values (if (plusp adds)
 715                 `(logand ,result #.(1- (ash 1 32))) ; using modular arithmetic
 716                 result)
 717             adds
 718             shifts)))
 719
 720 \f
 721 ;;; Transform GET-LISP-OBJ-ADDRESS for constant immediates, since the normal
 722 ;;; VOP can't handle them.
 723
 724 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg fixnum)))
 725   (ash (lvar-value obj) sb!vm::n-fixnum-tag-bits))
 726
 727 (deftransform sb!vm::get-lisp-obj-address ((obj) ((constant-arg character)))
 728   (logior sb!vm::character-widetag
 729           (ash (char-code (lvar-value obj)) sb!vm::n-widetag-bits)))