src/compiler/x86-64/array.lisp

   1 ;;;; array operations for the x86 VM
   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!VM")
  13 \f
  14
  15 ;; For use in constant indexing; we can't use INDEX since the displacement
  16 ;; field of an EA can't contain 64 bit values.
  17 (def!type low-index () '(signed-byte 29))
  18
  19 ;;;; allocator for the array header
  20
  21 (define-vop (make-array-header)
  22   (:translate make-array-header)
  23   (:policy :fast-safe)
  24   (:args (type :scs (any-reg))
  25          (rank :scs (any-reg)))
  26   (:arg-types positive-fixnum positive-fixnum)
  27   (:temporary (:sc any-reg :to :eval) bytes)
  28   (:temporary (:sc any-reg :to :result) header)
  29   (:results (result :scs (descriptor-reg) :from :eval))
  30   (:node-var node)
  31   (:generator 13
  32     (inst lea bytes
  33           (make-ea :qword
  34                    :index rank :scale (ash 1 (- word-shift n-fixnum-tag-bits))
  35                    :disp (+ (* array-dimensions-offset n-word-bytes)
  36                             lowtag-mask)))
  37     (inst and bytes (lognot lowtag-mask))
  38     (inst lea header (make-ea :qword :base rank
  39                               :disp (fixnumize (1- array-dimensions-offset))))
  40     (inst shl header n-widetag-bits)
  41     (inst or  header type)
  42     (inst shr header n-fixnum-tag-bits)
  43     (pseudo-atomic
  44      (allocation result bytes node nil other-pointer-lowtag)
  45      (storew header result 0 other-pointer-lowtag))))
  46
  47 (define-vop (make-array-header/c)
  48   (:translate make-array-header)
  49   (:policy :fast-safe)
  50   (:arg-types (:constant t) (:constant t))
  51   (:info type rank)
  52   (:results (result :scs (descriptor-reg) :from :eval))
  53   (:node-var node)
  54   (:generator 12
  55     (let* ((header-size (+ rank
  56                            (1- array-dimensions-offset)))
  57            (bytes (logandc2 (+ (* (1+ header-size) n-word-bytes)
  58                                lowtag-mask)
  59                             lowtag-mask))
  60            (header (logior (ash header-size
  61                                 n-widetag-bits)
  62                            type)))
  63      (pseudo-atomic
  64       (allocation result bytes node nil other-pointer-lowtag)
  65       (storew header result 0 other-pointer-lowtag)))))
  66
  67 \f
  68 ;;;; additional accessors and setters for the array header
  69 (define-full-reffer %array-dimension *
  70   array-dimensions-offset other-pointer-lowtag
  71   (any-reg) positive-fixnum %array-dimension)
  72
  73 (define-full-setter %set-array-dimension *
  74   array-dimensions-offset other-pointer-lowtag
  75   (any-reg) positive-fixnum %set-array-dimension)
  76
  77 (define-vop (array-rank-vop)
  78   (:translate %array-rank)
  79   (:policy :fast-safe)
  80   (:args (x :scs (descriptor-reg)))
  81   (:results (res :scs (unsigned-reg)))
  82   (:result-types positive-fixnum)
  83   (:generator 3
  84     ;; An unaligned dword read not spanning a 16-byte boundary is as fast as
  85     ;; and shorter by 5 bytes than a qword read and right-shift by 8.
  86     (inst mov (reg-in-size res :dword)
  87           (make-ea :dword :base x :disp (1+ (- other-pointer-lowtag))))
  88     (inst sub (reg-in-size res :dword) (1- array-dimensions-offset))))
  89
  90 (define-vop (array-rank-vop=>fixnum)
  91   (:translate %array-rank)
  92   (:policy :fast-safe)
  93   (:args (x :scs (descriptor-reg)))
  94   (:results (res :scs (any-reg)))
  95   (:result-types positive-fixnum)
  96   (:generator 2
  97     (inst mov (reg-in-size res :dword)
  98           (make-ea :dword :base x :disp (1+ (- other-pointer-lowtag))))
  99     (inst lea (reg-in-size res :dword)
 100           (let ((scale (ash 1 n-fixnum-tag-bits)))
 101             ;; Compute [res*N-disp]. for N=2 use [res+res-disp]
 102             (make-ea :dword
 103                      :scale (if (= scale 2) 1 scale)
 104                      :index res
 105                      :base (if (= scale 2) res nil)
 106                      :disp (- (* scale (1- array-dimensions-offset))))))))
 107 \f
 108 ;;;; bounds checking routine
 109
 110 ;;; Note that the immediate SC for the index argument is disabled
 111 ;;; because it is not possible to generate a valid error code SC for
 112 ;;; an immediate value.
 113 ;;;
 114 ;;; FIXME: As per the KLUDGE note explaining the :IGNORE-FAILURE-P
 115 ;;; flag in build-order.lisp-expr, compiling this file causes warnings
 116 ;;;    Argument FOO to VOP CHECK-BOUND has SC restriction
 117 ;;;    DESCRIPTOR-REG which is not allowed by the operand type:
 118 ;;;      (:OR POSITIVE-FIXNUM)
 119 ;;; CSR's message "format ~/ /" on sbcl-devel 2002-03-12 contained
 120 ;;; a possible patch, described as
 121 ;;;   Another patch is included more for information than anything --
 122 ;;;   removing the descriptor-reg SCs from the CHECK-BOUND vop in
 123 ;;;   x86/array.lisp seems to allow that file to compile without error[*],
 124 ;;;   and build; I haven't tested rebuilding capability, but I'd be
 125 ;;;   surprised if there were a problem.  I'm not certain that this is the
 126 ;;;   correct fix, though, as the restrictions on the arguments to the VOP
 127 ;;;   aren't the same as in the sparc and alpha ports, where, incidentally,
 128 ;;;   the corresponding file builds without error currently.
 129 ;;; Since neither of us (CSR or WHN) was quite sure that this is the
 130 ;;; right thing, I've just recorded the patch here in hopes it might
 131 ;;; help when someone attacks this problem again:
 132 ;;;   diff -u -r1.7 array.lisp
 133 ;;;   --- src/compiler/x86/array.lisp 11 Oct 2001 14:05:26 -0000      1.7
 134 ;;;   +++ src/compiler/x86/array.lisp 12 Mar 2002 12:23:37 -0000
 135 ;;;   @@ -76,10 +76,10 @@
 136 ;;;      (:translate %check-bound)
 137 ;;;      (:policy :fast-safe)
 138 ;;;      (:args (array :scs (descriptor-reg))
 139 ;;;   -        (bound :scs (any-reg descriptor-reg))
 140 ;;;   -        (index :scs (any-reg descriptor-reg #+nil immediate) :target result))
 141 ;;;   +        (bound :scs (any-reg))
 142 ;;;   +        (index :scs (any-reg #+nil immediate) :target result))
 143 ;;;      (:arg-types * positive-fixnum tagged-num)
 144 ;;;   -  (:results (result :scs (any-reg descriptor-reg)))
 145 ;;;   +  (:results (result :scs (any-reg)))
 146 ;;;      (:result-types positive-fixnum)
 147 ;;;      (:vop-var vop)
 148 ;;;      (:save-p :compute-only)
 149 (define-vop (check-bound)
 150   (:translate %check-bound)
 151   (:policy :fast-safe)
 152   (:args (array :scs (descriptor-reg))
 153          (bound :scs (any-reg descriptor-reg))
 154          (index :scs (any-reg descriptor-reg)))
 155   ;(:arg-types * positive-fixnum *)
 156   (:variant-vars %test-fixnum)
 157   (:variant t)
 158   (:vop-var vop)
 159   (:save-p :compute-only)
 160   (:generator 5
 161     (let ((error (generate-error-code vop 'invalid-array-index-error
 162                                       array bound index))
 163           (index (if (sc-is index immediate)
 164                      (fixnumize (tn-value index))
 165                      index)))
 166       (when (and %test-fixnum (not (integerp index)))
 167         (%test-fixnum index error t))
 168       (inst cmp bound index)
 169       ;; We use below-or-equal even though it's an unsigned test,
 170       ;; because negative indexes appear as large unsigned numbers.
 171       ;; Therefore, we get the <0 and >=bound test all rolled into one.
 172       (inst jmp :be error))))
 173 (define-vop (check-bound/fast check-bound)
 174   (:policy :fast)
 175   (:variant nil)
 176   (:variant-cost 4))
 177 \f
 178 ;;;; accessors/setters
 179
 180 ;;; variants built on top of WORD-INDEX-REF, etc. I.e., those vectors
 181 ;;; whose elements are represented in integer registers and are built
 182 ;;; out of 8, 16, or 32 bit elements.
 183 (macrolet ((def-full-data-vector-frobs (type element-type &rest scs)
 184              `(progn
 185                 (define-full-reffer+offset
 186                   ,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" type)
 187                   ,type vector-data-offset other-pointer-lowtag ,scs
 188                   ,element-type data-vector-ref-with-offset)
 189                 (define-full-setter+offset
 190                   ,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" type)
 191                   ,type vector-data-offset other-pointer-lowtag ,scs
 192                   ,element-type data-vector-set-with-offset)))
 193            )
 194   (def-full-data-vector-frobs simple-vector * descriptor-reg any-reg)
 195   (def-full-data-vector-frobs simple-array-unsigned-byte-64 unsigned-num
 196     unsigned-reg)
 197   (def-full-data-vector-frobs simple-array-fixnum tagged-num any-reg)
 198   (def-full-data-vector-frobs simple-array-unsigned-fixnum
 199       positive-fixnum any-reg)
 200   (def-full-data-vector-frobs simple-array-signed-byte-64
 201       signed-num signed-reg)
 202   (def-full-data-vector-frobs simple-array-unsigned-byte-63 unsigned-num
 203     unsigned-reg))
 204
 205 (define-full-compare-and-swap %compare-and-swap-svref simple-vector
 206   vector-data-offset other-pointer-lowtag
 207   (descriptor-reg any-reg) *
 208   %compare-and-swap-svref)
 209 \f
 210 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 211 ;;;; bit, 2-bit, and 4-bit vectors
 212
 213 (define-vop (data-vector-ref-with-offset/simple-bit-vector-c)
 214   (:translate data-vector-ref-with-offset)
 215   (:policy :fast-safe)
 216   (:args (object :scs (descriptor-reg)))
 217   (:arg-types simple-bit-vector
 218               ;; this constant is possibly off by something
 219               ;; but (sbit n <huge-constant>) is unlikely to appear in code
 220               (:constant (integer 0 #x3ffffffff)) (:constant (integer 0 0)))
 221   (:info index offset)
 222   (:ignore offset)
 223   (:results (result :scs (any-reg)))
 224   (:result-types positive-fixnum)
 225   (:generator 3
 226     ;; using 32-bit operand size might elide the REX prefix on mov + shift
 227     (multiple-value-bind (dword-index bit) (floor index 32)
 228       (inst mov (reg-in-size result :dword)
 229                 (make-ea :dword :base object
 230                          :disp (+ (* dword-index 4)
 231                                   (- (* vector-data-offset n-word-bytes)
 232                                      other-pointer-lowtag))))
 233       (let ((right-shift (- bit n-fixnum-tag-bits)))
 234         (cond ((plusp right-shift)
 235                (inst shr (reg-in-size result :dword) right-shift))
 236               ((minusp right-shift) ; = left shift
 237                (inst shl (reg-in-size result :dword) (- right-shift))))))
 238     (inst and (reg-in-size result :dword) (fixnumize 1))))
 239
 240 (define-vop (data-vector-ref-with-offset/simple-bit-vector)
 241   (:translate data-vector-ref-with-offset)
 242   (:policy :fast-safe)
 243   (:args (object :scs (descriptor-reg))
 244          (index :scs (unsigned-reg)))
 245   (:info offset)
 246   (:ignore offset)
 247   (:arg-types simple-bit-vector positive-fixnum (:constant (integer 0 0)))
 248   (:results (result :scs (any-reg)))
 249   (:result-types positive-fixnum)
 250   (:generator 4
 251     (inst bt (make-ea :qword :base object
 252                       :disp (- (* vector-data-offset n-word-bytes)
 253                                other-pointer-lowtag))
 254              index)
 255     (inst sbb (reg-in-size result :dword) (reg-in-size result :dword))
 256     (inst and (reg-in-size result :dword) (fixnumize 1))))
 257
 258 (macrolet ((def-small-data-vector-frobs (type bits)
 259              (let* ((elements-per-word (floor n-word-bits bits))
 260                     (bit-shift (1- (integer-length elements-per-word))))
 261     `(progn
 262       ,@(unless (= bits 1)
 263        `((define-vop (,(symbolicate 'data-vector-ref-with-offset/ type))
 264          (:note "inline array access")
 265          (:translate data-vector-ref-with-offset)
 266          (:policy :fast-safe)
 267          (:args (object :scs (descriptor-reg))
 268                 (index :scs (unsigned-reg)))
 269          (:info offset)
 270          (:arg-types ,type positive-fixnum (:constant (integer 0 0)))
 271          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 272          (:result-types positive-fixnum)
 273          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 274          (:generator 20
 275            (aver (zerop offset))
 276            (move ecx index)
 277            (inst shr ecx ,bit-shift)
 278            (inst mov result
 279                  (make-ea :qword :base object :index ecx :scale n-word-bytes
 280                           :disp (- (* vector-data-offset n-word-bytes)
 281                                    other-pointer-lowtag)))
 282            (move ecx index)
 283            ;; We used to mask ECX for all values of BITS, but since
 284            ;; Intel's documentation says that the chip will mask shift
 285            ;; and rotate counts by 63 automatically, we can safely move
 286            ;; the masking operation under the protection of this UNLESS
 287            ;; in the bit-vector case.  --njf, 2006-07-14
 288            ,@(unless (= bits 1)
 289                `((inst and ecx ,(1- elements-per-word))
 290                  (inst shl ecx ,(1- (integer-length bits)))))
 291            (inst shr result :cl)
 292            (inst and result ,(1- (ash 1 bits)))))
 293        (define-vop (,(symbolicate 'data-vector-ref-with-offset/ type "-C"))
 294          (:translate data-vector-ref-with-offset)
 295          (:policy :fast-safe)
 296          (:args (object :scs (descriptor-reg)))
 297          (:arg-types ,type (:constant low-index) (:constant (integer 0 0)))
 298          (:info index offset)
 299          (:results (result :scs (unsigned-reg)))
 300          (:result-types positive-fixnum)
 301          (:generator 15
 302            (aver (zerop offset))
 303            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 304              (loadw result object (+ word vector-data-offset)
 305                     other-pointer-lowtag)
 306              (unless (zerop extra)
 307                (inst shr result (* extra ,bits)))
 308              (unless (= extra ,(1- elements-per-word))
 309                (inst and result ,(1- (ash 1 bits)))))))))
 310        (define-vop (,(symbolicate 'data-vector-set-with-offset/ type))
 311          (:note "inline array store")
 312          (:translate data-vector-set-with-offset)
 313          (:policy :fast-safe)
 314          (:args (object :scs (descriptor-reg))
 315                 (index :scs (unsigned-reg) :target ecx)
 316                 (value :scs (unsigned-reg immediate) :target result))
 317          (:info offset)
 318          (:arg-types ,type positive-fixnum (:constant (integer 0 0))
 319                      positive-fixnum)
 320          (:results (result :scs (unsigned-reg)))
 321          (:result-types positive-fixnum)
 322          (:temporary (:sc unsigned-reg) word-index)
 323          (:temporary (:sc unsigned-reg) old)
 324          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 325          (:generator 25
 326            (aver (zerop offset))
 327            (move word-index index)
 328            (inst shr word-index ,bit-shift)
 329            (inst mov old
 330                  (make-ea :qword :base object :index word-index
 331                           :scale n-word-bytes
 332                           :disp (- (* vector-data-offset n-word-bytes)
 333                                    other-pointer-lowtag)))
 334            (move ecx index)
 335            ;; We used to mask ECX for all values of BITS, but since
 336            ;; Intel's documentation says that the chip will mask shift
 337            ;; and rotate counts by 63 automatically, we can safely move
 338            ;; the masking operation under the protection of this UNLESS
 339            ;; in the bit-vector case.  --njf, 2006-07-14
 340            ,@(unless (= bits 1)
 341                `((inst and ecx ,(1- elements-per-word))
 342                  (inst shl ecx ,(1- (integer-length bits)))))
 343            (inst ror old :cl)
 344            (unless (and (sc-is value immediate)
 345                         (= (tn-value value) ,(1- (ash 1 bits))))
 346              (inst and old ,(lognot (1- (ash 1 bits)))))
 347            (sc-case value
 348              (immediate
 349               (unless (zerop (tn-value value))
 350                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
 351              (unsigned-reg
 352               (inst or old value)))
 353            (inst rol old :cl)
 354            (inst mov (make-ea :qword :base object :index word-index
 355                               :scale n-word-bytes
 356                               :disp (- (* vector-data-offset n-word-bytes)
 357                                        other-pointer-lowtag))
 358                  old)
 359            (sc-case value
 360              (immediate
 361               (inst mov result (tn-value value)))
 362              (unsigned-reg
 363               (move result value)))))
 364        (define-vop (,(symbolicate 'data-vector-set-with-offset/ type "-C"))
 365          (:translate data-vector-set-with-offset)
 366          (:policy :fast-safe)
 367          (:args (object :scs (descriptor-reg))
 368                 (value :scs (unsigned-reg immediate) :target result))
 369          (:arg-types ,type (:constant low-index)
 370                      (:constant (integer 0 0)) positive-fixnum)
 371          (:temporary (:sc unsigned-reg) mask-tn)
 372          (:info index offset)
 373          (:results (result :scs (unsigned-reg)))
 374          (:result-types positive-fixnum)
 375          (:temporary (:sc unsigned-reg :to (:result 0)) old)
 376          (:generator 20
 377            (aver (zerop offset))
 378            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 379              (inst mov old
 380                    (make-ea :qword :base object
 381                             :disp (- (* (+ word vector-data-offset)
 382                                         n-word-bytes)
 383                                      other-pointer-lowtag)))
 384              (sc-case value
 385                (immediate
 386                 (let* ((value (tn-value value))
 387                        (mask ,(1- (ash 1 bits)))
 388                        (shift (* extra ,bits)))
 389                   (unless (= value mask)
 390                     (inst mov mask-tn (ldb (byte 64 0)
 391                                            (lognot (ash mask shift))))
 392                     (inst and old mask-tn))
 393                   (unless (zerop value)
 394                     (inst mov mask-tn (ash value shift))
 395                     (inst or old mask-tn))))
 396                (unsigned-reg
 397                 (let ((shift (* extra ,bits)))
 398                   (unless (zerop shift)
 399                     (inst ror old shift))
 400                   (inst mov mask-tn (lognot ,(1- (ash 1 bits))))
 401                   (inst and old mask-tn)
 402                   (inst or old value)
 403                   (unless (zerop shift)
 404                     (inst rol old shift)))))
 405              (inst mov (make-ea :qword :base object
 406                                 :disp (- (* (+ word vector-data-offset)
 407                                             n-word-bytes)
 408                                          other-pointer-lowtag))
 409                    old)
 410              (sc-case value
 411                (immediate
 412                 (inst mov result (tn-value value)))
 413                (unsigned-reg
 414                 (move result value))))))))))
 415   (def-small-data-vector-frobs simple-bit-vector 1)
 416   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 417   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 418 ;;; And the float variants.
 419
 420 (defun make-ea-for-float-ref (object index offset element-size
 421                               &key (scale 1) (complex-offset 0))
 422   (let ((ea-size (if (= element-size 4) :dword :qword)))
 423     (etypecase index
 424       (integer
 425        (make-ea ea-size :base object
 426                 :disp (- (+ (* vector-data-offset n-word-bytes)
 427                             (* (+ index offset) element-size)
 428                             complex-offset)
 429                          other-pointer-lowtag)))
 430       (tn
 431        (make-ea ea-size :base object :index index :scale scale
 432                 :disp (- (+ (* vector-data-offset n-word-bytes)
 433                             (* offset element-size)
 434                             complex-offset)
 435                          other-pointer-lowtag))))))
 436
 437 #.
 438 (let ((use-temp (<= word-shift n-fixnum-tag-bits)))
 439   `(define-vop (data-vector-ref-with-offset/simple-array-single-float)
 440      (:note "inline array access")
 441      (:translate data-vector-ref-with-offset)
 442      (:policy :fast-safe)
 443      (:args (object :scs (descriptor-reg))
 444             (index :scs (any-reg)))
 445      (:info offset)
 446      (:arg-types simple-array-single-float tagged-num
 447                  (:constant (constant-displacement other-pointer-lowtag
 448                                                    4 vector-data-offset)))
 449      ,@(when use-temp '((:temporary (:sc unsigned-reg) dword-index)))
 450      (:results (value :scs (single-reg)))
 451      (:result-types single-float)
 452      (:generator 5
 453       ,@(if use-temp
 454             '((move dword-index index)
 455               (inst shr dword-index (1+ (- n-fixnum-tag-bits word-shift)))
 456               (inst movss value (make-ea-for-float-ref object dword-index offset 4)))
 457             '((inst movss value (make-ea-for-float-ref object index offset 4
 458                                  :scale (ash 4 (- n-fixnum-tag-bits)))))))))
 459
 460 (define-vop (data-vector-ref-with-offset/simple-array-single-float-c)
 461   (:note "inline array access")
 462   (:translate data-vector-ref-with-offset)
 463   (:policy :fast-safe)
 464   (:args (object :scs (descriptor-reg)))
 465   (:info index offset)
 466   (:arg-types simple-array-single-float (:constant low-index)
 467               (:constant (constant-displacement other-pointer-lowtag
 468                                                 4 vector-data-offset)))
 469   (:results (value :scs (single-reg)))
 470   (:result-types single-float)
 471   (:generator 4
 472    (inst movss value (make-ea-for-float-ref object index offset 4))))
 473
 474 #.
 475 (let ((use-temp (<= word-shift n-fixnum-tag-bits)))
 476   `(define-vop (data-vector-set-with-offset/simple-array-single-float)
 477      (:note "inline array store")
 478      (:translate data-vector-set-with-offset)
 479      (:policy :fast-safe)
 480      (:args (object :scs (descriptor-reg))
 481             (index :scs (any-reg))
 482             (value :scs (single-reg) :target result))
 483      (:info offset)
 484      (:arg-types simple-array-single-float tagged-num
 485                  (:constant (constant-displacement other-pointer-lowtag
 486                                                    4 vector-data-offset))
 487                   single-float)
 488      ,@(when use-temp '((:temporary (:sc unsigned-reg) dword-index)))
 489      (:results (result :scs (single-reg)))
 490      (:result-types single-float)
 491      (:generator 5
 492       ,@(if use-temp
 493             '((move dword-index index)
 494               (inst shr dword-index (1+ (- n-fixnum-tag-bits word-shift)))
 495               (inst movss (make-ea-for-float-ref object dword-index offset 4) value))
 496             '((inst movss (make-ea-for-float-ref object index offset 4
 497                            :scale (ash 4 (- n-fixnum-tag-bits))) value)))
 498       (move result value))))
 499
 500 (define-vop (data-vector-set-with-offset/simple-array-single-float-c)
 501   (:note "inline array store")
 502   (:translate data-vector-set-with-offset)
 503   (:policy :fast-safe)
 504   (:args (object :scs (descriptor-reg))
 505          (value :scs (single-reg) :target result))
 506   (:info index offset)
 507   (:arg-types simple-array-single-float (:constant low-index)
 508               (:constant (constant-displacement other-pointer-lowtag
 509                                                 4 vector-data-offset))
 510               single-float)
 511   (:results (result :scs (single-reg)))
 512   (:result-types single-float)
 513   (:generator 4
 514    (inst movss (make-ea-for-float-ref object index offset 4) value)
 515    (move result value)))
 516
 517 (define-vop (data-vector-ref-with-offset/simple-array-double-float)
 518   (:note "inline array access")
 519   (:translate data-vector-ref-with-offset)
 520   (:policy :fast-safe)
 521   (:args (object :scs (descriptor-reg))
 522          (index :scs (any-reg)))
 523   (:info offset)
 524   (:arg-types simple-array-double-float tagged-num
 525               (:constant (constant-displacement other-pointer-lowtag
 526                                                 8 vector-data-offset)))
 527   (:results (value :scs (double-reg)))
 528   (:result-types double-float)
 529   (:generator 7
 530    (inst movsd value (make-ea-for-float-ref object index offset 8
 531                                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 532
 533 (define-vop (data-vector-ref-c/simple-array-double-float)
 534   (:note "inline array access")
 535   (:translate data-vector-ref-with-offset)
 536   (:policy :fast-safe)
 537   (:args (object :scs (descriptor-reg)))
 538   (:info index offset)
 539   (:arg-types simple-array-double-float (:constant low-index)
 540               (:constant (constant-displacement other-pointer-lowtag
 541                                                 8 vector-data-offset)))
 542   (:results (value :scs (double-reg)))
 543   (:result-types double-float)
 544   (:generator 6
 545    (inst movsd value (make-ea-for-float-ref object index offset 8))))
 546
 547 (define-vop (data-vector-set-with-offset/simple-array-double-float)
 548   (:note "inline array store")
 549   (:translate data-vector-set-with-offset)
 550   (:policy :fast-safe)
 551   (:args (object :scs (descriptor-reg))
 552          (index :scs (any-reg))
 553          (value :scs (double-reg) :target result))
 554   (:info offset)
 555   (:arg-types simple-array-double-float tagged-num
 556               (:constant (constant-displacement other-pointer-lowtag
 557                                                 8 vector-data-offset))
 558               double-float)
 559   (:results (result :scs (double-reg)))
 560   (:result-types double-float)
 561   (:generator 20
 562    (inst movsd (make-ea-for-float-ref object index offset 8
 563                                       :scale (ash 1 (- word-shift n-fixnum-tag-bits)))
 564          value)
 565    (move result value)))
 566
 567 (define-vop (data-vector-set-with-offset/simple-array-double-float-c)
 568   (:note "inline array store")
 569   (:translate data-vector-set-with-offset)
 570   (:policy :fast-safe)
 571   (:args (object :scs (descriptor-reg))
 572          (value :scs (double-reg) :target result))
 573   (:info index offset)
 574   (:arg-types simple-array-double-float (:constant low-index)
 575               (:constant (constant-displacement other-pointer-lowtag
 576                                                 8 vector-data-offset))
 577               double-float)
 578   (:results (result :scs (double-reg)))
 579   (:result-types double-float)
 580   (:generator 19
 581    (inst movsd (make-ea-for-float-ref object index offset 8) value)
 582    (move result value)))
 583
 584
 585 ;;; complex float variants
 586
 587 (define-vop (data-vector-ref-with-offset/simple-array-complex-single-float)
 588   (:note "inline array access")
 589   (:translate data-vector-ref-with-offset)
 590   (:policy :fast-safe)
 591   (:args (object :scs (descriptor-reg))
 592          (index :scs (any-reg)))
 593   (:info offset)
 594   (:arg-types simple-array-complex-single-float tagged-num
 595               (:constant (constant-displacement other-pointer-lowtag
 596                                                 8 vector-data-offset)))
 597   (:results (value :scs (complex-single-reg)))
 598   (:result-types complex-single-float)
 599   (:generator 5
 600     (inst movq value (make-ea-for-float-ref object index offset 8
 601                                             :scale (ash 1 (- word-shift n-fixnum-tag-bits))))))
 602
 603 (define-vop (data-vector-ref-with-offset/simple-array-complex-single-float-c)
 604   (:note "inline array access")
 605   (:translate data-vector-ref-with-offset)
 606   (:policy :fast-safe)
 607   (:args (object :scs (descriptor-reg)))
 608   (:info index offset)
 609   (:arg-types simple-array-complex-single-float (:constant low-index)
 610               (:constant (constant-displacement other-pointer-lowtag
 611                                                 8 vector-data-offset)))
 612   (:results (value :scs (complex-single-reg)))
 613   (:result-types complex-single-float)
 614   (:generator 4
 615     (inst movq value (make-ea-for-float-ref object index offset 8))))
 616
 617 (define-vop (data-vector-set-with-offset/simple-array-complex-single-float)
 618   (:note "inline array store")
 619   (:translate data-vector-set-with-offset)
 620   (:policy :fast-safe)
 621   (:args (object :scs (descriptor-reg))
 622          (index :scs (any-reg))
 623          (value :scs (complex-single-reg) :target result))
 624   (:info offset)
 625   (:arg-types simple-array-complex-single-float tagged-num
 626               (:constant (constant-displacement other-pointer-lowtag
 627                                                 8 vector-data-offset))
 628               complex-single-float)
 629   (:results (result :scs (complex-single-reg)))
 630   (:result-types complex-single-float)
 631   (:generator 5
 632     (move result value)
 633     (inst movq (make-ea-for-float-ref object index offset 8
 634                                       :scale (ash 1 (- word-shift n-fixnum-tag-bits)))
 635           value)))
 636
 637 (define-vop (data-vector-set-with-offset/simple-array-complex-single-float-c)
 638   (:note "inline array store")
 639   (:translate data-vector-set-with-offset)
 640   (:policy :fast-safe)
 641   (:args (object :scs (descriptor-reg))
 642          (value :scs (complex-single-reg) :target result))
 643   (:info index offset)
 644   (:arg-types simple-array-complex-single-float (:constant low-index)
 645               (:constant (constant-displacement other-pointer-lowtag
 646                                                 8 vector-data-offset))
 647               complex-single-float)
 648   (:results (result :scs (complex-single-reg)))
 649   (:result-types complex-single-float)
 650   (:generator 4
 651     (move result value)
 652     (inst movq (make-ea-for-float-ref object index offset 8) value)))
 653
 654 (define-vop (data-vector-ref-with-offset/simple-array-complex-double-float)
 655   (:note "inline array access")
 656   (:translate data-vector-ref-with-offset)
 657   (:policy :fast-safe)
 658   (:args (object :scs (descriptor-reg))
 659          (index :scs (any-reg)))
 660   (:info offset)
 661   (:arg-types simple-array-complex-double-float tagged-num
 662               (:constant (constant-displacement other-pointer-lowtag
 663                                                 16 vector-data-offset)))
 664   (:results (value :scs (complex-double-reg)))
 665   (:result-types complex-double-float)
 666   (:generator 7
 667     (inst movapd value (make-ea-for-float-ref object index offset 16
 668                                               :scale (ash 2 (- word-shift n-fixnum-tag-bits))))))
 669
 670 (define-vop (data-vector-ref-with-offset/simple-array-complex-double-float-c)
 671   (:note "inline array access")
 672   (:translate data-vector-ref-with-offset)
 673   (:policy :fast-safe)
 674   (:args (object :scs (descriptor-reg)))
 675   (:info index offset)
 676   (:arg-types simple-array-complex-double-float (:constant low-index)
 677               (:constant (constant-displacement other-pointer-lowtag
 678                                                 16 vector-data-offset)))
 679   (:results (value :scs (complex-double-reg)))
 680   (:result-types complex-double-float)
 681   (:generator 6
 682     (inst movapd value (make-ea-for-float-ref object index offset 16))))
 683
 684 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
 685   (:note "inline array store")
 686   (:translate data-vector-set-with-offset)
 687   (:policy :fast-safe)
 688   (:args (object :scs (descriptor-reg))
 689          (index :scs (any-reg))
 690          (value :scs (complex-double-reg) :target result))
 691   (:info offset)
 692   (:arg-types simple-array-complex-double-float tagged-num
 693               (:constant (constant-displacement other-pointer-lowtag
 694                                                 16 vector-data-offset))
 695               complex-double-float)
 696   (:results (result :scs (complex-double-reg)))
 697   (:result-types complex-double-float)
 698   (:generator 20
 699     (inst movapd (make-ea-for-float-ref object index offset 16
 700                                         :scale (ash 2 (- word-shift n-fixnum-tag-bits)))
 701           value)
 702     (move result value)))
 703
 704 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float-c)
 705   (:note "inline array store")
 706   (:translate data-vector-set-with-offset)
 707   (:policy :fast-safe)
 708   (:args (object :scs (descriptor-reg))
 709          (value :scs (complex-double-reg) :target result))
 710   (:info index offset)
 711   (:arg-types simple-array-complex-double-float (:constant low-index)
 712               (:constant (constant-displacement other-pointer-lowtag
 713                                                 16 vector-data-offset))
 714               complex-double-float)
 715   (:results (result :scs (complex-double-reg)))
 716   (:result-types complex-double-float)
 717   (:generator 19
 718     (inst movapd (make-ea-for-float-ref object index offset 16) value)
 719     (move result value)))
 720
 721 \f
 722
 723 ;;; {un,}signed-byte-{8,16,32} and characters
 724 (macrolet ((define-data-vector-frobs (ptype mov-inst operand-size
 725                                             type &rest scs)
 726   (let ((n-bytes (ecase operand-size
 727                    (:byte 1)
 728                    (:word 2)
 729                    (:dword 4))))
 730     (multiple-value-bind (index-sc scale)
 731         (if (>= n-bytes (ash 1 n-fixnum-tag-bits))
 732             (values 'any-reg (ash n-bytes (- n-fixnum-tag-bits)))
 733             (values 'signed-reg n-bytes))
 734       `(progn
 735          (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
 736            (:translate data-vector-ref-with-offset)
 737            (:policy :fast-safe)
 738            (:args (object :scs (descriptor-reg))
 739                   (index :scs (,index-sc)))
 740            (:info offset)
 741            (:arg-types ,ptype tagged-num
 742                        (:constant (constant-displacement other-pointer-lowtag
 743                                                          ,n-bytes vector-data-offset)))
 744            (:results (value :scs ,scs))
 745            (:result-types ,type)
 746            (:generator 5
 747                        (inst ,mov-inst value
 748                              (make-ea ,operand-size :base object :index index :scale ,scale
 749                                       :disp (- (+ (* vector-data-offset n-word-bytes)
 750                                                   (* offset ,n-bytes))
 751                                                other-pointer-lowtag)))))
 752          (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype "-C"))
 753            (:translate data-vector-ref-with-offset)
 754            (:policy :fast-safe)
 755            (:args (object :scs (descriptor-reg)))
 756            (:info index offset)
 757            (:arg-types ,ptype (:constant low-index)
 758                        (:constant (constant-displacement other-pointer-lowtag
 759                                                          ,n-bytes vector-data-offset)))
 760            (:results (value :scs ,scs))
 761            (:result-types ,type)
 762            (:generator 4
 763                        (inst ,mov-inst value
 764                              (make-ea ,operand-size :base object
 765                                       :disp (- (+ (* vector-data-offset n-word-bytes)
 766                                                   (* ,n-bytes index)
 767                                                   (* ,n-bytes offset))
 768                                                other-pointer-lowtag)))))
 769          (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
 770            (:translate data-vector-set-with-offset)
 771            (:policy :fast-safe)
 772            (:args (object :scs (descriptor-reg) :to (:eval 0))
 773                   (index :scs (,index-sc) :to (:eval 0))
 774                   (value :scs ,scs :target result))
 775            (:info offset)
 776            (:arg-types ,ptype tagged-num
 777                        (:constant (constant-displacement other-pointer-lowtag
 778                                                          ,n-bytes vector-data-offset))
 779                        ,type)
 780            (:results (result :scs ,scs))
 781            (:result-types ,type)
 782            (:generator 5
 783                        (inst mov (make-ea ,operand-size :base object :index index :scale ,scale
 784                                           :disp (- (+ (* vector-data-offset n-word-bytes)
 785                                                       (* offset ,n-bytes))
 786                                                    other-pointer-lowtag))
 787                              (reg-in-size value ,operand-size))
 788                        (move result value)))
 789
 790          (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype "-C"))
 791            (:translate data-vector-set-with-offset)
 792            (:policy :fast-safe)
 793            (:args (object :scs (descriptor-reg) :to (:eval 0))
 794                   (value :scs ,scs :target result))
 795            (:info index offset)
 796            (:arg-types ,ptype (:constant low-index)
 797                        (:constant (constant-displacement other-pointer-lowtag
 798                                                          ,n-bytes vector-data-offset))
 799                        ,type)
 800            (:results (result :scs ,scs))
 801            (:result-types ,type)
 802            (:generator 4
 803                        (inst mov (make-ea ,operand-size :base object
 804                                           :disp (- (+ (* vector-data-offset n-word-bytes)
 805                                                       (* ,n-bytes index)
 806                                                       (* ,n-bytes offset))
 807                                                    other-pointer-lowtag))
 808                              (reg-in-size value ,operand-size))
 809                        (move result value))))))))
 810   (define-data-vector-frobs simple-array-unsigned-byte-7 movzx :byte
 811     positive-fixnum unsigned-reg signed-reg)
 812   (define-data-vector-frobs simple-array-unsigned-byte-8 movzx :byte
 813     positive-fixnum unsigned-reg signed-reg)
 814   (define-data-vector-frobs simple-array-signed-byte-8 movsx :byte
 815     tagged-num signed-reg)
 816   (define-data-vector-frobs simple-base-string
 817      #!+sb-unicode movzx #!-sb-unicode mov :byte
 818      character character-reg)
 819   (define-data-vector-frobs simple-array-unsigned-byte-15 movzx :word
 820     positive-fixnum unsigned-reg signed-reg)
 821   (define-data-vector-frobs simple-array-unsigned-byte-16 movzx :word
 822     positive-fixnum unsigned-reg signed-reg)
 823   (define-data-vector-frobs simple-array-signed-byte-16 movsx :word
 824     tagged-num signed-reg)
 825   (define-data-vector-frobs simple-array-unsigned-byte-32 movzxd :dword
 826     positive-fixnum unsigned-reg signed-reg)
 827   (define-data-vector-frobs simple-array-unsigned-byte-31 movzxd :dword
 828     positive-fixnum unsigned-reg signed-reg)
 829   (define-data-vector-frobs simple-array-signed-byte-32 movsxd :dword
 830     tagged-num signed-reg)
 831   #!+sb-unicode
 832   (define-data-vector-frobs simple-character-string movzxd :dword
 833     character character-reg))
 834
 835 \f
 836 ;;; These vops are useful for accessing the bits of a vector
 837 ;;; irrespective of what type of vector it is.
 838 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 839   (unsigned-reg) unsigned-num %vector-raw-bits)
 840 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 841   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 842 \f
 843 ;;;; ATOMIC-INCF for arrays
 844
 845 (define-vop (array-atomic-incf/word)
 846   (:translate %array-atomic-incf/word)
 847   (:policy :fast-safe)
 848   (:args (array :scs (descriptor-reg))
 849          (index :scs (any-reg))
 850          (diff :scs (unsigned-reg) :target result))
 851   (:arg-types * positive-fixnum unsigned-num)
 852   (:results (result :scs (unsigned-reg)))
 853   (:result-types unsigned-num)
 854   (:generator 4
 855     (inst xadd (make-ea :qword :base array
 856                         :scale (ash 1 (- word-shift n-fixnum-tag-bits))
 857                         :index index
 858                         :disp (- (* vector-data-offset n-word-bytes)
 859                                  other-pointer-lowtag))
 860           diff :lock)
 861     (move result diff)))