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