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 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 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 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) (floor index ,elements-per-word)
 193              (setf extra (logxor extra (1- ,elements-per-word)))
 194              (let ((offset (- (* (+ word vector-data-offset) n-word-bytes)
 195                               other-pointer-lowtag)))
 196                (cond ((typep offset '(signed-byte 13))
 197                       (inst ld result object offset))
 198                      (t
 199                       (inst li temp offset)
 200                       (inst ld result object temp))))
 201              (unless (zerop extra)
 202                (inst srl result
 203                      (logxor (* extra ,bits) ,(1- elements-per-word))))
 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 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))