array.lisp

开源跨平台Lisp编译器

           ;; this UNLESS in the bit-vector case.  --njf, 2006-07-14
           ,@(unless (= elements-per-word n-word-bits)
               `((inst and ecx ,(1- elements-per-word))
                 (inst shl ecx ,(1- (integer-length bits)))))
           (inst ror old :cl)
           (unless (and (sc-is value immediate)
                        (= (tn-value value) ,(1- (ash 1 bits))))
             (inst and old ,(lognot (1- (ash 1 bits)))))
           (sc-case value
             (immediate
              (unless (zerop (tn-value value))
                (inst or old (logand (tn-value value) ,(1- (ash 1 bits))))))
             (unsigned-reg
              (inst or old value)))
           (inst rol old :cl)
           (inst mov (make-ea-for-vector-data object :index word-index)
                 old)
           (sc-case value
             (immediate
              (inst mov result (tn-value value)))
             (unsigned-reg
              (move result value)))))
       (define-vop (,(symbolicate 'data-vector-set-c-with-offset/ type))
         (:translate data-vector-set-with-offset)
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg))
                (value :scs (unsigned-reg immediate) :target result))
         (:arg-types ,type (:constant index) (:constant (integer 0 0))
                     positive-fixnum)
         (:info index offset)
         (:results (result :scs (unsigned-reg)))
         (:result-types positive-fixnum)
         (:temporary (:sc unsigned-reg :to (:result 0)) old)
         (:generator 20
           (aver (zerop offset))
           (multiple-value-bind (word extra) (floor index ,elements-per-word)
             (loadw old object (+ word vector-data-offset) other-pointer-lowtag)
             (sc-case value
               (immediate
                (let* ((value (tn-value value))
                       (mask ,(1- (ash 1 bits)))
                       (shift (* extra ,bits)))
                  (unless (= value mask)
                    (inst and old (ldb (byte n-word-bits 0)
                                       (lognot (ash mask shift)))))
                  (unless (zerop value)
                    (inst or old (ash value shift)))))
               (unsigned-reg
                (let ((shift (* extra ,bits)))
                  (unless (zerop shift)
                    (inst ror old shift))
                  (inst and old (lognot ,(1- (ash 1 bits))))
                  (inst or old value)
                  (unless (zerop shift)
                    (inst rol old shift)))))
             (storew old object (+ word vector-data-offset) other-pointer-lowtag)
             (sc-case value
               (immediate
                (inst mov result (tn-value value)))
               (unsigned-reg
                (move result value))))))))))
  (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.

(defun make-ea-for-float-ref (object index offset element-size
                              &key (scale 1) (complex-offset 0))
  (sc-case index
    (immediate
     (make-ea :dword :base object
              :disp (- (+ (* vector-data-offset n-word-bytes)
                          (* element-size (+ offset (tn-value index)))
                          complex-offset)
                       other-pointer-lowtag)))
    (t
     (make-ea :dword :base object :index index :scale scale
              :disp (- (+ (* vector-data-offset n-word-bytes)
                          (* element-size offset)
                          complex-offset)
                       other-pointer-lowtag)))))

(define-vop (data-vector-ref-with-offset/simple-array-single-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-single-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                4 vector-data-offset)))
  (:results (value :scs (single-reg)))
  (:result-types single-float)
  (:generator 5
   (with-empty-tn@fp-top(value)
     (inst fld (make-ea-for-float-ref object index offset 4)))))

(define-vop (data-vector-set-with-offset/simple-array-single-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 (single-reg) :target result))
  (:info offset)
  (:arg-types simple-array-single-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                4 vector-data-offset))
              single-float)
  (:results (result :scs (single-reg)))
  (:result-types single-float)
  (:generator 5
    (cond ((zerop (tn-offset value))
           ;; Value is in ST0.
           (inst fst (make-ea-for-float-ref object index offset 4))
           (unless (zerop (tn-offset result))
             ;; Value is in ST0 but not result.
             (inst fst result)))
          (t
           ;; Value is not in ST0.
           (inst fxch value)
           (inst fst (make-ea-for-float-ref object index offset 4))
           (cond ((zerop (tn-offset result))
                  ;; The result is in ST0.
                  (inst fst value))
                 (t
                  ;; Neither value or result are in ST0
                  (unless (location= value result)
                    (inst fst result))
                  (inst fxch value)))))))

(define-vop (data-vector-ref-with-offset/simple-array-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-double-float
              positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                8 vector-data-offset)))
  (:results (value :scs (double-reg)))
  (:result-types double-float)
  (:generator 7
   (with-empty-tn@fp-top(value)
     (inst fldd (make-ea-for-float-ref object index offset 8 :scale 2)))))

(define-vop (data-vector-set-with-offset/simple-array-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 (double-reg) :target result))
  (:info offset)
  (:arg-types simple-array-double-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                8 vector-data-offset))
              double-float)
  (:results (result :scs (double-reg)))
  (:result-types double-float)
  (:generator 20
    (cond ((zerop (tn-offset value))
           ;; Value is in ST0.
           (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
           (unless (zerop (tn-offset result))
                   ;; Value is in ST0 but not result.
                   (inst fstd result)))
          (t
           ;; Value is not in ST0.
           (inst fxch value)
           (inst fstd (make-ea-for-float-ref object index offset 8 :scale 2))
           (cond ((zerop (tn-offset result))
                  ;; The result is in ST0.
                  (inst fstd value))
                 (t
                  ;; Neither value or result are in ST0
                  (unless (location= value result)
                          (inst fstd result))
                  (inst fxch value)))))))

;;; complex float variants

(define-vop (data-vector-ref-with-offset/simple-array-complex-single-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-single-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                8 vector-data-offset)))
  (:results (value :scs (complex-single-reg)))
  (:result-types complex-single-float)
  (:generator 5
    (let ((real-tn (complex-single-reg-real-tn value)))
      (with-empty-tn@fp-top (real-tn)
        (inst fld (make-ea-for-float-ref object index offset 8 :scale 2))))
    (let ((imag-tn (complex-single-reg-imag-tn value)))
      (with-empty-tn@fp-top (imag-tn)
        ;; FIXME
        (inst fld (make-ea-for-float-ref object index offset 8
                                         :scale 2 :complex-offset 4))))))

(define-vop (data-vector-set-with-offset/simple-array-complex-single-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-single-reg) :target result))
  (:info offset)
  (:arg-types simple-array-complex-single-float positive-fixnum
              (:constant (constant-displacement other-pointer-lowtag
                                                8 vector-data-offset))
              complex-single-float)
  (:results (result :scs (complex-single-reg)))
  (:result-types complex-single-float)
  (:generator 5
    (let ((value-real (complex-single-reg-real-tn value))
          (result-real (complex-single-reg-real-tn result)))
      (cond ((zerop (tn-offset value-real))
             ;; Value is in ST0.
             (inst fst (make-ea-for-float-ref object index offset 8 :scale 2))
             (unless (zerop (tn-offset result-real))
               ;; Value is in ST0 but not result.
               (inst fst result-real)))
            (t
             ;; Value is not in ST0.