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-with-offset/ type))
 173          (:note "inline array access")
 174          (:translate data-vector-ref-with-offset)
 175          (:policy :fast-safe)
 176          (:args (object :scs (descriptor-reg))
 177                 (index :scs (unsigned-reg)))
 178          (:info offset)
 179          (:arg-types ,type positive-fixnum (:constant (integer 0 0)))
 180          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 181          (:result-types positive-fixnum)
 182          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 183          (:generator 20
 184            (aver (zerop offset))
 185            (move ecx index)
 186            (inst shr ecx ,bit-shift)
 187            (inst mov result
 188                  (make-ea :qword :base object :index ecx :scale n-word-bytes
 189                           :disp (- (* vector-data-offset n-word-bytes)
 190                                    other-pointer-lowtag)))
 191            (move ecx index)
 192            ;; We used to mask ECX for all values of BITS, but since
 193            ;; Intel's documentation says that the chip will mask shift
 194            ;; and rotate counts by 63 automatically, we can safely move
 195            ;; the masking operation under the protection of this UNLESS
 196            ;; in the bit-vector case.  --njf, 2006-07-14
 197            ,@(unless (= bits 1)
 198                `((inst and ecx ,(1- elements-per-word))
 199                  (inst shl ecx ,(1- (integer-length bits)))))
 200            (inst shr result :cl)
 201            (inst and result ,(1- (ash 1 bits)))))
 202        (define-vop (,(symbolicate 'data-vector-ref-c-with-offset/ type))
 203          (:translate data-vector-ref-with-offset)
 204          (:policy :fast-safe)
 205          (:args (object :scs (descriptor-reg)))
 206          (:arg-types ,type (:constant low-index) (:constant (integer 0 0)))
 207          (:info index offset)
 208          (:results (result :scs (unsigned-reg)))
 209          (:result-types positive-fixnum)
 210          (:generator 15
 211            (aver (zerop offset))
 212            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 213              (loadw result object (+ word vector-data-offset)
 214                     other-pointer-lowtag)
 215              (unless (zerop extra)
 216                (inst shr result (* extra ,bits)))
 217              (unless (= extra ,(1- elements-per-word))
 218                (inst and result ,(1- (ash 1 bits)))))))
 219        (define-vop (,(symbolicate 'data-vector-set-with-offset/ type))
 220          (:note "inline array store")
 221          (:translate data-vector-set-with-offset)
 222          (:policy :fast-safe)
 223          (:args (object :scs (descriptor-reg))
 224                 (index :scs (unsigned-reg) :target ecx)
 225                 (value :scs (unsigned-reg immediate) :target result))
 226          (:info offset)
 227          (:arg-types ,type positive-fixnum (:constant (integer 0 0))
 228                      positive-fixnum)
 229          (:results (result :scs (unsigned-reg)))
 230          (:result-types positive-fixnum)
 231          (:temporary (:sc unsigned-reg) word-index)
 232          (:temporary (:sc unsigned-reg) old)
 233          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 234          (:generator 25
 235            (aver (zerop offset))
 236            (move word-index index)
 237            (inst shr word-index ,bit-shift)
 238            (inst mov old
 239                  (make-ea :qword :base object :index word-index
 240                           :scale n-word-bytes
 241                           :disp (- (* vector-data-offset n-word-bytes)
 242                                    other-pointer-lowtag)))
 243            (move ecx index)
 244            ;; We used to mask ECX for all values of BITS, but since
 245            ;; Intel's documentation says that the chip will mask shift
 246            ;; and rotate counts by 63 automatically, we can safely move
 247            ;; the masking operation under the protection of this UNLESS
 248            ;; in the bit-vector case.  --njf, 2006-07-14
 249            ,@(unless (= bits 1)
 250                `((inst and ecx ,(1- elements-per-word))
 251                  (inst shl ecx ,(1- (integer-length bits)))))
 252            (inst ror old :cl)
 253            (unless (and (sc-is value immediate)
 254                         (= (tn-value value) ,(1- (ash 1 bits))))
 255              (inst and old ,(lognot (1- (ash 1 bits)))))
 256            (sc-case value
 257              (immediate
 258               (unless (zerop (tn-value value))
 259                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
 260              (unsigned-reg
 261               (inst or old value)))
 262            (inst rol old :cl)
 263            (inst mov (make-ea :qword :base object :index word-index
 264                               :scale n-word-bytes
 265                               :disp (- (* vector-data-offset n-word-bytes)
 266                                        other-pointer-lowtag))
 267                  old)
 268            (sc-case value
 269              (immediate
 270               (inst mov result (tn-value value)))
 271              (unsigned-reg
 272               (move result value)))))
 273        (define-vop (,(symbolicate 'data-vector-set-c-with-offset/ type))
 274          (:translate data-vector-set-with-offset)
 275          (:policy :fast-safe)
 276          (:args (object :scs (descriptor-reg))
 277                 (value :scs (unsigned-reg immediate) :target result))
 278          (:arg-types ,type (:constant low-index)
 279                      (:constant (integer 0 0)) positive-fixnum)
 280          (:temporary (:sc unsigned-reg) mask-tn)
 281          (:info index offset)
 282          (:results (result :scs (unsigned-reg)))
 283          (:result-types positive-fixnum)
 284          (:temporary (:sc unsigned-reg :to (:result 0)) old)
 285          (:generator 20
 286            (aver (zerop offset))
 287            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 288              (inst mov old
 289                    (make-ea :qword :base object
 290                             :disp (- (* (+ word vector-data-offset)
 291                                         n-word-bytes)
 292                                      other-pointer-lowtag)))
 293              (sc-case value
 294                (immediate
 295                 (let* ((value (tn-value value))
 296                        (mask ,(1- (ash 1 bits)))
 297                        (shift (* extra ,bits)))
 298                   (unless (= value mask)
 299                     (inst mov mask-tn (ldb (byte 64 0)
 300                                            (lognot (ash mask shift))))
 301                     (inst and old mask-tn))
 302                   (unless (zerop value)
 303                     (inst mov mask-tn (ash value shift))
 304                     (inst or old mask-tn))))
 305                (unsigned-reg
 306                 (let ((shift (* extra ,bits)))
 307                   (unless (zerop shift)
 308                     (inst ror old shift))
 309                   (inst mov mask-tn (lognot ,(1- (ash 1 bits))))
 310                   (inst and old mask-tn)
 311                   (inst or old value)
 312                   (unless (zerop shift)
 313                     (inst rol old shift)))))
 314              (inst mov (make-ea :qword :base object
 315                                 :disp (- (* (+ word vector-data-offset)
 316                                             n-word-bytes)
 317                                          other-pointer-lowtag))
 318                    old)
 319              (sc-case value
 320                (immediate
 321                 (inst mov result (tn-value value)))
 322                (unsigned-reg
 323                 (move result value))))))))))
 324   (def-small-data-vector-frobs simple-bit-vector 1)
 325   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 326   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 327 ;;; And the float variants.
 328
 329 (defun make-ea-for-float-ref (object index offset element-size
 330                               &key (scale 1) (complex-offset 0))
 331   (let ((ea-size (if (= element-size 4) :dword :qword)))
 332     (etypecase index
 333       (integer
 334        (make-ea ea-size :base object
 335                 :disp (- (+ (* vector-data-offset n-word-bytes)
 336                             (* (+ index offset) element-size)
 337                             complex-offset)
 338                          other-pointer-lowtag)))
 339       (tn
 340        (make-ea ea-size :base object :index index :scale scale
 341                 :disp (- (+ (* vector-data-offset n-word-bytes)
 342                             (* offset element-size)
 343                             complex-offset)
 344                          other-pointer-lowtag))))))
 345
 346 (define-vop (data-vector-ref/simple-array-single-float)
 347   (:note "inline array access")
 348   (:translate data-vector-ref-with-offset)
 349   (:policy :fast-safe)
 350   (:args (object :scs (descriptor-reg))
 351          (index :scs (any-reg)))
 352   (:info offset)
 353   (:arg-types simple-array-single-float positive-fixnum
 354               (:constant (constant-displacement other-pointer-lowtag
 355                                                 4 vector-data-offset)))
 356   (:temporary (:sc unsigned-reg) dword-index)
 357   (:results (value :scs (single-reg)))
 358   (:result-types single-float)
 359   (:generator 5
 360    (move dword-index index)
 361    (inst shr dword-index 1)
 362    (inst movss value (make-ea-for-float-ref object dword-index offset 4))))
 363
 364 (define-vop (data-vector-ref-c/simple-array-single-float)
 365   (:note "inline array access")
 366   (:translate data-vector-ref-with-offset)
 367   (:policy :fast-safe)
 368   (:args (object :scs (descriptor-reg)))
 369   (:info index offset)
 370   (:arg-types simple-array-single-float (:constant low-index)
 371               (:constant (constant-displacement other-pointer-lowtag
 372                                                 4 vector-data-offset)))
 373   (:results (value :scs (single-reg)))
 374   (:result-types single-float)
 375   (:generator 4
 376    (inst movss value (make-ea-for-float-ref object index offset 4))))
 377
 378 (define-vop (data-vector-set/simple-array-single-float)
 379   (:note "inline array store")
 380   (:translate data-vector-set-with-offset)
 381   (:policy :fast-safe)
 382   (:args (object :scs (descriptor-reg))
 383          (index :scs (any-reg))
 384          (value :scs (single-reg) :target result))
 385   (:info offset)
 386   (:arg-types simple-array-single-float positive-fixnum
 387               (:constant (constant-displacement other-pointer-lowtag
 388                                                 4 vector-data-offset))
 389                single-float)
 390   (:temporary (:sc unsigned-reg) dword-index)
 391   (:results (result :scs (single-reg)))
 392   (:result-types single-float)
 393   (:generator 5
 394    (move dword-index index)
 395    (inst shr dword-index 1)
 396    (inst movss (make-ea-for-float-ref object dword-index offset 4) value)
 397    (unless (location= result value)
 398      (inst movss result value))))
 399
 400 (define-vop (data-vector-set-c/simple-array-single-float)
 401   (:note "inline array store")
 402   (:translate data-vector-set-with-offset)
 403   (:policy :fast-safe)
 404   (:args (object :scs (descriptor-reg))
 405          (value :scs (single-reg) :target result))
 406   (:info index offset)
 407   (:arg-types simple-array-single-float (:constant low-index)
 408               (:constant (constant-displacement other-pointer-lowtag
 409                                                 4 vector-data-offset))
 410               single-float)
 411   (:results (result :scs (single-reg)))
 412   (:result-types single-float)
 413   (:generator 4
 414    (inst movss (make-ea-for-float-ref object index offset 4) value)
 415    (unless (location= result value)
 416      (inst movss result value))))
 417
 418 (define-vop (data-vector-ref/simple-array-double-float)
 419   (:note "inline array access")
 420   (:translate data-vector-ref-with-offset)
 421   (:policy :fast-safe)
 422   (:args (object :scs (descriptor-reg))
 423          (index :scs (any-reg)))
 424   (:info offset)
 425   (:arg-types simple-array-double-float positive-fixnum
 426               (:constant (constant-displacement other-pointer-lowtag
 427                                                 8 vector-data-offset)))
 428   (:results (value :scs (double-reg)))
 429   (:result-types double-float)
 430   (:generator 7
 431    (inst movsd value (make-ea-for-float-ref object index offset 8))))
 432
 433 (define-vop (data-vector-ref-c/simple-array-double-float)
 434   (:note "inline array access")
 435   (:translate data-vector-ref-with-offset)
 436   (:policy :fast-safe)
 437   (:args (object :scs (descriptor-reg)))
 438   (:info index offset)
 439   (:arg-types simple-array-double-float (:constant low-index)
 440               (:constant (constant-displacement other-pointer-lowtag
 441                                                 8 vector-data-offset)))
 442   (:results (value :scs (double-reg)))
 443   (:result-types double-float)
 444   (:generator 6
 445    (inst movsd value (make-ea-for-float-ref object index offset 8))))
 446
 447 (define-vop (data-vector-set/simple-array-double-float)
 448   (:note "inline array store")
 449   (:translate data-vector-set-with-offset)
 450   (:policy :fast-safe)
 451   (:args (object :scs (descriptor-reg))
 452          (index :scs (any-reg))
 453          (value :scs (double-reg) :target result))
 454   (:info offset)
 455   (:arg-types simple-array-double-float positive-fixnum
 456               (:constant (constant-displacement other-pointer-lowtag
 457                                                 8 vector-data-offset))
 458               double-float)
 459   (:results (result :scs (double-reg)))
 460   (:result-types double-float)
 461   (:generator 20
 462    (inst movsd (make-ea-for-float-ref object index offset 8) value)
 463    (unless (location= result value)
 464      (inst movsd result value))))
 465
 466 (define-vop (data-vector-set-c/simple-array-double-float)
 467   (:note "inline array store")
 468   (:translate data-vector-set-with-offset)
 469   (:policy :fast-safe)
 470   (:args (object :scs (descriptor-reg))
 471          (value :scs (double-reg) :target result))
 472   (:info index offset)
 473   (:arg-types simple-array-double-float (:constant low-index)
 474               (:constant (constant-displacement other-pointer-lowtag
 475                                                 8 vector-data-offset))
 476               double-float)
 477   (:results (result :scs (double-reg)))
 478   (:result-types double-float)
 479   (:generator 19
 480    (inst movsd (make-ea-for-float-ref object index offset 8) value)
 481    (unless (location= result value)
 482      (inst movsd result value))))
 483
 484
 485 ;;; complex float variants
 486
 487 (define-vop (data-vector-ref/simple-array-complex-single-float)
 488   (:note "inline array access")
 489   (:translate data-vector-ref-with-offset)
 490   (:policy :fast-safe)
 491   (:args (object :scs (descriptor-reg))
 492          (index :scs (any-reg)))
 493   (:info offset)
 494   (:arg-types simple-array-complex-single-float positive-fixnum
 495               (:constant (constant-displacement other-pointer-lowtag
 496                                                 8 vector-data-offset)))
 497   (:results (value :scs (complex-single-reg)))
 498   (:result-types complex-single-float)
 499   (:generator 5
 500     (let ((real-tn (complex-single-reg-real-tn value)))
 501       (inst movss real-tn (make-ea-for-float-ref object index offset 8)))
 502     (let ((imag-tn (complex-single-reg-imag-tn value)))
 503       (inst movss imag-tn (make-ea-for-float-ref object index offset 8
 504                                                  :complex-offset 4)))))
 505
 506 (define-vop (data-vector-ref-c/simple-array-complex-single-float)
 507   (:note "inline array access")
 508   (:translate data-vector-ref-with-offset)
 509   (:policy :fast-safe)
 510   (:args (object :scs (descriptor-reg)))
 511   (:info index offset)
 512   (:arg-types simple-array-complex-single-float (:constant low-index)
 513               (:constant (constant-displacement other-pointer-lowtag
 514                                                 8 vector-data-offset)))
 515   (:results (value :scs (complex-single-reg)))
 516   (:result-types complex-single-float)
 517   (:generator 4
 518     (let ((real-tn (complex-single-reg-real-tn value)))
 519       (inst movss real-tn (make-ea-for-float-ref object index offset 8)))
 520     (let ((imag-tn (complex-single-reg-imag-tn value)))
 521       (inst movss imag-tn (make-ea-for-float-ref object index offset 8
 522                                                  :complex-offset 4)))))
 523
 524 (define-vop (data-vector-set/simple-array-complex-single-float)
 525   (:note "inline array store")
 526   (:translate data-vector-set-with-offset)
 527   (:policy :fast-safe)
 528   (:args (object :scs (descriptor-reg))
 529          (index :scs (any-reg))
 530          (value :scs (complex-single-reg) :target result))
 531   (:info offset)
 532   (:arg-types simple-array-complex-single-float positive-fixnum
 533               (:constant (constant-displacement other-pointer-lowtag
 534                                                 8 vector-data-offset))
 535               complex-single-float)
 536   (:results (result :scs (complex-single-reg)))
 537   (:result-types complex-single-float)
 538   (:generator 5
 539     (let ((value-real (complex-single-reg-real-tn value))
 540           (result-real (complex-single-reg-real-tn result)))
 541       (inst movss (make-ea-for-float-ref object index offset 8) value-real)
 542       (unless (location= value-real result-real)
 543         (inst movss result-real value-real)))
 544     (let ((value-imag (complex-single-reg-imag-tn value))
 545           (result-imag (complex-single-reg-imag-tn result)))
 546       (inst movss (make-ea-for-float-ref object index offset 8
 547                                          :complex-offset 4)
 548             value-imag)
 549       (unless (location= value-imag result-imag)
 550         (inst movss result-imag value-imag)))))
 551
 552 (define-vop (data-vector-set-c/simple-array-complex-single-float)
 553   (:note "inline array store")
 554   (:translate data-vector-set-with-offset)
 555   (:policy :fast-safe)
 556   (:args (object :scs (descriptor-reg))
 557          (value :scs (complex-single-reg) :target result))
 558   (:info index offset)
 559   (:arg-types simple-array-complex-single-float (:constant low-index)
 560               (:constant (constant-displacement other-pointer-lowtag
 561                                                 8 vector-data-offset))
 562               complex-single-float)
 563   (:results (result :scs (complex-single-reg)))
 564   (:result-types complex-single-float)
 565   (:generator 4
 566     (let ((value-real (complex-single-reg-real-tn value))
 567           (result-real (complex-single-reg-real-tn result)))
 568       (inst movss (make-ea-for-float-ref object index offset 8) value-real)
 569       (unless (location= value-real result-real)
 570         (inst movss result-real value-real)))
 571     (let ((value-imag (complex-single-reg-imag-tn value))
 572           (result-imag (complex-single-reg-imag-tn result)))
 573       (inst movss (make-ea-for-float-ref object index offset 8
 574                                          :complex-offset 4)
 575             value-imag)
 576       (unless (location= value-imag result-imag)
 577         (inst movss result-imag value-imag)))))
 578
 579 (define-vop (data-vector-ref/simple-array-complex-double-float)
 580   (:note "inline array access")
 581   (:translate data-vector-ref-with-offset)
 582   (:policy :fast-safe)
 583   (:args (object :scs (descriptor-reg))
 584          (index :scs (any-reg)))
 585   (:info offset)
 586   (:arg-types simple-array-complex-double-float positive-fixnum
 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 7
 592     (let ((real-tn (complex-double-reg-real-tn value)))
 593       (inst movsd real-tn (make-ea-for-float-ref object index offset 16 :scale 2)))
 594     (let ((imag-tn (complex-double-reg-imag-tn value)))
 595       (inst movsd imag-tn (make-ea-for-float-ref object index offset 16 :scale 2
 596                                                  :complex-offset 8)))))
 597
 598 (define-vop (data-vector-ref-c/simple-array-complex-double-float)
 599   (:note "inline array access")
 600   (:translate data-vector-ref-with-offset)
 601   (:policy :fast-safe)
 602   (:args (object :scs (descriptor-reg)))
 603   (:info index offset)
 604   (:arg-types simple-array-complex-double-float (:constant low-index)
 605               (:constant (constant-displacement other-pointer-lowtag
 606                                                 16 vector-data-offset)))
 607   (:results (value :scs (complex-double-reg)))
 608   (:result-types complex-double-float)
 609   (:generator 6
 610     (let ((real-tn (complex-double-reg-real-tn value)))
 611       (inst movsd real-tn (make-ea-for-float-ref object index offset 16 :scale 2)))
 612     (let ((imag-tn (complex-double-reg-imag-tn value)))
 613       (inst movsd imag-tn (make-ea-for-float-ref object index offset 16 :scale 2
 614                                                  :complex-offset 8)))))
 615
 616 (define-vop (data-vector-set/simple-array-complex-double-float)
 617   (:note "inline array store")
 618   (:translate data-vector-set-with-offset)
 619   (:policy :fast-safe)
 620   (:args (object :scs (descriptor-reg))
 621          (index :scs (any-reg))
 622          (value :scs (complex-double-reg) :target result))
 623   (:info offset)
 624   (:arg-types simple-array-complex-double-float positive-fixnum
 625               (:constant (constant-displacement other-pointer-lowtag
 626                                                 16 vector-data-offset))
 627               complex-double-float)
 628   (:results (result :scs (complex-double-reg)))
 629   (:result-types complex-double-float)
 630   (:generator 20
 631     (let ((value-real (complex-double-reg-real-tn value))
 632           (result-real (complex-double-reg-real-tn result)))
 633       (inst movsd (make-ea-for-float-ref object index offset 16 :scale 2)
 634             value-real)
 635       (unless (location= value-real result-real)
 636         (inst movsd result-real value-real)))
 637     (let ((value-imag (complex-double-reg-imag-tn value))
 638           (result-imag (complex-double-reg-imag-tn result)))
 639       (inst movsd (make-ea-for-float-ref object index offset 16 :scale 2
 640                                                  :complex-offset 8)
 641             value-imag)
 642       (unless (location= value-imag result-imag)
 643         (inst movsd result-imag value-imag)))))
 644
 645 (define-vop (data-vector-set-c/simple-array-complex-double-float)
 646   (:note "inline array store")
 647   (:translate data-vector-set-with-offset)
 648   (:policy :fast-safe)
 649   (:args (object :scs (descriptor-reg))
 650          (value :scs (complex-double-reg) :target result))
 651   (:info index offset)
 652   (:arg-types simple-array-complex-double-float (:constant low-index)
 653               (:constant (constant-displacement other-pointer-lowtag
 654                                                 16 vector-data-offset))
 655               complex-double-float)
 656   (:results (result :scs (complex-double-reg)))
 657   (:result-types complex-double-float)
 658   (:generator 19
 659     (let ((value-real (complex-double-reg-real-tn value))
 660           (result-real (complex-double-reg-real-tn result)))
 661       (inst movsd (make-ea-for-float-ref object index offset 16 :scale 2)
 662             value-real)
 663       (unless (location= value-real result-real)
 664         (inst movsd result-real value-real)))
 665     (let ((value-imag (complex-double-reg-imag-tn value))
 666           (result-imag (complex-double-reg-imag-tn result)))
 667       (inst movsd (make-ea-for-float-ref object index offset 16 :scale 2
 668                                                  :complex-offset 8)
 669             value-imag)
 670       (unless (location= value-imag result-imag)
 671         (inst movsd result-imag value-imag)))))
 672
 673 \f
 674
 675 ;;; unsigned-byte-8
 676 (macrolet ((define-data-vector-frobs (ptype mov-inst type
 677                                             8-bit-tns-p &rest scs)
 678   `(progn
 679     (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 680       (:translate data-vector-ref-with-offset)
 681       (:policy :fast-safe)
 682       (:args (object :scs (descriptor-reg))
 683              (index :scs (unsigned-reg)))
 684       (:info offset)
 685       (:arg-types ,ptype positive-fixnum
 686                   (:constant (constant-displacement other-pointer-lowtag
 687                                                     1 vector-data-offset)))
 688       (:results (value :scs ,scs))
 689       (:result-types ,type)
 690       (:generator 5
 691         (inst ,mov-inst value
 692               (make-ea :byte :base object :index index :scale 1
 693                        :disp (- (+ (* vector-data-offset n-word-bytes)
 694                                    offset)
 695                                 other-pointer-lowtag)))))
 696     (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 697       (:translate data-vector-ref-with-offset)
 698       (:policy :fast-safe)
 699       (:args (object :scs (descriptor-reg)))
 700       (:info index offset)
 701       (:arg-types ,ptype (:constant low-index)
 702                   (:constant (constant-displacement other-pointer-lowtag
 703                                                     1 vector-data-offset)))
 704       (:results (value :scs ,scs))
 705       (:result-types ,type)
 706       (:generator 4
 707         (inst ,mov-inst value
 708               (make-ea :byte :base object
 709                        :disp (- (+ (* vector-data-offset n-word-bytes)
 710                                    index offset)
 711                                 other-pointer-lowtag)))))
 712     (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 713       (:translate data-vector-set-with-offset)
 714       (:policy :fast-safe)
 715       (:args (object :scs (descriptor-reg) :to (:eval 0))
 716              (index :scs (unsigned-reg) :to (:eval 0))
 717              (value :scs ,scs ,@(unless 8-bit-tns-p '(:target rax))))
 718       (:info offset)
 719       (:arg-types ,ptype positive-fixnum
 720                   (:constant (constant-displacement other-pointer-lowtag
 721                                                     1 vector-data-offset))
 722                   ,type)
 723       ,@(unless 8-bit-tns-p
 724          '((:temporary (:sc unsigned-reg :offset rax-offset :target result
 725                         :from (:argument 2) :to (:result 0))
 726             rax)))
 727       (:results (result :scs ,scs))
 728       (:result-types ,type)
 729       (:generator 5
 730         ,@(unless 8-bit-tns-p '((move rax value)))
 731         (inst mov (make-ea :byte :base object :index index :scale 1
 732                            :disp (- (+ (* vector-data-offset n-word-bytes)
 733                                        offset)
 734                                     other-pointer-lowtag))
 735               ,(if 8-bit-tns-p 'value 'al-tn))
 736         (move result ,(if 8-bit-tns-p 'value 'rax))))
 737     (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 738       (:translate data-vector-set-with-offset)
 739       (:policy :fast-safe)
 740       (:args (object :scs (descriptor-reg) :to (:eval 0))
 741              (value :scs ,scs ,@(unless 8-bit-tns-p '(:target rax))))
 742       (:info index offset)
 743       (:arg-types ,ptype (:constant low-index)
 744                   (:constant (constant-displacement other-pointer-lowtag
 745                                                     1 vector-data-offset))
 746                   ,type)
 747       ,@(unless 8-bit-tns-p
 748          '((:temporary (:sc unsigned-reg :offset rax-offset :target result
 749                         :from (:argument 2) :to (:result 0))
 750             rax)))
 751       (:results (result :scs ,scs))
 752       (:result-types ,type)
 753       (:generator 4
 754         ,@(unless 8-bit-tns-p '((move rax value)))
 755         (inst mov (make-ea :byte :base object
 756                            :disp (- (+ (* vector-data-offset n-word-bytes)
 757                                        index offset)
 758                                     other-pointer-lowtag))
 759               ,(if 8-bit-tns-p 'value 'al-tn))
 760         (move result ,(if 8-bit-tns-p 'value 'rax)))))))
 761   (define-data-vector-frobs simple-array-unsigned-byte-7 movzx positive-fixnum
 762     nil unsigned-reg signed-reg)
 763   (define-data-vector-frobs simple-array-unsigned-byte-8 movzx positive-fixnum
 764     nil unsigned-reg signed-reg)
 765   (define-data-vector-frobs simple-array-signed-byte-8 movsx tagged-num
 766     nil signed-reg)
 767   (define-data-vector-frobs simple-base-string
 768      #!+sb-unicode movzx #!-sb-unicode mov
 769      character
 770      #!+sb-unicode nil #!-sb-unicode t character-reg))
 771
 772 ;;; unsigned-byte-16
 773 (macrolet ((define-data-vector-frobs (ptype mov-inst type &rest scs)
 774     `(progn
 775       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 776         (:translate data-vector-ref-with-offset)
 777         (:policy :fast-safe)
 778         (:args (object :scs (descriptor-reg))
 779                (index :scs (unsigned-reg)))
 780         (:info offset)
 781         (:arg-types ,ptype positive-fixnum
 782                     (:constant (constant-displacement other-pointer-lowtag
 783                                                       2 vector-data-offset)))
 784         (:results (value :scs ,scs))
 785         (:result-types ,type)
 786         (:generator 5
 787           (inst ,mov-inst value
 788                 (make-ea :word :base object :index index :scale 2
 789                          :disp (- (+ (* vector-data-offset n-word-bytes)
 790                                      (* offset 2))
 791                                   other-pointer-lowtag)))))
 792       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 793         (:translate data-vector-ref-with-offset)
 794         (:policy :fast-safe)
 795         (:args (object :scs (descriptor-reg)))
 796         (:info index offset)
 797         (:arg-types ,ptype (:constant low-index)
 798                     (:constant (constant-displacement other-pointer-lowtag
 799                                                       2 vector-data-offset)))
 800         (:results (value :scs ,scs))
 801         (:result-types ,type)
 802         (:generator 4
 803           (inst ,mov-inst value
 804                 (make-ea :word :base object
 805                          :disp (- (+ (* vector-data-offset n-word-bytes)
 806                                      (* 2 index)
 807                                      (* 2 offset))
 808                                   other-pointer-lowtag)))))
 809       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 810         (:translate data-vector-set-with-offset)
 811         (:policy :fast-safe)
 812         (:args (object :scs (descriptor-reg) :to (:eval 0))
 813                (index :scs (unsigned-reg) :to (:eval 0))
 814                (value :scs ,scs :target eax))
 815         (:info offset)
 816         (:arg-types ,ptype positive-fixnum
 817                     (:constant (constant-displacement other-pointer-lowtag
 818                                                       2 vector-data-offset))
 819                     ,type)
 820         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 821                          :from (:argument 2) :to (:result 0))
 822                     eax)
 823         (:results (result :scs ,scs))
 824         (:result-types ,type)
 825         (:generator 5
 826           (move eax value)
 827           (inst mov (make-ea :word :base object :index index :scale 2
 828                              :disp (- (+ (* vector-data-offset n-word-bytes)
 829                                          (* offset 2))
 830                                       other-pointer-lowtag))
 831                 ax-tn)
 832           (move result eax)))
 833
 834       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 835         (:translate data-vector-set-with-offset)
 836         (:policy :fast-safe)
 837         (:args (object :scs (descriptor-reg) :to (:eval 0))
 838                (value :scs ,scs :target eax))
 839         (:info index offset)
 840         (:arg-types ,ptype (:constant low-index)
 841                     (:constant (constant-displacement other-pointer-lowtag
 842                                                       2 vector-data-offset))
 843                     ,type)
 844         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 845                          :from (:argument 1) :to (:result 0))
 846                     eax)
 847         (:results (result :scs ,scs))
 848         (:result-types ,type)
 849         (:generator 4
 850           (move eax value)
 851           (inst mov (make-ea :word :base object
 852                              :disp (- (+ (* vector-data-offset n-word-bytes)
 853                                          (* 2 index)
 854                                          (* 2 offset))
 855                                       other-pointer-lowtag))
 856                 ax-tn)
 857           (move result eax))))))
 858   (define-data-vector-frobs simple-array-unsigned-byte-15 movzx positive-fixnum
 859     unsigned-reg signed-reg)
 860   (define-data-vector-frobs simple-array-unsigned-byte-16 movzx positive-fixnum
 861     unsigned-reg signed-reg)
 862   (define-data-vector-frobs simple-array-signed-byte-16 movsx tagged-num
 863     signed-reg))
 864
 865 (macrolet ((define-data-vector-frobs (ptype mov-inst type &rest scs)
 866     `(progn
 867       (define-vop (,(symbolicate "DATA-VECTOR-REF/" ptype))
 868         (:translate data-vector-ref-with-offset)
 869         (:policy :fast-safe)
 870         (:args (object :scs (descriptor-reg))
 871                (index :scs (unsigned-reg)))
 872         (:info offset)
 873         (:arg-types ,ptype positive-fixnum
 874                     (:constant (constant-displacement other-pointer-lowtag
 875                                                       4 vector-data-offset)))
 876         (:results (value :scs ,scs))
 877         (:result-types ,type)
 878         (:generator 5
 879           (inst ,mov-inst value
 880                 (make-ea :dword :base object :index index :scale 4
 881                          :disp (- (+ (* vector-data-offset n-word-bytes)
 882                                      (* offset 4))
 883                                   other-pointer-lowtag)))))
 884       (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" ptype))
 885         (:translate data-vector-ref-with-offset)
 886         (:policy :fast-safe)
 887         (:args (object :scs (descriptor-reg)))
 888         (:info index offset)
 889         (:arg-types ,ptype (:constant low-index)
 890                     (:constant (constant-displacement other-pointer-lowtag
 891                                                       4 vector-data-offset)))
 892         (:results (value :scs ,scs))
 893         (:result-types ,type)
 894         (:generator 4
 895           (inst ,mov-inst value
 896                 (make-ea :dword :base object
 897                          :disp (- (+ (* vector-data-offset n-word-bytes)
 898                                      (* 4 index)
 899                                      (* 4 offset))
 900                                   other-pointer-lowtag)))))
 901       (define-vop (,(symbolicate "DATA-VECTOR-SET/" ptype))
 902         (:translate data-vector-set-with-offset)
 903         (:policy :fast-safe)
 904         (:args (object :scs (descriptor-reg) :to (:eval 0))
 905                (index :scs (unsigned-reg) :to (:eval 0))
 906                (value :scs ,scs :target rax))
 907         (:info offset)
 908         (:arg-types ,ptype positive-fixnum
 909                     (:constant (constant-displacement other-pointer-lowtag
 910                                                       4 vector-data-offset))
 911                     ,type)
 912         (:temporary (:sc unsigned-reg :offset rax-offset :target result
 913                          :from (:argument 2) :to (:result 0))
 914                     rax)
 915         (:results (result :scs ,scs))
 916         (:result-types ,type)
 917         (:generator 5
 918           (move rax value)
 919           (inst mov (make-ea :dword :base object :index index :scale 4
 920                                 :disp (- (+ (* vector-data-offset n-word-bytes)
 921                                             (* offset 4))
 922                                          other-pointer-lowtag))
 923                 eax-tn)
 924           (move result rax)))
 925
 926       (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" ptype))
 927         (:translate data-vector-set-with-offset)
 928         (:policy :fast-safe)
 929         (:args (object :scs (descriptor-reg) :to (:eval 0))
 930                (value :scs ,scs :target rax))
 931         (:info index offset)
 932         (:arg-types ,ptype (:constant low-index)
 933                     (:constant (constant-displacement other-pointer-lowtag
 934                                                       4 vector-data-offset))
 935                     ,type)
 936         (:temporary (:sc unsigned-reg :offset rax-offset :target result
 937                          :from (:argument 1) :to (:result 0))
 938                     rax)
 939         (:results (result :scs ,scs))
 940         (:result-types ,type)
 941         (:generator 4
 942           (move rax value)
 943           (inst mov (make-ea :dword :base object
 944                              :disp (- (+ (* vector-data-offset n-word-bytes)
 945                                          (* 4 index)
 946                                          (* 4 offset))
 947                                       other-pointer-lowtag))
 948                 eax-tn)
 949           (move result rax))))))
 950   (define-data-vector-frobs simple-array-unsigned-byte-32 movzxd positive-fixnum
 951     unsigned-reg signed-reg)
 952   (define-data-vector-frobs simple-array-unsigned-byte-31 movzxd positive-fixnum
 953     unsigned-reg signed-reg)
 954   (define-data-vector-frobs simple-array-signed-byte-32 movsxd tagged-num
 955     signed-reg)
 956   #!+sb-unicode
 957   (define-data-vector-frobs simple-character-string movzxd character
 958     character-reg))
 959
 960 \f
 961 ;;; These vops are useful for accessing the bits of a vector
 962 ;;; irrespective of what type of vector it is.
 963 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 964   unsigned-num %raw-bits)
 965 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 966   unsigned-num %set-raw-bits)
 967 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 968   (unsigned-reg) unsigned-num %vector-raw-bits)
 969 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 970   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 971 \f
 972 ;;;; miscellaneous array VOPs
 973
 974 (define-vop (get-vector-subtype get-header-data))
 975 (define-vop (set-vector-subtype set-header-data))