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