array.lisp

开源跨平台Lisp编译器

                                                                ,(1- (ash 1
                                                                          bits)))
                                                              (* extra
                                                                 ,bits))))
                                              (cond ((< value #x100)
                                                     (inst bis old value old))
                                                    (t
                                                     (inst li value temp)
                                                     (inst bis old temp old)))))
                                           (unsigned-reg
                                            (inst sll value (* extra ,bits)
                                                  temp)
                                            (inst bis old temp old)))
                                  (inst stl old
                                        (- (* (+ word vector-data-offset)
                                              n-word-bytes)
                                           other-pointer-lowtag)
                                        object)
                                  (sc-case value
                                           (immediate
                                            (inst li (tn-value value) result))
                                           (zero
                                            (move zero-tn result))
                                           (unsigned-reg
                                            (move value result))))))))))
  (def-full-data-vector-frobs simple-vector *
    descriptor-reg any-reg null zero)

  (def-partial-data-vector-frobs simple-base-string character :byte nil
    character-reg)
  #!+sb-unicode ; FIXME: what about when a word is 64 bits?
  (def-full-data-vector-frobs simple-character-string character character-reg)

  (def-partial-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
    :byte nil unsigned-reg signed-reg)
  (def-partial-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
    :byte nil unsigned-reg signed-reg)

  (def-partial-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
    :short nil unsigned-reg signed-reg)
  (def-partial-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
    :short nil unsigned-reg signed-reg)

  (def-full-data-vector-frobs simple-array-unsigned-byte-31 unsigned-num
    unsigned-reg)
  (def-full-data-vector-frobs simple-array-unsigned-byte-32 unsigned-num
    unsigned-reg)

  (def-partial-data-vector-frobs simple-array-signed-byte-8 tagged-num
    :byte t signed-reg)

  (def-partial-data-vector-frobs simple-array-signed-byte-16 tagged-num
    :short t signed-reg)

  (def-full-data-vector-frobs simple-array-unsigned-byte-29 positive-fixnum any-reg)
  (def-full-data-vector-frobs simple-array-signed-byte-30 tagged-num any-reg)

  (def-full-data-vector-frobs simple-array-signed-byte-32 signed-num
    signed-reg)

  ;; Integer vectors whos elements are smaller than a byte. I.e. bit,
  ;; 2-bit, and 4-bit vectors.
  (def-small-data-vector-frobs simple-bit-vector 1)
  (def-small-data-vector-frobs simple-array-unsigned-byte-2 2)
  (def-small-data-vector-frobs simple-array-unsigned-byte-4 4))

;;; and the float variants..

(define-vop (data-vector-ref/simple-array-single-float)
  (:note "inline array access")
  (:translate data-vector-ref)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types simple-array-single-float positive-fixnum)
  (:results (value :scs (single-reg)))
  (:result-types single-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 20
    (inst addq object index lip)
    (inst lds value
          (- (* vector-data-offset n-word-bytes)
             other-pointer-lowtag)
           lip)))

(define-vop (data-vector-set/simple-array-single-float)
  (:note "inline array store")
  (:translate data-vector-set)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (single-reg) :target result))
  (:arg-types simple-array-single-float positive-fixnum single-float)
  (:results (result :scs (single-reg)))
  (:result-types single-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 20
    (inst addq object index lip)
    (inst sts value
          (- (* vector-data-offset n-word-bytes)
             other-pointer-lowtag)
          lip)
    (unless (location= result value)
      (inst fmove value result))))

(define-vop (data-vector-ref/simple-array-double-float)
  (:note "inline array access")
  (:translate data-vector-ref)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types simple-array-double-float positive-fixnum)
  (:results (value :scs (double-reg)))
  (:result-types double-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 20
    (inst addq object index lip)
    (inst addq lip index lip)
    (inst ldt value
          (- (* vector-data-offset n-word-bytes)
             other-pointer-lowtag)
          lip)))

(define-vop (data-vector-set/simple-array-double-float)
  (:note "inline array store")
  (:translate data-vector-set)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (double-reg) :target result))
  (:arg-types simple-array-double-float positive-fixnum double-float)
  (:results (result :scs (double-reg)))
  (:result-types double-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 20
    (inst addq object index lip)
    (inst addq lip index lip)
    (inst stt value
          (- (* vector-data-offset n-word-bytes)
             other-pointer-lowtag) lip)
    (unless (location= result value)
      (inst fmove value result))))

;;; complex float arrays

(define-vop (data-vector-ref/simple-array-complex-single-float)
  (:note "inline array access")
  (:translate data-vector-ref)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types simple-array-complex-single-float positive-fixnum)
  (:results (value :scs (complex-single-reg)))
  (:temporary (:scs (interior-reg)) lip)
  (:result-types complex-single-float)
  (:generator 5
    (let ((real-tn (complex-single-reg-real-tn value)))
      (inst addq object index lip)
      (inst addq lip index lip)
      (inst lds real-tn
            (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
            lip))
    (let ((imag-tn (complex-single-reg-imag-tn value)))
      (inst lds imag-tn
            (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
            lip))))

(define-vop (data-vector-set/simple-array-complex-single-float)
  (:note "inline array store")
  (:translate data-vector-set)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (complex-single-reg) :target result))
  (:arg-types simple-array-complex-single-float positive-fixnum
              complex-single-float)
  (:results (result :scs (complex-single-reg)))
  (:result-types complex-single-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 5
    (let ((value-real (complex-single-reg-real-tn value))
          (result-real (complex-single-reg-real-tn result)))
      (inst addq object index lip)
      (inst addq lip index lip)
      (inst sts value-real
            (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
            lip)
      (unless (location= result-real value-real)
        (inst fmove value-real result-real)))
    (let ((value-imag (complex-single-reg-imag-tn value))
          (result-imag (complex-single-reg-imag-tn result)))
      (inst sts value-imag
            (- (* (1+ vector-data-offset) n-word-bytes) other-pointer-lowtag)
            lip)
      (unless (location= result-imag value-imag)
        (inst fmove value-imag result-imag)))))

(define-vop (data-vector-ref/simple-array-complex-double-float)
  (:note "inline array access")
  (:translate data-vector-ref)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types simple-array-complex-double-float positive-fixnum)
  (:results (value :scs (complex-double-reg)))
  (:result-types complex-double-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 7
    (let ((real-tn (complex-double-reg-real-tn value)))
      (inst addq object index lip)
      (inst addq lip index lip)
      (inst addq lip index lip)
      (inst addq lip index lip)
      (inst ldt real-tn
            (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
            lip))
    (let ((imag-tn (complex-double-reg-imag-tn value)))
      (inst ldt imag-tn
            (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
            lip))))

(define-vop (data-vector-set/simple-array-complex-double-float)
  (:note "inline array store")
  (:translate data-vector-set)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (complex-double-reg) :target result))
  (:arg-types simple-array-complex-double-float positive-fixnum
              complex-double-float)
  (:results (result :scs (complex-double-reg)))
  (:result-types complex-double-float)
  (:temporary (:scs (interior-reg)) lip)
  (:generator 20
    (let ((value-real (complex-double-reg-real-tn value))
          (result-real (complex-double-reg-real-tn result)))
      (inst addq object index lip)
      (inst addq lip index lip)
      (inst addq lip index lip)
      (inst addq lip index lip)
      (inst stt value-real
            (- (* vector-data-offset n-word-bytes) other-pointer-lowtag)
            lip)
      (unless (location= result-real value-real)
        (inst fmove value-real result-real)))
    (let ((value-imag (complex-double-reg-imag-tn value))
          (result-imag (complex-double-reg-imag-tn result)))
      (inst stt value-imag
            (- (* (+ vector-data-offset 2) n-word-bytes) other-pointer-lowtag)
            lip)
      (unless (location= result-imag value-imag)
        (inst fmove value-imag result-imag)))))


;;; These vops are useful for accessing the bits of a vector irrespective of
;;; what type of vector it is.
;;;
(define-full-reffer raw-bits * 0 other-pointer-lowtag (unsigned-reg) unsigned-num
  %raw-bits)
(define-full-setter set-raw-bits * 0 other-pointer-lowtag (unsigned-reg)
  unsigned-num %set-raw-bits)
(define-full-reffer vector-raw-bits * vector-data-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num %vector-raw-bits)
(define-full-setter set-vector-raw-bits * vector-data-offset other-pointer-lowtag
  (unsigned-reg) unsigned-num %set-vector-raw-bits)


;;;; misc. array VOPs

(define-vop (get-vector-subtype get-header-data))
(define-vop (set-vector-subtype set-header-data))