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 \f
 154 ;;;; integer vectors whose elements are smaller than a byte, i.e.,
 155 ;;;; bit, 2-bit, and 4-bit vectors
 156
 157 (macrolet ((def-small-data-vector-frobs (type bits)
 158              (let* ((elements-per-word (floor n-word-bits bits))
 159                     (bit-shift (1- (integer-length elements-per-word))))
 160     `(progn
 161        (define-vop (,(symbolicate 'data-vector-ref/ type))
 162          (:note "inline array access")
 163          (:translate data-vector-ref)
 164          (:policy :fast-safe)
 165          (:args (object :scs (descriptor-reg))
 166                 (index :scs (unsigned-reg)))
 167          (:arg-types ,type positive-fixnum)
 168          (:results (result :scs (unsigned-reg) :from (:argument 0)))
 169          (:result-types positive-fixnum)
 170          (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)
 171          (:generator 20
 172            (move ecx index)
 173            (inst shr ecx ,bit-shift)
 174            (inst mov result
 175                  (make-ea :dword :base object :index ecx :scale 4
 176                           :disp (- (* vector-data-offset n-word-bytes)
 177                                    other-pointer-lowtag)))
 178            (move ecx index)
 179            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
 180            ;; but since Intel's documentation says that the chip will
 181            ;; mask shift and rotate counts by 31 automatically, we can
 182            ;; safely move the masking operation under the protection of
 183            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
 184            ,@(unless (= elements-per-word n-word-bits)
 185                `((inst and ecx ,(1- elements-per-word))
 186                  (inst shl ecx ,(1- (integer-length bits)))))
 187            (inst shr result :cl)
 188            (inst and result ,(1- (ash 1 bits)))))
 189        (define-vop (,(symbolicate 'data-vector-ref-c/ type))
 190          (:translate data-vector-ref)
 191          (:policy :fast-safe)
 192          (:args (object :scs (descriptor-reg)))
 193          (:arg-types ,type (:constant index))
 194          (:info index)
 195          (:results (result :scs (unsigned-reg)))
 196          (:result-types positive-fixnum)
 197          (:generator 15
 198            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 199              (loadw result object (+ word vector-data-offset)
 200                     other-pointer-lowtag)
 201              (unless (zerop extra)
 202                (inst shr result (* extra ,bits)))
 203              (unless (= extra ,(1- elements-per-word))
 204                (inst and result ,(1- (ash 1 bits)))))))
 205        (define-vop (,(symbolicate 'data-vector-set/ type))
 206          (:note "inline array store")
 207          (:translate data-vector-set)
 208          (:policy :fast-safe)
 209          (:args (object :scs (descriptor-reg) :to (:argument 2))
 210                 (index :scs (unsigned-reg) :target ecx)
 211                 (value :scs (unsigned-reg immediate) :target result))
 212          (:arg-types ,type positive-fixnum positive-fixnum)
 213          (:results (result :scs (unsigned-reg)))
 214          (:result-types positive-fixnum)
 215          (:temporary (:sc unsigned-reg) word-index)
 216          (:temporary (:sc unsigned-reg) old)
 217          (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
 218          (:generator 25
 219            (move word-index index)
 220            (inst shr word-index ,bit-shift)
 221            (inst mov old
 222                  (make-ea :dword :base object :index word-index :scale 4
 223                           :disp (- (* vector-data-offset n-word-bytes)
 224                                    other-pointer-lowtag)))
 225            (move ecx index)
 226            ;; We used to mask ECX for all values of ELEMENT-PER-WORD,
 227            ;; but since Intel's documentation says that the chip will
 228            ;; mask shift and rotate counts by 31 automatically, we can
 229            ;; safely move the masking operation under the protection of
 230            ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
 231            ,@(unless (= elements-per-word n-word-bits)
 232                `((inst and ecx ,(1- elements-per-word))
 233                  (inst shl ecx ,(1- (integer-length bits)))))
 234            (inst ror old :cl)
 235            (unless (and (sc-is value immediate)
 236                         (= (tn-value value) ,(1- (ash 1 bits))))
 237              (inst and old ,(lognot (1- (ash 1 bits)))))
 238            (sc-case value
 239              (immediate
 240               (unless (zerop (tn-value value))
 241                 (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
 242              (unsigned-reg
 243               (inst or old value)))
 244            (inst rol old :cl)
 245            (inst mov (make-ea :dword :base object :index word-index :scale 4
 246                               :disp (- (* vector-data-offset n-word-bytes)
 247                                        other-pointer-lowtag))
 248                  old)
 249            (sc-case value
 250              (immediate
 251               (inst mov result (tn-value value)))
 252              (unsigned-reg
 253               (move result value)))))
 254        (define-vop (,(symbolicate 'data-vector-set-c/ type))
 255          (:translate data-vector-set)
 256          (:policy :fast-safe)
 257          (:args (object :scs (descriptor-reg))
 258                 (value :scs (unsigned-reg immediate) :target result))
 259          (:arg-types ,type (:constant index) positive-fixnum)
 260          (:info index)
 261          (:results (result :scs (unsigned-reg)))
 262          (:result-types positive-fixnum)
 263          (:temporary (:sc unsigned-reg :to (:result 0)) old)
 264          (:generator 20
 265            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 266              (loadw old object (+ word vector-data-offset) other-pointer-lowtag)
 267              (sc-case value
 268                (immediate
 269                 (let* ((value (tn-value value))
 270                        (mask ,(1- (ash 1 bits)))
 271                        (shift (* extra ,bits)))
 272                   (unless (= value mask)
 273                     (inst and old (ldb (byte n-word-bits 0)
 274                                        (lognot (ash mask shift)))))
 275                   (unless (zerop value)
 276                     (inst or old (ash value shift)))))
 277                (unsigned-reg
 278                 (let ((shift (* extra ,bits)))
 279                   (unless (zerop shift)
 280                     (inst ror old shift))
 281                   (inst and old (lognot ,(1- (ash 1 bits))))
 282                   (inst or old value)
 283                   (unless (zerop shift)
 284                     (inst rol old shift)))))
 285              (storew old object (+ word vector-data-offset) other-pointer-lowtag)
 286              (sc-case value
 287                (immediate
 288                 (inst mov result (tn-value value)))
 289                (unsigned-reg
 290                 (move result value))))))))))
 291   (def-small-data-vector-frobs simple-bit-vector 1)
 292   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 293   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 294
 295 ;;; And the float variants.
 296
 297 (defun make-ea-for-float-ref (object index offset element-size
 298                               &key (scale 1) (complex-offset 0))
 299   (sc-case index
 300     (immediate
 301      (make-ea :dword :base object
 302               :disp (- (+ (* vector-data-offset n-word-bytes)
 303                           (* element-size (+ offset (tn-value index)))
 304                           complex-offset)
 305                        other-pointer-lowtag)))
 306     (t
 307      (make-ea :dword :base object :index index :scale scale
 308               :disp (- (+ (* vector-data-offset n-word-bytes)
 309                           (* element-size offset)
 310                           complex-offset)
 311                        other-pointer-lowtag)))))
 312
 313 (define-vop (data-vector-ref-with-offset/simple-array-single-float)
 314   (:note "inline array access")
 315   (:translate data-vector-ref-with-offset)
 316   (:policy :fast-safe)
 317   (:args (object :scs (descriptor-reg))
 318          (index :scs (any-reg immediate)))
 319   (:info offset)
 320   (:arg-types simple-array-single-float positive-fixnum
 321               (:constant (constant-displacement other-pointer-lowtag
 322                                                 4 vector-data-offset)))
 323   (:results (value :scs (single-reg)))
 324   (:result-types single-float)
 325   (:generator 5
 326    (with-empty-tn@fp-top(value)
 327      (inst fld (make-ea-for-float-ref object index offset 4)))))
 328
 329 (define-vop (data-vector-set-with-offset/simple-array-single-float)
 330   (:note "inline array store")
 331   (:translate data-vector-set-with-offset)
 332   (:policy :fast-safe)
 333   (:args (object :scs (descriptor-reg))
 334          (index :scs (any-reg immediate))
 335          (value :scs (single-reg) :target result))
 336   (:info offset)
 337   (:arg-types simple-array-single-float positive-fixnum
 338               (:constant (constant-displacement other-pointer-lowtag
 339                                                 4 vector-data-offset))
 340               single-float)
 341   (:results (result :scs (single-reg)))
 342   (:result-types single-float)
 343   (:generator 5
 344     (cond ((zerop (tn-offset value))
 345            ;; Value is in ST0.
 346            (inst fst (make-ea-for-float-ref object index offset 4))
 347            (unless (zerop (tn-offset result))
 348              ;; Value is in ST0 but not result.
 349              (inst fst result)))
 350           (t
 351            ;; Value is not in ST0.
 352            (inst fxch value)
 353            (inst fst (make-ea-for-float-ref object index offset 4))
 354            (cond ((zerop (tn-offset result))
 355                   ;; The result is in ST0.
 356                   (inst fst value))
 357                  (t
 358                   ;; Neither value or result are in ST0
 359                   (unless (location= value result)
 360                     (inst fst result))
 361                   (inst fxch value)))))))
 362
 363 (define-vop (data-vector-ref-with-offset/simple-array-double-float)
 364   (:note "inline array access")
 365   (:translate data-vector-ref-with-offset)
 366   (:policy :fast-safe)
 367   (:args (object :scs (descriptor-reg))
 368          (index :scs (any-reg immediate)))
 369   (:info offset)
 370   (:arg-types simple-array-double-float
 371               positive-fixnum
 372               (:constant (constant-displacement other-pointer-lowtag
 373                                                 8 vector-data-offset)))
 374   (:results (value :scs (double-reg)))
 375   (:result-types double-float)
 376   (:generator 7
 377    (with-empty-tn@fp-top(value)
 378      (inst fldd (make-ea-for-float-ref object index offset 8 :scale 2)))))
 379
 380 (define-vop (data-vector-set-with-offset/simple-array-double-float)
 381   (:note "inline array store")
 382   (:translate data-vector-set-with-offset)
 383   (:policy :fast-safe)
 384   (:args (object :scs (descriptor-reg))
 385          (index :scs (any-reg immediate))
 386          (value :scs (double-reg) :target result))
 387   (:info offset)
 388   (:arg-types simple-array-double-float positive-fixnum
 389               (:constant (constant-displacement other-pointer-lowtag
 390                                                 8 vector-data-offset))
 391               double-float)
 392   (:results (result :scs (double-reg)))
 393   (:result-types double-float)
 394   (:generator 20
 395     (cond ((zerop (tn-offset value))
 396            ;; Value is in ST0.
 397            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
 398            (unless (zerop (tn-offset result))
 399                    ;; Value is in ST0 but not result.
 400                    (inst fstd result)))
 401           (t
 402            ;; Value is not in ST0.
 403            (inst fxch value)
 404            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
 405            (cond ((zerop (tn-offset result))
 406                   ;; The result is in ST0.
 407                   (inst fstd value))
 408                  (t
 409                   ;; Neither value or result are in ST0
 410                   (unless (location= value result)
 411                           (inst fstd result))
 412                   (inst fxch value)))))))
 413
 414 ;;; complex float variants
 415
 416 (define-vop (data-vector-ref-with-offset/simple-array-complex-single-float)
 417   (:note "inline array access")
 418   (:translate data-vector-ref-with-offset)
 419   (:policy :fast-safe)
 420   (:args (object :scs (descriptor-reg))
 421          (index :scs (any-reg immediate)))
 422   (:info offset)
 423   (:arg-types simple-array-complex-single-float positive-fixnum
 424               (:constant (constant-displacement other-pointer-lowtag
 425                                                 8 vector-data-offset)))
 426   (:results (value :scs (complex-single-reg)))
 427   (:result-types complex-single-float)
 428   (:generator 5
 429     (let ((real-tn (complex-single-reg-real-tn value)))
 430       (with-empty-tn@fp-top (real-tn)
 431         (inst fld (make-ea-for-float-ref object index offset 8 :scale 2))))
 432     (let ((imag-tn (complex-single-reg-imag-tn value)))
 433       (with-empty-tn@fp-top (imag-tn)
 434         ;; FIXME
 435         (inst fld (make-ea-for-float-ref object index offset 8
 436                                          :scale 2 :complex-offset 4))))))
 437
 438 (define-vop (data-vector-set-with-offset/simple-array-complex-single-float)
 439   (:note "inline array store")
 440   (:translate data-vector-set-with-offset)
 441   (:policy :fast-safe)
 442   (:args (object :scs (descriptor-reg))
 443          (index :scs (any-reg immediate))
 444          (value :scs (complex-single-reg) :target result))
 445   (:info offset)
 446   (:arg-types simple-array-complex-single-float positive-fixnum
 447               (:constant (constant-displacement other-pointer-lowtag
 448                                                 8 vector-data-offset))
 449               complex-single-float)
 450   (:results (result :scs (complex-single-reg)))
 451   (:result-types complex-single-float)
 452   (:generator 5
 453     (let ((value-real (complex-single-reg-real-tn value))
 454           (result-real (complex-single-reg-real-tn result)))
 455       (cond ((zerop (tn-offset value-real))
 456              ;; Value is in ST0.
 457              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
 458              (unless (zerop (tn-offset result-real))
 459                ;; Value is in ST0 but not result.
 460                (inst fst result-real)))
 461             (t
 462              ;; Value is not in ST0.
 463              (inst fxch value-real)
 464              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
 465              (cond ((zerop (tn-offset result-real))
 466                     ;; The result is in ST0.
 467                     (inst fst value-real))
 468                    (t
 469                     ;; Neither value or result are in ST0
 470                     (unless (location= value-real result-real)
 471                       (inst fst result-real))
 472                     (inst fxch value-real))))))
 473     (let ((value-imag (complex-single-reg-imag-tn value))
 474           (result-imag (complex-single-reg-imag-tn result)))
 475       (inst fxch value-imag)
 476       (inst fst (make-ea-for-float-ref object index offset 8
 477                                        :scale 2 :complex-offset 4))
 478       (unless (location= value-imag result-imag)
 479         (inst fst result-imag))
 480       (inst fxch value-imag))))
 481
 482 (define-vop (data-vector-ref-with-offset/simple-array-complex-double-float)
 483   (:note "inline array access")
 484   (:translate data-vector-ref-with-offset)
 485   (:policy :fast-safe)
 486   (:args (object :scs (descriptor-reg))
 487          (index :scs (any-reg immediate)))
 488   (:info offset)
 489   (:arg-types simple-array-complex-double-float positive-fixnum
 490               (:constant (constant-displacement other-pointer-lowtag
 491                                                 16 vector-data-offset)))
 492   (:results (value :scs (complex-double-reg)))
 493   (:result-types complex-double-float)
 494   (:generator 7
 495     (let ((real-tn (complex-double-reg-real-tn value)))
 496       (with-empty-tn@fp-top (real-tn)
 497         (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4)))
 498     (let ((imag-tn (complex-double-reg-imag-tn value)))
 499       (with-empty-tn@fp-top (imag-tn)
 500         (inst fldd (make-ea-for-float-ref object index offset 16
 501                                           :scale 4 :complex-offset 8)))))))
 502
 503 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
 504   (:note "inline array store")
 505   (:translate data-vector-set-with-offset)
 506   (:policy :fast-safe)
 507   (:args (object :scs (descriptor-reg))
 508          (index :scs (any-reg immediate))
 509          (value :scs (complex-double-reg) :target result))
 510   (:info offset)
 511   (:arg-types simple-array-complex-double-float positive-fixnum
 512               (:constant (constant-displacement other-pointer-lowtag
 513                                                 16 vector-data-offset))
 514               complex-double-float)
 515   (:results (result :scs (complex-double-reg)))
 516   (:result-types complex-double-float)
 517   (:generator 20
 518     (let ((value-real (complex-double-reg-real-tn value))
 519           (result-real (complex-double-reg-real-tn result)))
 520       (cond ((zerop (tn-offset value-real))
 521              ;; Value is in ST0.
 522              (inst fstd (make-ea-for-float-ref object index offset 16
 523                                                :scale 4))
 524              (unless (zerop (tn-offset result-real))
 525                ;; Value is in ST0 but not result.
 526                (inst fstd result-real)))
 527             (t
 528              ;; Value is not in ST0.
 529              (inst fxch value-real)
 530              (inst fstd (make-ea-for-float-ref object index offset 16
 531                                                :scale 4))
 532              (cond ((zerop (tn-offset result-real))
 533                     ;; The result is in ST0.
 534                     (inst fstd value-real))
 535                    (t
 536                     ;; Neither value or result are in ST0
 537                     (unless (location= value-real result-real)
 538                       (inst fstd result-real))
 539                     (inst fxch value-real))))))
 540     (let ((value-imag (complex-double-reg-imag-tn value))
 541           (result-imag (complex-double-reg-imag-tn result)))
 542       (inst fxch value-imag)
 543       (inst fstd (make-ea-for-float-ref object index offset 16
 544                                         :scale 4 :complex-offset 8))
 545       (unless (location= value-imag result-imag)
 546         (inst fstd result-imag))
 547       (inst fxch value-imag))))
 548
 549 \f
 550 ;;; {un,}signed-byte-8, simple-base-string
 551
 552 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst
 553                                             8-bit-tns-p &rest scs)
 554   `(progn
 555     (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
 556       (:translate data-vector-ref-with-offset)
 557       (:policy :fast-safe)
 558       (:args (object :scs (descriptor-reg))
 559              (index :scs (unsigned-reg immediate)))
 560       (:info offset)
 561       (:arg-types ,ptype positive-fixnum
 562                   (:constant (constant-displacement other-pointer-lowtag
 563                                                     1 vector-data-offset)))
 564       (:results (value :scs ,scs))
 565       (:result-types ,element-type)
 566       (:generator 5
 567         (sc-case index
 568           (immediate
 569            (inst ,ref-inst value
 570                  (make-ea :byte :base object
 571                           :disp (- (+ (* vector-data-offset n-word-bytes)
 572                                       (tn-value index)
 573                                       offset)
 574                                    other-pointer-lowtag))))
 575           (t
 576            (inst ,ref-inst value
 577                  (make-ea :byte :base object :index index :scale 1
 578                           :disp (- (+ (* vector-data-offset n-word-bytes)
 579                                       offset)
 580                                    other-pointer-lowtag)))))))
 581     (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
 582       (:translate data-vector-set-with-offset)
 583       (:policy :fast-safe)
 584       (:args (object :scs (descriptor-reg) :to (:eval 0))
 585              (index :scs (unsigned-reg immediate) :to (:eval 0))
 586              (value :scs ,scs ,@(unless 8-bit-tns-p
 587                                   '(:target eax))))
 588       (:info offset)
 589       (:arg-types ,ptype positive-fixnum
 590                   (:constant (constant-displacement other-pointer-lowtag
 591                                                     1 vector-data-offset))
 592                   ,element-type)
 593       ,@(unless 8-bit-tns-p
 594          '((:temporary (:sc unsigned-reg :offset eax-offset :target result
 595                         :from (:argument 2) :to (:result 0))
 596             eax)))
 597       (:results (result :scs ,scs))
 598       (:result-types ,element-type)
 599       (:generator 5
 600         ,@(unless 8-bit-tns-p
 601            '((move eax value)))
 602         (sc-case index
 603           (immediate
 604            (inst mov (make-ea :byte :base object
 605                               :disp (- (+ (* vector-data-offset n-word-bytes)
 606                                           (tn-value index)
 607                                           offset)
 608                                        other-pointer-lowtag))
 609                  ,(if 8-bit-tns-p
 610                       'value
 611                       'al-tn)))
 612           (t
 613            (inst mov (make-ea :byte :base object :index index :scale 1
 614                               :disp (- (+ (* vector-data-offset n-word-bytes)
 615                                           offset)
 616                                        other-pointer-lowtag))
 617                  ,(if 8-bit-tns-p
 618                       'value
 619                       'al-tn))))
 620         (move result ,(if 8-bit-tns-p
 621                           'value
 622                           'eax)))))))
 623   (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
 624     movzx nil unsigned-reg signed-reg)
 625   (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
 626     movzx nil unsigned-reg signed-reg)
 627   (define-data-vector-frobs simple-array-signed-byte-8 tagged-num
 628     movsx nil signed-reg)
 629   (define-data-vector-frobs simple-base-string character
 630                             #!+sb-unicode movzx #!-sb-unicode mov
 631                             #!+sb-unicode nil #!-sb-unicode t character-reg))
 632
 633 ;;; {un,}signed-byte-16
 634 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs)
 635     `(progn
 636       (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
 637         (:translate data-vector-ref-with-offset)
 638         (:policy :fast-safe)
 639         (:args (object :scs (descriptor-reg))
 640                (index :scs (unsigned-reg immediate)))
 641         (:info offset)
 642         (:arg-types ,ptype positive-fixnum
 643                     (:constant (constant-displacement other-pointer-lowtag
 644                                                       2 vector-data-offset)))
 645         (:results (value :scs ,scs))
 646         (:result-types ,element-type)
 647         (:generator 5
 648           (sc-case index
 649             (immediate
 650              (inst ,ref-inst value
 651                    (make-ea :word :base object
 652                             :disp (- (+ (* vector-data-offset n-word-bytes)
 653                                         (* 2 (+ offset (tn-value index))))
 654                                      other-pointer-lowtag))))
 655             (t
 656              (inst ,ref-inst value
 657                    (make-ea :word :base object :index index :scale 2
 658                             :disp (- (+ (* vector-data-offset n-word-bytes)
 659                                         (* 2 offset))
 660                                      other-pointer-lowtag)))))))
 661       (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
 662         (:translate data-vector-set-with-offset)
 663         (:policy :fast-safe)
 664         (:args (object :scs (descriptor-reg) :to (:eval 0))
 665                (index :scs (unsigned-reg immediate) :to (:eval 0))
 666                (value :scs ,scs :target eax))
 667         (:info offset)
 668         (:arg-types ,ptype positive-fixnum
 669                     (:constant (constant-displacement other-pointer-lowtag
 670                                                       2 vector-data-offset))
 671                     ,element-type)
 672         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 673                          :from (:argument 2) :to (:result 0))
 674                     eax)
 675         (:results (result :scs ,scs))
 676         (:result-types ,element-type)
 677         (:generator 5
 678           (move eax value)
 679           (sc-case index
 680             (immediate
 681              (inst mov (make-ea :word :base object
 682                                 :disp (- (+ (* vector-data-offset n-word-bytes)
 683                                             (* 2 (+ offset (tn-value index))))
 684                                          other-pointer-lowtag))
 685                    ax-tn))
 686             (t
 687              (inst mov (make-ea :word :base object :index index :scale 2
 688                                 :disp (- (+ (* vector-data-offset n-word-bytes)
 689                                             (* 2 offset))
 690                                          other-pointer-lowtag))
 691                    ax-tn)))
 692           (move result eax))))))
 693   (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
 694     movzx unsigned-reg signed-reg)
 695   (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
 696     movzx unsigned-reg signed-reg)
 697   (define-data-vector-frobs simple-array-signed-byte-16 tagged-num
 698     movsx signed-reg))
 699
 700 \f
 701 ;;; These vops are useful for accessing the bits of a vector
 702 ;;; irrespective of what type of vector it is.
 703 (define-full-reffer+offset raw-bits-with-offset * 0 other-pointer-lowtag (unsigned-reg)
 704   unsigned-num %raw-bits-with-offset)
 705 (define-full-setter+offset set-raw-bits-with-offset * 0 other-pointer-lowtag (unsigned-reg)
 706   unsigned-num %set-raw-bits-with-offset)
 707
 708 \f
 709 ;;;; miscellaneous array VOPs
 710
 711 (define-vop (get-vector-subtype get-header-data))
 712 (define-vop (set-vector-subtype set-header-data))