array.lisp

开源跨平台Lisp编译器

             (inst fxch value-real)
             (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
             (cond ((zerop (tn-offset result-real))
                    ;; The result is in ST0.
                    (inst fst value-real))
                   (t
                    ;; Neither value or result are in ST0
                    (unless (location= value-real result-real)
                      (inst fst result-real))
                    (inst fxch value-real))))))
    (let ((value-imag (complex-single-reg-imag-tn value))
          (result-imag (complex-single-reg-imag-tn result)))
      (inst fxch value-imag)
      (inst fst (make-ea-for-float-ref object index offset 8
                                       :scale 2 :complex-offset 4))
      (unless (location= value-imag result-imag)
        (inst fst result-imag))
      (inst fxch value-imag))))

(define-vop (data-vector-ref-with-offset/simple-array-complex-double-float)
  (:note "inline array access")
  (:translate data-vector-ref-with-offset)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg immediate)))
  (:info offset)
  (:arg-types simple-array-complex-double-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                16 vector-data-offset)))
  (:results (value :scs (complex-double-reg)))
  (:result-types complex-double-float)
  (:generator 7
    (let ((real-tn (complex-double-reg-real-tn value)))
      (with-empty-tn@fp-top (real-tn)
        (inst fldd (make-ea-for-float-ref object index offset 16 :scale 4)))
    (let ((imag-tn (complex-double-reg-imag-tn value)))
      (with-empty-tn@fp-top (imag-tn)
        (inst fldd (make-ea-for-float-ref object index offset 16
                                          :scale 4 :complex-offset 8)))))))

(define-vop (data-vector-set-with-offset/simple-array-complex-double-float)
  (:note "inline array store")
  (:translate data-vector-set-with-offset)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg immediate))
         (value :scs (complex-double-reg) :target result))
  (:info offset)
  (:arg-types simple-array-complex-double-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                16 vector-data-offset))
              complex-double-float)
  (:results (result :scs (complex-double-reg)))
  (:result-types complex-double-float)
  (:generator 20
    (let ((value-real (complex-double-reg-real-tn value))
          (result-real (complex-double-reg-real-tn result)))
      (cond ((zerop (tn-offset value-real))
             ;; Value is in ST0.
             (inst fstd (make-ea-for-float-ref object index offset 16
                                               :scale 4))
             (unless (zerop (tn-offset result-real))
               ;; Value is in ST0 but not result.
               (inst fstd result-real)))
            (t
             ;; Value is not in ST0.
             (inst fxch value-real)
             (inst fstd (make-ea-for-float-ref object index offset 16
                                               :scale 4))
             (cond ((zerop (tn-offset result-real))
                    ;; The result is in ST0.
                    (inst fstd value-real))
                   (t
                    ;; Neither value or result are in ST0
                    (unless (location= value-real result-real)
                      (inst fstd result-real))
                    (inst fxch value-real))))))
    (let ((value-imag (complex-double-reg-imag-tn value))
          (result-imag (complex-double-reg-imag-tn result)))
      (inst fxch value-imag)
      (inst fstd (make-ea-for-float-ref object index offset 16
                                        :scale 4 :complex-offset 8))
      (unless (location= value-imag result-imag)
        (inst fstd result-imag))
      (inst fxch value-imag))))


;;; {un,}signed-byte-8, simple-base-string

(macrolet ((define-data-vector-frobs (ptype element-type ref-inst
                                            8-bit-tns-p &rest scs)
  `(progn
    (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
      (:translate data-vector-ref-with-offset)
      (:policy :fast-safe)
      (:args (object :scs (descriptor-reg))
             (index :scs (unsigned-reg immediate)))
      (:info offset)
      (:arg-types ,ptype positive-fixnum
                  (:constant (constant-displacement other-pointer-lowtag
                                                    1 vector-data-offset)))
      (:results (value :scs ,scs))
      (:result-types ,element-type)
      (:generator 5
        (sc-case index
          (immediate
           (inst ,ref-inst value (make-ea-for-vector-data
                                  object :size :byte
                                  :offset (+ (tn-value index) offset))))
          (t
           (inst ,ref-inst value
                 (make-ea-for-vector-data object :size :byte
                                          :index index :offset offset))))))
    (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
      (:translate data-vector-set-with-offset)
      (:policy :fast-safe)
      (:args (object :scs (descriptor-reg) :to (:eval 0))
             (index :scs (unsigned-reg immediate) :to (:eval 0))
             (value :scs ,scs ,@(unless 8-bit-tns-p
                                  '(:target eax))))
      (:info offset)
      (:arg-types ,ptype positive-fixnum
                  (:constant (constant-displacement other-pointer-lowtag
                                                    1 vector-data-offset))
                  ,element-type)
      ,@(unless 8-bit-tns-p
         '((:temporary (:sc unsigned-reg :offset eax-offset :target result
                        :from (:argument 2) :to (:result 0))
            eax)))
      (:results (result :scs ,scs))
      (:result-types ,element-type)
      (:generator 5
        ,@(unless 8-bit-tns-p
           '((move eax value)))
        (sc-case index
          (immediate
           (inst mov (make-ea-for-vector-data
                      object :size :byte :offset (+ (tn-value index) offset))
                 ,(if 8-bit-tns-p
                      'value
                      'al-tn)))
          (t
           (inst mov (make-ea-for-vector-data object :size :byte
                                              :index index :offset offset)
                 ,(if 8-bit-tns-p
                      'value
                      'al-tn))))
        (move result ,(if 8-bit-tns-p
                          'value
                          'eax)))))))
  (define-data-vector-frobs simple-array-unsigned-byte-7 positive-fixnum
    movzx nil unsigned-reg signed-reg)
  (define-data-vector-frobs simple-array-unsigned-byte-8 positive-fixnum
    movzx nil unsigned-reg signed-reg)
  (define-data-vector-frobs simple-array-signed-byte-8 tagged-num
    movsx nil signed-reg)
  (define-data-vector-frobs simple-base-string character
                            #!+sb-unicode movzx #!-sb-unicode mov
                            #!+sb-unicode nil #!-sb-unicode t character-reg))

;;; {un,}signed-byte-16
(macrolet ((define-data-vector-frobs (ptype element-type ref-inst &rest scs)
    `(progn
      (define-vop (,(symbolicate "DATA-VECTOR-REF-WITH-OFFSET/" ptype))
        (:translate data-vector-ref-with-offset)
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg))
               (index :scs (unsigned-reg immediate)))
        (:info offset)
        (:arg-types ,ptype positive-fixnum
                    (:constant (constant-displacement other-pointer-lowtag
                                                      2 vector-data-offset)))
        (:results (value :scs ,scs))
        (:result-types ,element-type)
        (:generator 5
          (sc-case index
            (immediate
             (inst ,ref-inst value
                   (make-ea-for-vector-data object :size :word
                                            :offset (+ (tn-value index) offset))))
            (t
             (inst ,ref-inst value
                   (make-ea-for-vector-data object :size :word
                                            :index index :offset offset))))))
      (define-vop (,(symbolicate "DATA-VECTOR-SET-WITH-OFFSET/" ptype))
        (:translate data-vector-set-with-offset)
        (:policy :fast-safe)
        (:args (object :scs (descriptor-reg) :to (:eval 0))
               (index :scs (unsigned-reg immediate) :to (:eval 0))
               (value :scs ,scs :target eax))
        (:info offset)
        (:arg-types ,ptype positive-fixnum
                    (:constant (constant-displacement other-pointer-lowtag
                                                      2 vector-data-offset))
                    ,element-type)
        (:temporary (:sc unsigned-reg :offset eax-offset :target result
                         :from (:argument 2) :to (:result 0))
                    eax)
        (:results (result :scs ,scs))
        (:result-types ,element-type)
        (:generator 5
          (move eax value)
          (sc-case index
            (immediate
             (inst mov (make-ea-for-vector-data
                        object :size :word :offset (+ (tn-value index) offset))
                   ax-tn))
            (t
             (inst mov (make-ea-for-vector-data object :size :word
                                                :index index :offset offset)
                   ax-tn)))
          (move result eax))))))
  (define-data-vector-frobs simple-array-unsigned-byte-15 positive-fixnum
    movzx unsigned-reg signed-reg)
  (define-data-vector-frobs simple-array-unsigned-byte-16 positive-fixnum
    movzx unsigned-reg signed-reg)
  (define-data-vector-frobs simple-array-signed-byte-16 tagged-num
    movsx signed-reg))

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


;;;; miscellaneous array VOPs

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