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