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