src/compiler/sparc/array.lisp

   1 ;;;; the Sparc definitions for array operations
   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 (define-vop (make-array-header)
  16   (:translate make-array-header)
  17   (:policy :fast-safe)
  18   (:args (type :scs (any-reg))
  19          (rank :scs (any-reg)))
  20   (:arg-types tagged-num tagged-num)
  21   (:temporary (:scs (descriptor-reg) :to (:result 0) :target result) header)
  22   (:temporary (:scs (non-descriptor-reg)) ndescr)
  23   (:temporary (:scs (non-descriptor-reg)) gencgc-temp)
  24   (:results (result :scs (descriptor-reg)))
  25   (:generator 0
  26     (pseudo-atomic ()
  27       (inst add ndescr rank (+ (* (1+ array-dimensions-offset) n-word-bytes)
  28                                lowtag-mask))
  29       (inst andn ndescr lowtag-mask)
  30       (allocation header ndescr other-pointer-lowtag :temp-tn gencgc-temp)
  31       (inst add ndescr rank (fixnumize (1- array-dimensions-offset)))
  32       (inst sll ndescr ndescr n-widetag-bits)
  33       (inst or ndescr ndescr type)
  34       ;; Remove the extraneous fixnum tag bits because TYPE and RANK
  35       ;; were fixnums
  36       (inst srl ndescr ndescr n-fixnum-tag-bits)
  37       (storew ndescr header 0 other-pointer-lowtag))
  38     (move result header)))
  39 \f
  40 ;;;; Additional accessors and setters for the array header.
  41 (define-vop (%array-dimension word-index-ref)
  42   (:translate sb!kernel:%array-dimension)
  43   (:policy :fast-safe)
  44   (:variant array-dimensions-offset other-pointer-lowtag))
  45
  46 (define-vop (%set-array-dimension word-index-set)
  47   (:translate sb!kernel:%set-array-dimension)
  48   (:policy :fast-safe)
  49   (:variant array-dimensions-offset other-pointer-lowtag))
  50
  51 (define-vop (array-rank-vop)
  52   (:translate sb!kernel:%array-rank)
  53   (:policy :fast-safe)
  54   (:args (x :scs (descriptor-reg)))
  55   (:temporary (:scs (non-descriptor-reg)) temp)
  56   (:results (res :scs (any-reg descriptor-reg)))
  57   (:generator 6
  58     (loadw temp x 0 other-pointer-lowtag)
  59     (inst sra temp n-widetag-bits)
  60     (inst sub temp (1- array-dimensions-offset))
  61     (inst sll res temp n-fixnum-tag-bits)))
  62 \f
  63 ;;;; Bounds checking routine.
  64 (define-vop (check-bound)
  65   (:translate %check-bound)
  66   (:policy :fast-safe)
  67   (:args (array :scs (descriptor-reg))
  68          (bound :scs (any-reg descriptor-reg))
  69          (index :scs (any-reg descriptor-reg) :target result))
  70   (:results (result :scs (any-reg descriptor-reg)))
  71   (:vop-var vop)
  72   (:save-p :compute-only)
  73   (:generator 5
  74     (let ((error (generate-error-code vop invalid-array-index-error
  75                                       array bound index)))
  76       (inst cmp index bound)
  77       (inst b :geu error)
  78       (inst nop)
  79       (move result index))))
  80 \f
  81 ;;;; Accessors/Setters
  82
  83 ;;; Variants built on top of word-index-ref, etc.  I.e. those vectors whos
  84 ;;; elements are represented in integer registers and are built out of
  85 ;;; 8, 16, or 32 bit elements.
  86 (macrolet ((def-data-vector-frobs (type variant element-type &rest scs)
  87   `(progn
  88      (define-vop (,(symbolicate "DATA-VECTOR-REF/" (string type))
  89                   ,(symbolicate (string variant) "-REF"))
  90        (:note "inline array access")
  91        (:variant vector-data-offset other-pointer-lowtag)
  92        (:translate data-vector-ref)
  93        (:arg-types ,type positive-fixnum)
  94        (:results (value :scs ,scs))
  95        (:result-types ,element-type))
  96      (define-vop (,(symbolicate "DATA-VECTOR-SET/" (string type))
  97                   ,(symbolicate (string variant) "-SET"))
  98        (:note "inline array store")
  99        (:variant vector-data-offset other-pointer-lowtag)
 100        (:translate data-vector-set)
 101        (:arg-types ,type positive-fixnum ,element-type)
 102        (:args (object :scs (descriptor-reg))
 103               (index :scs (any-reg zero immediate))
 104               (value :scs ,scs))
 105        (:results (result :scs ,scs))
 106        (:result-types ,element-type)))))
 107
 108   (def-data-vector-frobs simple-base-string byte-index
 109     character character-reg)
 110   #!+sb-unicode
 111   (def-data-vector-frobs simple-character-string word-index
 112     character character-reg)
 113   (def-data-vector-frobs simple-vector word-index
 114     * descriptor-reg any-reg)
 115
 116   (def-data-vector-frobs simple-array-unsigned-byte-7 byte-index
 117     positive-fixnum unsigned-reg)
 118   (def-data-vector-frobs simple-array-unsigned-byte-8 byte-index
 119     positive-fixnum unsigned-reg)
 120   (def-data-vector-frobs simple-array-unsigned-byte-15 halfword-index
 121     positive-fixnum unsigned-reg)
 122   (def-data-vector-frobs simple-array-unsigned-byte-16 halfword-index
 123     positive-fixnum unsigned-reg)
 124   (def-data-vector-frobs simple-array-unsigned-byte-31 word-index
 125     unsigned-num unsigned-reg)
 126   (def-data-vector-frobs simple-array-unsigned-byte-32 word-index
 127     unsigned-num unsigned-reg)
 128
 129   (def-data-vector-frobs simple-array-unsigned-fixnum word-index
 130     positive-fixnum any-reg)
 131   (def-data-vector-frobs simple-array-fixnum word-index
 132     tagged-num any-reg)
 133   (def-data-vector-frobs simple-array-signed-byte-32 word-index
 134     signed-num signed-reg))
 135
 136 ;;; Integer vectors whose elements are smaller than a byte.  I.e. bit, 2-bit,
 137 ;;; and 4-bit vectors.
 138 (macrolet ((def-small-data-vector-frobs (type bits)
 139   (let* ((elements-per-word (floor n-word-bits bits))
 140          (bit-shift (1- (integer-length elements-per-word))))
 141     `(progn
 142        (define-vop (,(symbolicate "DATA-VECTOR-REF/" type))
 143          (:note "inline array access")
 144          (:translate data-vector-ref)
 145          (:policy :fast-safe)
 146          (:args (object :scs (descriptor-reg))
 147                 (index :scs (unsigned-reg)))
 148          (:arg-types ,type positive-fixnum)
 149          (:results (value :scs (any-reg)))
 150          (:result-types positive-fixnum)
 151          (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp result)
 152          (:generator 20
 153            (inst srl temp index ,bit-shift)
 154            (inst sll temp n-fixnum-tag-bits)
 155            (inst add temp (- (* vector-data-offset n-word-bytes)
 156                              other-pointer-lowtag))
 157            (inst ld result object temp)
 158            (inst and temp index ,(1- elements-per-word))
 159            (inst xor temp ,(1- elements-per-word))
 160            ,@(unless (= bits 1)
 161                `((inst sll temp ,(1- (integer-length bits)))))
 162            (inst srl result temp)
 163            (inst and result ,(1- (ash 1 bits)))
 164            (inst sll value result 2)))
 165        (define-vop (,(symbolicate "DATA-VECTOR-REF-C/" type))
 166          (:translate data-vector-ref)
 167          (:policy :fast-safe)
 168          (:args (object :scs (descriptor-reg)))
 169          (:arg-types ,type (:constant index))
 170          (:info index)
 171          (:results (result :scs (unsigned-reg)))
 172          (:result-types positive-fixnum)
 173          (:temporary (:scs (non-descriptor-reg)) temp)
 174          (:generator 15
 175            (multiple-value-bind (word extra)
 176                (floor index ,elements-per-word)
 177              (setf extra (logxor extra (1- ,elements-per-word)))
 178              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 179                               other-pointer-lowtag)))
 180                (cond ((typep offset '(signed-byte 13))
 181                       (inst ld result object offset))
 182                      (t
 183                       (inst li temp offset)
 184                       (inst ld result object temp))))
 185              (unless (zerop extra)
 186                (inst srl result (* extra ,bits)))
 187              (unless (= extra ,(1- elements-per-word))
 188                (inst and result ,(1- (ash 1 bits)))))))
 189        (define-vop (,(symbolicate "DATA-VECTOR-SET/" type))
 190          (:note "inline array store")
 191          (:translate data-vector-set)
 192          (:policy :fast-safe)
 193          (:args (object :scs (descriptor-reg))
 194                 (index :scs (unsigned-reg) :target shift)
 195                 (value :scs (unsigned-reg zero immediate) :target result))
 196          (:arg-types ,type positive-fixnum positive-fixnum)
 197          (:results (result :scs (unsigned-reg)))
 198          (:result-types positive-fixnum)
 199          (:temporary (:scs (non-descriptor-reg)) temp old offset)
 200          (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) shift)
 201          (:generator 25
 202            (inst srl offset index ,bit-shift)
 203            (inst sll offset n-fixnum-tag-bits)
 204            (inst add offset (- (* vector-data-offset n-word-bytes)
 205                                other-pointer-lowtag))
 206            (inst ld old object offset)
 207            (inst and shift index ,(1- elements-per-word))
 208            (inst xor shift ,(1- elements-per-word))
 209            ,@(unless (= bits 1)
 210                `((inst sll shift ,(1- (integer-length bits)))))
 211            (unless (and (sc-is value immediate)
 212                         (= (tn-value value) ,(1- (ash 1 bits))))
 213              (inst li temp ,(1- (ash 1 bits)))
 214              (inst sll temp shift)
 215              (inst not temp)
 216              (inst and old temp))
 217            (unless (sc-is value zero)
 218              (sc-case value
 219                (immediate
 220                 (inst li temp (logand (tn-value value) ,(1- (ash 1 bits)))))
 221                (unsigned-reg
 222                 (inst and temp value ,(1- (ash 1 bits)))))
 223              (inst sll temp shift)
 224              (inst or old temp))
 225            (inst st old object offset)
 226            (sc-case value
 227              (immediate
 228               (inst li result (tn-value value)))
 229              (t
 230               (move result value)))))
 231        (define-vop (,(symbolicate "DATA-VECTOR-SET-C/" type))
 232          (:translate data-vector-set)
 233          (:policy :fast-safe)
 234          (:args (object :scs (descriptor-reg))
 235                 (value :scs (unsigned-reg zero immediate) :target result))
 236          (:arg-types ,type
 237                      (:constant index)
 238                      positive-fixnum)
 239          (:info index)
 240          (:results (result :scs (unsigned-reg)))
 241          (:result-types positive-fixnum)
 242          (:temporary (:scs (non-descriptor-reg)) offset-reg temp old)
 243          (:generator 20
 244            (multiple-value-bind (word extra) (floor index ,elements-per-word)
 245              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 246                               other-pointer-lowtag)))
 247                (cond ((typep offset '(signed-byte 13))
 248                       (inst ld old object offset))
 249                      (t
 250                       (inst li offset-reg offset)
 251                       (inst ld old object offset-reg)))
 252                (unless (and (sc-is value immediate)
 253                             (= (tn-value value) ,(1- (ash 1 bits))))
 254                  (cond ((zerop extra)
 255                         (inst sll old ,bits)
 256                         (inst srl old ,bits))
 257                        (t
 258                         (inst li temp
 259                               (lognot (ash ,(1- (ash 1 bits))
 260                                            (* (logxor extra
 261                                                       ,(1- elements-per-word))
 262                                               ,bits))))
 263                         (inst and old temp))))
 264                (sc-case value
 265                  (zero)
 266                  (immediate
 267                   (let ((value (ash (logand (tn-value value)
 268                                             ,(1- (ash 1 bits)))
 269                                     (* (logxor extra
 270                                                ,(1- elements-per-word))
 271                                        ,bits))))
 272                     (cond ((typep value '(signed-byte 13))
 273                            (inst or old value))
 274                           (t
 275                            (inst li temp value)
 276                            (inst or old temp)))))
 277                  (unsigned-reg
 278                   (inst sll temp value
 279                         (* (logxor extra ,(1- elements-per-word)) ,bits))
 280                   (inst or old temp)))
 281                (if (typep offset '(signed-byte 13))
 282                    (inst st old object offset)
 283                    (inst st old object offset-reg)))
 284              (sc-case value
 285                (immediate
 286                 (inst li result (tn-value value)))
 287                (t
 288                 (move result value))))))))))
 289
 290   (def-small-data-vector-frobs simple-bit-vector 1)
 291   (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
 292   (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))
 293
 294 ;;; And the float variants.
 295 (define-vop (data-vector-ref/simple-array-single-float)
 296   (:note "inline array access")
 297   (:translate data-vector-ref)
 298   (:policy :fast-safe)
 299   (:args (object :scs (descriptor-reg))
 300          (index :scs (any-reg)))
 301   (:arg-types simple-array-single-float positive-fixnum)
 302   (:results (value :scs (single-reg)))
 303   (:temporary (:scs (non-descriptor-reg)) offset)
 304   (:result-types single-float)
 305   (:generator 5
 306     (inst add offset index (- (* vector-data-offset n-word-bytes)
 307                               other-pointer-lowtag))
 308     (inst ldf value object offset)))
 309
 310
 311 (define-vop (data-vector-set/simple-array-single-float)
 312   (:note "inline array store")
 313   (:translate data-vector-set)
 314   (:policy :fast-safe)
 315   (:args (object :scs (descriptor-reg))
 316          (index :scs (any-reg))
 317          (value :scs (single-reg) :target result))
 318   (:arg-types simple-array-single-float positive-fixnum single-float)
 319   (:results (result :scs (single-reg)))
 320   (:result-types single-float)
 321   (:temporary (:scs (non-descriptor-reg)) offset)
 322   (:generator 5
 323     (inst add offset index
 324           (- (* vector-data-offset n-word-bytes)
 325              other-pointer-lowtag))
 326     (inst stf value object offset)
 327     (unless (location= result value)
 328       (inst fmovs result value))))
 329
 330 (define-vop (data-vector-ref/simple-array-double-float)
 331   (:note "inline array access")
 332   (:translate data-vector-ref)
 333   (:policy :fast-safe)
 334   (:args (object :scs (descriptor-reg))
 335          (index :scs (any-reg)))
 336   (:arg-types simple-array-double-float positive-fixnum)
 337   (:results (value :scs (double-reg)))
 338   (:result-types double-float)
 339   (:temporary (:scs (non-descriptor-reg)) offset)
 340   (:generator 7
 341     (inst sll offset index 1)
 342     (inst add offset (- (* vector-data-offset n-word-bytes)
 343                         other-pointer-lowtag))
 344     (inst lddf value object offset)))
 345
 346 (define-vop (data-vector-set/simple-array-double-float)
 347   (:note "inline array store")
 348   (:translate data-vector-set)
 349   (:policy :fast-safe)
 350   (:args (object :scs (descriptor-reg))
 351          (index :scs (any-reg))
 352          (value :scs (double-reg) :target result))
 353   (:arg-types simple-array-double-float positive-fixnum double-float)
 354   (:results (result :scs (double-reg)))
 355   (:result-types double-float)
 356   (:temporary (:scs (non-descriptor-reg)) offset)
 357   (:generator 20
 358     (inst sll offset index 1)
 359     (inst add offset (- (* vector-data-offset n-word-bytes)
 360                         other-pointer-lowtag))
 361     (inst stdf value object offset)
 362     (unless (location= result value)
 363       (move-double-reg result value))))
 364
 365 #!+long-float
 366 (define-vop (data-vector-ref/simple-array-long-float)
 367   (:note "inline array access")
 368   (:translate data-vector-ref)
 369   (:policy :fast-safe)
 370   (:args (object :scs (descriptor-reg))
 371          (index :scs (any-reg)))
 372   (:arg-types simple-array-long-float positive-fixnum)
 373   (:results (value :scs (long-reg)))
 374   (:result-types long-float)
 375   (:temporary (:scs (non-descriptor-reg)) offset)
 376   (:generator 7
 377     (inst sll offset index 2)
 378     (inst add offset (- (* vector-data-offset n-word-bytes)
 379                         other-pointer-lowtag))
 380     (load-long-reg value object offset nil)))
 381
 382 #!+long-float
 383 (define-vop (data-vector-set/simple-array-long-float)
 384   (:note "inline array store")
 385   (:translate data-vector-set)
 386   (:policy :fast-safe)
 387   (:args (object :scs (descriptor-reg))
 388          (index :scs (any-reg))
 389          (value :scs (long-reg) :target result))
 390   (:arg-types simple-array-long-float positive-fixnum long-float)
 391   (:results (result :scs (long-reg)))
 392   (:result-types long-float)
 393   (:temporary (:scs (non-descriptor-reg)) offset)
 394   (:generator 20
 395     (inst sll offset index 2)
 396     (inst add offset (- (* vector-data-offset n-word-bytes)
 397                         other-pointer-lowtag))
 398     (store-long-reg value object offset nil)
 399     (unless (location= result value)
 400       (move-long-reg result value))))
 401
 402 \f
 403 ;;;; Misc. Array VOPs.
 404
 405
 406 #+nil
 407 (define-vop (vector-word-length)
 408   (:args (vec :scs (descriptor-reg)))
 409   (:results (res :scs (any-reg descriptor-reg)))
 410   (:generator 6
 411     (loadw res vec clc::g-vector-header-words)
 412     (inst niuo res res clc::g-vector-words-mask-16)))
 413
 414 (define-vop (get-vector-subtype get-header-data))
 415 (define-vop (set-vector-subtype set-header-data))
 416
 417 \f
 418 ;;; XXX FIXME: Don't we have these above, in DEF-DATA-VECTOR-FROBS?
 419 (define-vop (data-vector-ref/simple-array-signed-byte-8 signed-byte-index-ref)
 420   (:note "inline array access")
 421   (:variant vector-data-offset other-pointer-lowtag)
 422   (:translate data-vector-ref)
 423   (:arg-types simple-array-signed-byte-8 positive-fixnum)
 424   (:results (value :scs (signed-reg)))
 425   (:result-types tagged-num))
 426
 427 (define-vop (data-vector-set/simple-array-signed-byte-8 byte-index-set)
 428   (:note "inline array store")
 429   (:variant vector-data-offset other-pointer-lowtag)
 430   (:translate data-vector-set)
 431   (:arg-types simple-array-signed-byte-8 positive-fixnum tagged-num)
 432   (:args (object :scs (descriptor-reg))
 433          (index :scs (any-reg zero immediate))
 434          (value :scs (signed-reg)))
 435   (:results (result :scs (signed-reg)))
 436   (:result-types tagged-num))
 437
 438
 439 (define-vop (data-vector-ref/simple-array-signed-byte-16
 440              signed-halfword-index-ref)
 441   (:note "inline array access")
 442   (:variant vector-data-offset other-pointer-lowtag)
 443   (:translate data-vector-ref)
 444   (:arg-types simple-array-signed-byte-16 positive-fixnum)
 445   (:results (value :scs (signed-reg)))
 446   (:result-types tagged-num))
 447
 448 (define-vop (data-vector-set/simple-array-signed-byte-16 halfword-index-set)
 449   (:note "inline array store")
 450   (:variant vector-data-offset other-pointer-lowtag)
 451   (:translate data-vector-set)
 452   (:arg-types simple-array-signed-byte-16 positive-fixnum tagged-num)
 453   (:args (object :scs (descriptor-reg))
 454          (index :scs (any-reg zero immediate))
 455          (value :scs (signed-reg)))
 456   (:results (result :scs (signed-reg)))
 457   (:result-types tagged-num))
 458
 459 \f
 460 ;;; Complex float arrays.
 461
 462 (define-vop (data-vector-ref/simple-array-complex-single-float)
 463   (:note "inline array access")
 464   (:translate data-vector-ref)
 465   (:policy :fast-safe)
 466   (:args (object :scs (descriptor-reg) :to :result)
 467          (index :scs (any-reg)))
 468   (:arg-types simple-array-complex-single-float positive-fixnum)
 469   (:results (value :scs (complex-single-reg)))
 470   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 471   (:result-types complex-single-float)
 472   (:generator 5
 473     (let ((real-tn (complex-single-reg-real-tn value)))
 474       (inst sll offset index 1)
 475       (inst add offset (- (* vector-data-offset n-word-bytes)
 476                           other-pointer-lowtag))
 477       (inst ldf real-tn object offset))
 478     (let ((imag-tn (complex-single-reg-imag-tn value)))
 479       (inst add offset n-word-bytes)
 480       (inst ldf imag-tn object offset))))
 481
 482 (define-vop (data-vector-set/simple-array-complex-single-float)
 483   (:note "inline array store")
 484   (:translate data-vector-set)
 485   (:policy :fast-safe)
 486   (:args (object :scs (descriptor-reg) :to :result)
 487          (index :scs (any-reg))
 488          (value :scs (complex-single-reg) :target result))
 489   (:arg-types simple-array-complex-single-float positive-fixnum
 490               complex-single-float)
 491   (:results (result :scs (complex-single-reg)))
 492   (:result-types complex-single-float)
 493   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 494   (:generator 5
 495     (let ((value-real (complex-single-reg-real-tn value))
 496           (result-real (complex-single-reg-real-tn result)))
 497       (inst sll offset index 1)
 498       (inst add offset (- (* vector-data-offset n-word-bytes)
 499                           other-pointer-lowtag))
 500       (inst stf value-real object offset)
 501       (unless (location= result-real value-real)
 502         (inst fmovs result-real value-real)))
 503     (let ((value-imag (complex-single-reg-imag-tn value))
 504           (result-imag (complex-single-reg-imag-tn result)))
 505       (inst add offset n-word-bytes)
 506       (inst stf value-imag object offset)
 507       (unless (location= result-imag value-imag)
 508         (inst fmovs result-imag value-imag)))))
 509
 510 (define-vop (data-vector-ref/simple-array-complex-double-float)
 511   (:note "inline array access")
 512   (:translate data-vector-ref)
 513   (:policy :fast-safe)
 514   (:args (object :scs (descriptor-reg) :to :result)
 515          (index :scs (any-reg)))
 516   (:arg-types simple-array-complex-double-float positive-fixnum)
 517   (:results (value :scs (complex-double-reg)))
 518   (:result-types complex-double-float)
 519   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 520   (:generator 7
 521     (let ((real-tn (complex-double-reg-real-tn value)))
 522       (inst sll offset index 2)
 523       (inst add offset (- (* vector-data-offset n-word-bytes)
 524                           other-pointer-lowtag))
 525       (inst lddf real-tn object offset))
 526     (let ((imag-tn (complex-double-reg-imag-tn value)))
 527       (inst add offset (* 2 n-word-bytes))
 528       (inst lddf imag-tn object offset))))
 529
 530 (define-vop (data-vector-set/simple-array-complex-double-float)
 531   (:note "inline array store")
 532   (:translate data-vector-set)
 533   (:policy :fast-safe)
 534   (:args (object :scs (descriptor-reg) :to :result)
 535          (index :scs (any-reg))
 536          (value :scs (complex-double-reg) :target result))
 537   (:arg-types simple-array-complex-double-float positive-fixnum
 538               complex-double-float)
 539   (:results (result :scs (complex-double-reg)))
 540   (:result-types complex-double-float)
 541   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 542   (:generator 20
 543     (let ((value-real (complex-double-reg-real-tn value))
 544           (result-real (complex-double-reg-real-tn result)))
 545       (inst sll offset index 2)
 546       (inst add offset (- (* vector-data-offset n-word-bytes)
 547                           other-pointer-lowtag))
 548       (inst stdf value-real object offset)
 549       (unless (location= result-real value-real)
 550         (move-double-reg result-real value-real)))
 551     (let ((value-imag (complex-double-reg-imag-tn value))
 552           (result-imag (complex-double-reg-imag-tn result)))
 553       (inst add offset (* 2 n-word-bytes))
 554       (inst stdf value-imag object offset)
 555       (unless (location= result-imag value-imag)
 556         (move-double-reg result-imag value-imag)))))
 557
 558 #!+long-float
 559 (define-vop (data-vector-ref/simple-array-complex-long-float)
 560   (:note "inline array access")
 561   (:translate data-vector-ref)
 562   (:policy :fast-safe)
 563   (:args (object :scs (descriptor-reg) :to :result)
 564          (index :scs (any-reg)))
 565   (:arg-types simple-array-complex-long-float positive-fixnum)
 566   (:results (value :scs (complex-long-reg)))
 567   (:result-types complex-long-float)
 568   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 569   (:generator 7
 570     (let ((real-tn (complex-long-reg-real-tn value)))
 571       (inst sll offset index 3)
 572       (inst add offset (- (* vector-data-offset n-word-bytes)
 573                           other-pointer-lowtag))
 574       (load-long-reg real-tn object offset nil))
 575     (let ((imag-tn (complex-long-reg-imag-tn value)))
 576       (inst add offset (* 4 n-word-bytes))
 577       (load-long-reg imag-tn object offset nil))))
 578
 579 #!+long-float
 580 (define-vop (data-vector-set/simple-array-complex-long-float)
 581   (:note "inline array store")
 582   (:translate data-vector-set)
 583   (:policy :fast-safe)
 584   (:args (object :scs (descriptor-reg) :to :result)
 585          (index :scs (any-reg))
 586          (value :scs (complex-long-reg) :target result))
 587   (:arg-types simple-array-complex-long-float positive-fixnum
 588               complex-long-float)
 589   (:results (result :scs (complex-long-reg)))
 590   (:result-types complex-long-float)
 591   (:temporary (:scs (non-descriptor-reg) :from (:argument 1)) offset)
 592   (:generator 20
 593     (let ((value-real (complex-long-reg-real-tn value))
 594           (result-real (complex-long-reg-real-tn result)))
 595       (inst sll offset index 3)
 596       (inst add offset (- (* vector-data-offset n-word-bytes)
 597                           other-pointer-lowtag))
 598       (store-long-reg value-real object offset nil)
 599       (unless (location= result-real value-real)
 600         (move-long-reg result-real value-real)))
 601     (let ((value-imag (complex-long-reg-imag-tn value))
 602           (result-imag (complex-long-reg-imag-tn result)))
 603       (inst add offset (* 4 n-word-bytes))
 604       (store-long-reg value-imag object offset nil)
 605       (unless (location= result-imag value-imag)
 606         (move-long-reg result-imag value-imag)))))
 607
 608 \f
 609 ;;; These vops are useful for accessing the bits of a vector irrespective of
 610 ;;; what type of vector it is.
 611 (define-vop (vector-raw-bits word-index-ref)
 612   (:note "vector-raw-bits VOP")
 613   (:translate %vector-raw-bits)
 614   (:results (value :scs (unsigned-reg)))
 615   (:result-types unsigned-num)
 616   (:variant vector-data-offset other-pointer-lowtag))
 617
 618 (define-vop (set-vector-raw-bits word-index-set)
 619   (:note "setf vector-raw-bits VOP")
 620   (:translate %set-vector-raw-bits)
 621   (:args (object :scs (descriptor-reg))
 622          (index :scs (any-reg zero immediate))
 623          (value :scs (unsigned-reg)))
 624   (:arg-types * tagged-num unsigned-num)
 625   (:results (result :scs (unsigned-reg)))
 626   (:result-types unsigned-num)
 627   (:variant vector-data-offset other-pointer-lowtag))