cell.lisp

开源跨平台Lisp编译器

                    (let ((*package* (find-package :kernel)))
             (symbolicate "MUTATOR-" slot))))
               (multiple-value-bind
                   (lisp-type ref-vop set-vop)
                   (ecase type
                     (:des
                      (values t
                              'mutator-descriptor-ref
                              'mutator-descriptor-set))
                     (:ub32
                      (values '(unsigned-byte 32)
                              'mutator-ub32-ref
                              'mutator-ub32-set))
                     (:sap
                      (values 'system-area-pointer
                              'mutator-sap-ref
                              'mutator-sap-set)))
                 `(progn
                    (export ',fn :kernel)
                    (defknown ,fn () ,lisp-type (flushable))
                    (define-vop (,ref ,ref-vop)
                      (:translate ,fn)
                      (:variant ,offset))
                    ,@(when writable
                        `((defknown ((setf ,fn)) (,lisp-type) ,lisp-type
                            (unsafe))
                          (define-vop (,set ,set-vop)
                            (:translate (setf ,fn))
                            (:variant ,offset)))))))))
  (define-mutator-accessors thread :des t)
  (define-mutator-accessors suspends-disabled-count :ub32 t)
  (define-mutator-accessors suspend-pending :ub32 t)
  (define-mutator-accessors control-stack-base :sap nil)
  (define-mutator-accessors control-stack-end :sap nil)
  (define-mutator-accessors current-unwind-protect :sap nil)
  (define-mutator-accessors current-catch-block :sap nil)
  (define-mutator-accessors binding-stack-base :sap nil)
  (define-mutator-accessors binding-stack-end :sap nil)
  (define-mutator-accessors number-stack-base :sap nil)
  (define-mutator-accessors number-stack-end :sap nil)
  (define-mutator-accessors nursery-start :sap nil)
  (define-mutator-accessors nursery-end :sap nil)
  (define-mutator-accessors storebuf-start :sap nil)
  (define-mutator-accessors storebuf-end :sap nil)
  (define-mutator-accessors words-consed :ub32 nil))

); #+gengc progn



;;;; raw instance slot accessors

(define-vop (raw-instance-ref/word)
  (:translate %raw-instance-ref/word)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types * positive-fixnum)
  (:results (value :scs (unsigned-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types unsigned-num)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset n-word-bytes offset)
    (inst addq object offset lip)
    (inst ldl
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (inst mskll value 4 value)))

(define-vop (raw-instance-set/word)
  (:translate %raw-instance-set/word)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (unsigned-reg)))
  (:arg-types * positive-fixnum unsigned-num)
  (:results (result :scs (unsigned-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types unsigned-num)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset n-word-bytes offset)
    (inst addq object offset lip)
    (inst stl
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (move value result)))

(define-vop (raw-instance-ref/single)
  (:translate %raw-instance-ref/single)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types * positive-fixnum)
  (:results (value :scs (single-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types single-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset n-word-bytes offset)
    (inst addq object offset lip)
    (inst lds
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)))

(define-vop (raw-instance-set/single)
  (:translate %raw-instance-set/single)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (single-reg)))
  (:arg-types * positive-fixnum single-float)
  (:results (result :scs (single-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types single-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset n-word-bytes offset)
    (inst addq object offset lip)
    (inst sts
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (unless (location= result value)
      (inst fmove value result))))

(define-vop (raw-instance-ref/double)
  (:translate %raw-instance-ref/double)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types * positive-fixnum)
  (:results (value :scs (double-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types double-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 2 n-word-bytes) offset)
    (inst addq object offset lip)
    (inst ldt
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)))

(define-vop (raw-instance-set/double)
  (:translate %raw-instance-set/double)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (double-reg)))
  (:arg-types * positive-fixnum double-float)
  (:results (result :scs (double-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types double-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 2 n-word-bytes) offset)
    (inst addq object offset lip)
    (inst stt
          value
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (unless (location= result value)
      (inst fmove value result))))

(define-vop (raw-instance-ref/complex-single)
  (:translate %raw-instance-ref/complex-single)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types * positive-fixnum)
  (:results (value :scs (complex-single-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types complex-single-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 2 n-word-bytes) offset)
    (inst addq object offset lip)
    (inst lds
          (complex-double-reg-real-tn value)
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (inst lds
          (complex-double-reg-imag-tn value)
          (- (* (1+ instance-slots-offset) n-word-bytes)
             instance-pointer-lowtag)
          lip)))

(define-vop (raw-instance-set/complex-single)
  (:translate %raw-instance-set/complex-single)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (complex-single-reg)))
  (:arg-types * positive-fixnum complex-single-float)
  (:results (result :scs (complex-single-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types complex-single-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 2 n-word-bytes) offset)
    (inst addq object offset lip)
    (let ((value-real (complex-single-reg-real-tn value))
          (result-real (complex-single-reg-real-tn result)))
      (inst sts
            value-real
            (- (* instance-slots-offset n-word-bytes)
               instance-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+ instance-slots-offset) n-word-bytes)
               instance-pointer-lowtag)
            lip)
      (unless (location= result-imag value-imag)
        (inst fmove value-imag result-imag)))))

(define-vop (raw-instance-ref/complex-double)
  (:translate %raw-instance-ref/complex-double)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg)))
  (:arg-types * positive-fixnum)
  (:results (value :scs (complex-double-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types complex-double-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 4 n-word-bytes) offset)
    (inst addq object offset lip)
    (inst ldt
          (complex-double-reg-real-tn value)
          (- (* instance-slots-offset n-word-bytes)
             instance-pointer-lowtag)
          lip)
    (inst ldt
          (complex-double-reg-imag-tn value)
          (- (* (+ instance-slots-offset 2) n-word-bytes)
             instance-pointer-lowtag)
          lip)))

(define-vop (raw-instance-set/complex-double)
  (:translate %raw-instance-set/complex-double)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg))
         (index :scs (any-reg))
         (value :scs (complex-double-reg)))
  (:arg-types * positive-fixnum complex-double-float)
  (:results (result :scs (complex-double-reg)))
  (:temporary (:scs (non-descriptor-reg)) offset)
  (:temporary (:scs (interior-reg)) lip)
  (:result-types complex-double-float)
  (:generator 5
    (loadw offset object 0 instance-pointer-lowtag)
    (inst srl offset n-widetag-bits offset)
    (inst sll offset 2 offset)
    (inst subq offset index offset)
    (inst subq offset (* 4 n-word-bytes) offset)
    (inst addq object offset lip)
    (let ((value-real (complex-double-reg-real-tn value))
          (result-real (complex-double-reg-real-tn result)))
      (inst stt
            value-real
            (- (* instance-slots-offset n-word-bytes)
               instance-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
            (- (* (+ instance-slots-offset 2) n-word-bytes)
               instance-pointer-lowtag)
            lip)
      (unless (location= result-imag value-imag)
        (inst fmove value-imag result-imag)))))