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