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