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