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))
 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) 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              (inst mov old
 267                    (make-ea :dword :base object
 268                             :disp (- (* (+ word vector-data-offset)
 269                                         n-word-bytes)
 270                                      other-pointer-lowtag)))
 271              (sc-case value
 272                (immediate
 273                 (let* ((value (tn-value value))
 274                        (mask ,(1- (ash 1 bits)))
 275                        (shift (* extra ,bits)))
 276                   (unless (= value mask)
 277                     (inst and old (ldb (byte n-word-bits 0)
 278                                        (lognot (ash mask shift)))))
 279                   (unless (zerop value)
 280                     (inst or old (ash value shift)))))
 281                (unsigned-reg
 282                 (let ((shift (* extra ,bits)))
 283                   (unless (zerop shift)
 284                     (inst ror old shift))
 285                   (inst and old (lognot ,(1- (ash 1 bits))))
 286                   (inst or old value)
 287                   (unless (zerop shift)
 288                     (inst rol old shift)))))
 289              (inst mov (make-ea :dword :base object
 290                                 :disp (- (* (+ word vector-data-offset)
 291                                             n-word-bytes)
 292                                          other-pointer-lowtag))
 293                    old)
 294              (sc-case value
 295                (immediate
 296                 (inst mov result (tn-value value)))
 297                (unsigned-reg
 298                 (move result value))))))))))
 299   (def-small-data-vector-frobs simple-bit-vector 1)
 300   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 301   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 302
 303 ;;; And the float variants.
 304
 305 (defun make-ea-for-float-ref (object index offset element-size
 306                               &key (scale 1) (complex-offset 0))
 307   (sc-case index
 308     (immediate
 309      (make-ea :dword :base object
 310               :disp (- (+ (* vector-data-offset n-word-bytes)
 311                           (* element-size (+ offset complex-offset
 312                                              (tn-value index)))
 313                        other-pointer-lowtag))))
 314     (t
 315      (make-ea :dword :base object :index index :scale scale
 316               :disp (- (+ (* vector-data-offset n-word-bytes)
 317                           (* element-size offset)
 318                           complex-offset)
 319                        other-pointer-lowtag)))))
 320
 321 (define-vop (data-vector-ref-with-offset/simple-array-single-float)
 322   (:note "inline array access")
 323   (:translate data-vector-ref-with-offset)
 324   (:policy :fast-safe)
 325   (:args (object :scs (descriptor-reg))
 326          (index :scs (any-reg immediate)))
 327   (:info offset)
 328   (:arg-types simple-array-single-float positive-fixnum
 329               (:constant (constant-displacement other-pointer-lowtag
 330                                                 4 vector-data-offset)))
 331   (:results (value :scs (single-reg)))
 332   (:result-types single-float)
 333   (:generator 5
 334    (with-empty-tn@fp-top(value)
 335      (inst fld (make-ea-for-float-ref object index offset 4)))))
 336
 337 (define-vop (data-vector-set-with-offset/simple-array-single-float)
 338   (:note "inline array store")
 339   (:translate data-vector-set-with-offset)
 340   (:policy :fast-safe)
 341   (:args (object :scs (descriptor-reg))
 342          (index :scs (any-reg immediate))
 343          (value :scs (single-reg) :target result))
 344   (:info offset)
 345   (:arg-types simple-array-single-float positive-fixnum
 346               (:constant (constant-displacement other-pointer-lowtag
 347                                                 4 vector-data-offset))
 348               single-float)
 349   (:results (result :scs (single-reg)))
 350   (:result-types single-float)
 351   (:generator 5
 352     (cond ((zerop (tn-offset value))
 353            ;; Value is in ST0.
 354            (inst fst (make-ea-for-float-ref object index offset 4))
 355            (unless (zerop (tn-offset result))
 356              ;; Value is in ST0 but not result.
 357              (inst fst result)))
 358           (t
 359            ;; Value is not in ST0.
 360            (inst fxch value)
 361            (inst fst (make-ea-for-float-ref object index offset 4))
 362            (cond ((zerop (tn-offset result))
 363                   ;; The result is in ST0.
 364                   (inst fst value))
 365                  (t
 366                   ;; Neither value or result are in ST0
 367                   (unless (location= value result)
 368                     (inst fst result))
 369                   (inst fxch value)))))))
 370
 371 (define-vop (data-vector-ref-with-offset/simple-array-double-float)
 372   (:note "inline array access")
 373   (:translate data-vector-ref-with-offset)
 374   (:policy :fast-safe)
 375   (:args (object :scs (descriptor-reg))
 376          (index :scs (any-reg immediate)))
 377   (:info offset)
 378   (:arg-types simple-array-double-float
 379               positive-fixnum
 380               (:constant (constant-displacement other-pointer-lowtag
 381                                                 8 vector-data-offset)))
 382   (:results (value :scs (double-reg)))
 383   (:result-types double-float)
 384   (:generator 7
 385    (with-empty-tn@fp-top(value)
 386      (inst fldd (make-ea-for-float-ref object index offset 8 :scale 2)))))
 387
 388 (define-vop (data-vector-set-with-offset/simple-array-double-float)
 389   (:note "inline array store")
 390   (:translate data-vector-set-with-offset)
 391   (:policy :fast-safe)
 392   (:args (object :scs (descriptor-reg))
 393          (index :scs (any-reg immediate))
 394          (value :scs (double-reg) :target result))
 395   (:info offset)
 396   (:arg-types simple-array-double-float positive-fixnum
 397               (:constant (constant-displacement other-pointer-lowtag
 398                                                 8 vector-data-offset))
 399               double-float)
 400   (:results (result :scs (double-reg)))
 401   (:result-types double-float)
 402   (:generator 20
 403     (cond ((zerop (tn-offset value))
 404            ;; Value is in ST0.
 405            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
 406            (unless (zerop (tn-offset result))
 407                    ;; Value is in ST0 but not result.
 408                    (inst fstd result)))
 409           (t
 410            ;; Value is not in ST0.
 411            (inst fxch value)
 412            (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
 413            (cond ((zerop (tn-offset result))
 414                   ;; The result is in ST0.
 415                   (inst fstd value))
 416                  (t
 417                   ;; Neither value or result are in ST0
 418                   (unless (location= value result)
 419                           (inst fstd result))
 420                   (inst fxch value)))))))
 421
 422 ;;; complex float variants
 423
 424 (define-vop (data-vector-ref-with-offset/simple-array-complex-single-float)
 425   (:note "inline array access")
 426   (:translate data-vector-ref-with-offset)
 427   (:policy :fast-safe)
 428   (:args (object :scs (descriptor-reg))
 429          (index :scs (any-reg immediate)))
 430   (:info offset)
 431   (:arg-types simple-array-complex-single-float positive-fixnum
 432               (:constant (constant-displacement other-pointer-lowtag
 433                                                 8 vector-data-offset)))
 434   (:results (value :scs (complex-single-reg)))
 435   (:result-types complex-single-float)
 436   (:generator 5
 437     (let ((real-tn (complex-single-reg-real-tn value)))
 438       (with-empty-tn@fp-top (real-tn)
 439         (inst fld (make-ea-for-float-ref object index offset 8 :scale 2))))
 440     (let ((imag-tn (complex-single-reg-imag-tn value)))
 441       (with-empty-tn@fp-top (imag-tn)
 442         ;; FIXME
 443         (inst fld (make-ea-for-float-ref object index offset 8
 444                                          :scale 2 :complex-offset 4))))))
 445
 446 (define-vop (data-vector-set-with-offset/simple-array-complex-single-float)
 447   (:note "inline array store")
 448   (:translate data-vector-set-with-offset)
 449   (:policy :fast-safe)
 450   (:args (object :scs (descriptor-reg))
 451          (index :scs (any-reg immediate))
 452          (value :scs (complex-single-reg) :target result))
 453   (:info offset)
 454   (:arg-types simple-array-complex-single-float positive-fixnum
 455               (:constant (constant-displacement other-pointer-lowtag
 456                                                 8 vector-data-offset))
 457               complex-single-float)
 458   (:results (result :scs (complex-single-reg)))
 459   (:result-types complex-single-float)
 460   (:generator 5
 461     (let ((value-real (complex-single-reg-real-tn value))
 462           (result-real (complex-single-reg-real-tn result)))
 463       (cond ((zerop (tn-offset value-real))
 464              ;; Value is in ST0.
 465              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
 466              (unless (zerop (tn-offset result-real))
 467                ;; Value is in ST0 but not result.
 468                (inst fst result-real)))
 469             (t
 470              ;; Value is not in ST0.
 471              (inst fxch value-real)
 472              (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
 473              (cond ((zerop (tn-offset result-real))
 474                     ;; The result is in ST0.
 475                     (inst fst value-real))
 476                    (t
 477                     ;; Neither value or result are in ST0
 478                     (unless (location= value-real result-real)
 479                       (inst fst result-real))
 480                     (inst fxch value-real))))))
 481     (let ((value-imag (complex-single-reg-imag-tn value))
 482           (result-imag (complex-single-reg-imag-tn result)))
 483       (inst fxch value-imag)
 484       (inst fst (make-ea-for-float-ref object index offset 8
 485                                        :scale 2 :complex-offset 4))
 486       (unless (location= value-imag result-imag)
 487         (inst fst result-imag))
 488       (inst fxch value-imag))))
 489
 490 (define-vop (data-vector-ref-with-offset/simple-array-complex-double-float)
 491   (:note "inline array access")
 492   (:translate data-vector-ref-with-offset)
 493   (:policy :fast-safe)
 494   (:args (object :scs (descriptor-reg))
 495          (index :scs (any-reg immediate)))
 496   (:info offset)
 497   (:arg-types simple-array-complex-double-float positive-fixnum
 498               (:constant (constant-displacement other-pointer-lowtag
 499                                                 16 vector-data-offset)))
 500   (:results (value :scs (complex-double-reg)))
 501   (:result-types complex-double-float)
 502   (:generator 7
 503     (let ((real-tn (complex-double-reg-real-tn value)))
 504       (with-empty-tn@fp-top (real-tn)
 505         (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4)))
 506     (let ((imag-tn (complex-double-reg-imag-tn value)))
 507       (with-empty-tn@fp-top (imag-tn)
 508         (inst fldd (make-ea-for-float-ref object index offset 16
 509                                           :scale 4 :complex-offset 8)))))))
 510
 511 (define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
 512   (:note "inline array store")
 513   (:translate data-vector-set-with-offset)
 514   (:policy :fast-safe)
 515   (:args (object :scs (descriptor-reg))
 516          (index :scs (any-reg immediate))
 517          (value :scs (complex-double-reg) :target result))
 518   (:info offset)
 519   (:arg-types simple-array-complex-double-float positive-fixnum
 520               (:constant (constant-displacement other-pointer-lowtag
 521                                                 16 vector-data-offset))
 522               complex-double-float)
 523   (:results (result :scs (complex-double-reg)))
 524   (:result-types complex-double-float)
 525   (:generator 20
 526     (let ((value-real (complex-double-reg-real-tn value))
 527           (result-real (complex-double-reg-real-tn result)))
 528       (cond ((zerop (tn-offset value-real))
 529              ;; Value is in ST0.
 530              (inst fstd (make-ea-for-float-ref object index offset 16
 531                                                :scale 4))
 532              (unless (zerop (tn-offset result-real))
 533                ;; Value is in ST0 but not result.
 534                (inst fstd result-real)))
 535             (t
 536              ;; Value is not in ST0.
 537              (inst fxch value-real)
 538              (inst fstd (make-ea-for-float-ref object index offset 16
 539                                                :scale 4))
 540              (cond ((zerop (tn-offset result-real))
 541                     ;; The result is in ST0.
 542                     (inst fstd value-real))
 543                    (t
 544                     ;; Neither value or result are in ST0
 545                     (unless (location= value-real result-real)
 546                       (inst fstd result-real))
 547                     (inst fxch value-real))))))
 548     (let ((value-imag (complex-double-reg-imag-tn value))
 549           (result-imag (complex-double-reg-imag-tn result)))
 550       (inst fxch value-imag)
 551       (inst fstd (make-ea-for-float-ref object index offset 16
 552                                         :scale 4 :complex-offset 8))
 553       (unless (location= value-imag result-imag)
 554         (inst fstd result-imag))
 555       (inst fxch value-imag))))
 556
 557 \f
 558 ;;; {un,}signed-byte-8, simple-base-string
 559
 560 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs)
 561   `(progn
 562     (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
 563       (:translate data-vector-ref-with-offset)
 564       (:policy :fast-safe)
 565       (:args (object :scs (descriptor-reg))
 566              (index :scs (unsigned-reg immediate)))
 567       (:info offset)
 568       (:arg-types ,ptype positive-fixnum
 569                   (:constant (constant-displacement other-pointer-lowtag
 570                                                     1 vector-data-offset)))
 571       (:results (value :scs ,scs))
 572       (:result-types ,element-type)
 573       (:generator 5
 574         (sc-case index
 575           (immediate
 576            (inst ,ref-inst value
 577                  (make-ea :byte :base object
 578                           :disp (- (+ (* vector-data-offset n-word-bytes)
 579                                       (tn-value index)
 580                                       offset)
 581                                    other-pointer-lowtag))))
 582           (t
 583            (inst ,ref-inst value
 584                  (make-ea :byte :base object :index index :scale 1
 585                           :disp (- (+ (* vector-data-offset n-word-bytes)
 586                                       offset)
 587                                    other-pointer-lowtag)))))))
 588     (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
 589       (:translate data-vector-set-with-offset)
 590       (:policy :fast-safe)
 591       (:args (object :scs (descriptor-reg) :to (:eval 0))
 592              (index :scs (unsigned-reg immediate) :to (:eval 0))
 593              (value :scs ,scs :target eax))
 594       (:info offset)
 595       (:arg-types ,ptype positive-fixnum
 596                   (:constant (constant-displacement other-pointer-lowtag
 597                                                     1 vector-data-offset))
 598                   ,element-type)
 599       (:temporary (:sc unsigned-reg :offset eax-offset :target result
 600                        :from (:argument 2) :to (:result 0))
 601                   eax)
 602       (:results (result :scs ,scs))
 603       (:result-types ,element-type)
 604       (:generator 5
 605         (move eax value)
 606         (sc-case index
 607           (immediate
 608            (inst mov (make-ea :byte :base object
 609                               :disp (- (+ (* vector-data-offset n-word-bytes)
 610                                           (tn-value index)
 611                                           offset)
 612                                        other-pointer-lowtag))
 613                  al-tn))
 614           (t
 615            (inst mov (make-ea :byte :base object :index index :scale 1
 616                               :disp (- (+ (* vector-data-offset n-word-bytes)
 617                                           offset)
 618                                        other-pointer-lowtag))
 619                  al-tn)))
 620         (move result eax))))))
 621   (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
 622     movzx unsigned-reg signed-reg)
 623   (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
 624     movzx unsigned-reg signed-reg)
 625   (define-data-vector-frobs simple-array-signed-byte-8 tagged-num
 626     movsx signed-reg)
 627   (define-data-vector-frobs simple-base-string character movzx character-reg))
 628
 629 ;;; {un,}signed-byte-16
 630 (macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs)
 631     `(progn
 632       (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
 633         (:translate data-vector-ref-with-offset)
 634         (:policy :fast-safe)
 635         (:args (object :scs (descriptor-reg))
 636                (index :scs (unsigned-reg immediate)))
 637         (:info offset)
 638         (:arg-types ,ptype positive-fixnum
 639                     (:constant (constant-displacement other-pointer-lowtag
 640                                                       2 vector-data-offset)))
 641         (:results (value :scs ,scs))
 642         (:result-types ,element-type)
 643         (:generator 5
 644           (sc-case index
 645             (immediate
 646              (inst ,ref-inst value
 647                    (make-ea :word :base object
 648                             :disp (- (+ (* vector-data-offset n-word-bytes)
 649                                         (* 2 (+ offset (tn-value index)))
 650                                      other-pointer-lowtag)))))
 651             (t
 652              (inst ,ref-inst value
 653                    (make-ea :word :base object :index index :scale 2
 654                             :disp (- (+ (* vector-data-offset n-word-bytes)
 655                                         (* 2 offset))
 656                                      other-pointer-lowtag)))))))
 657       (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
 658         (:translate data-vector-set-with-offset)
 659         (:policy :fast-safe)
 660         (:args (object :scs (descriptor-reg) :to (:eval 0))
 661                (index :scs (unsigned-reg immediate) :to (:eval 0))
 662                (value :scs ,scs :target eax))
 663         (:info offset)
 664         (:arg-types ,ptype positive-fixnum
 665                     (:constant (constant-displacement other-pointer-lowtag
 666                                                       2 vector-data-offset))
 667                     ,element-type)
 668         (:temporary (:sc unsigned-reg :offset eax-offset :target result
 669                          :from (:argument 2) :to (:result 0))
 670                     eax)
 671         (:results (result :scs ,scs))
 672         (:result-types ,element-type)
 673         (:generator 5
 674           (move eax value)
 675           (sc-case index
 676             (immediate
 677              (inst mov (make-ea :word :base object
 678                                 :disp (- (+ (* vector-data-offset n-word-bytes)
 679                                             (* 2 (+ offset (tn-value index))))
 680                                          other-pointer-lowtag))
 681                    ax-tn))
 682             (t
 683              (inst mov (make-ea :word :base object :index index :scale 2
 684                                 :disp (- (+ (* vector-data-offset n-word-bytes)
 685                                             (* 2 offset))
 686                                          other-pointer-lowtag))
 687                    ax-tn)))
 688           (move result eax))))))
 689   (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
 690     movzx unsigned-reg signed-reg)
 691   (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
 692     movzx unsigned-reg signed-reg)
 693   (define-data-vector-frobs simple-array-signed-byte-16 tagged-num
 694     movsx signed-reg))
 695
 696 \f
 697 ;;; These vops are useful for accessing the bits of a vector
 698 ;;; irrespective of what type of vector it is.
 699 (define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 700   unsigned-num %raw-bits)
 701 (define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
 702   unsigned-num %set-raw-bits)
 703 (define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
 704   (unsigned-reg) unsigned-num %vector-raw-bits)
 705 (define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
 706   (unsigned-reg) unsigned-num %set-vector-raw-bits)
 707 \f
 708 ;;;; miscellaneous array VOPs
 709
 710 (define-vop (get-vector-subtype get-header-data))
 711 (define-vop (set-vector-subtype set-header-data))