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