macros.lisp

开源跨平台Lisp编译器

       (:args (object :scs (descriptor-reg))
              (index :scs (any-reg)))
       (:arg-types ,type tagged-num)
       (:temporary (:scs (interior-reg)) lip)
       (:results (value :scs ,scs))
       (:result-types ,el-type)
       (:generator 5
         (inst addq object index lip)
         (inst ldl value (- (* ,offset n-word-bytes) ,lowtag) lip)
         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))
     (define-vop (,(symbolicate name "-C"))
       ,@(when translate
           `((:translate ,translate)))
       (:policy :fast-safe)
       (:args (object :scs (descriptor-reg)))
       (:info index)
       (:arg-types ,type
                   (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
                                                ,(eval offset))))
       (:results (value :scs ,scs))
       (:result-types ,el-type)
       (:generator 4
         (inst ldl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
               object)
         ,@(when (equal scs '(unsigned-reg))
             '((inst mskll value 4 value)))))))

(defmacro define-full-setter (name type offset lowtag scs el-type
                                   &optional translate #!+gengc (remember t))
  `(progn
     (define-vop (,name)
       ,@(when translate
           `((:translate ,translate)))
       (:policy :fast-safe)
       (:args (object :scs (descriptor-reg))
              (index :scs (any-reg))
              (value :scs ,scs :target result))
       (:arg-types ,type tagged-num ,el-type)
       (:temporary (:scs (interior-reg)) lip)
       (:results (result :scs ,scs))
       (:result-types ,el-type)
       (:generator 2
         (inst addq index object lip)
         (inst stl value (- (* ,offset n-word-bytes) ,lowtag) lip)
         (move value result)))
     (define-vop (,(symbolicate name "-C"))
       ,@(when translate
           `((:translate ,translate)))
       (:policy :fast-safe)
       (:args (object :scs (descriptor-reg))
              (value :scs ,scs))
       (:info index)
       (:arg-types ,type
                   (:constant (load/store-index ,n-word-bytes ,(eval lowtag)
                                                ,(eval offset)))
                   ,el-type)
       (:results (result :scs ,scs))
       (:result-types ,el-type)
       (:generator 1
         (inst stl value (- (* (+ ,offset index) n-word-bytes) ,lowtag)
               object)
         (move value result)))))


(defmacro define-partial-reffer (name type size signed offset lowtag scs
                                      el-type &optional translate)
  (let ((scale (ecase size (:byte 1) (:short 2))))
    `(progn
       (define-vop (,name)
         ,@(when translate
             `((:translate ,translate)))
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg))
                (index :scs (unsigned-reg)))
         (:arg-types ,type positive-fixnum)
         (:results (value :scs ,scs))
         (:result-types ,el-type)
         (:temporary (:scs (interior-reg)) lip)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)
         (:generator 5
           (inst addq object index lip)
           ,@(when (eq size :short)
               '((inst addq index lip lip)))
           ,@(ecase size
               (:byte
                (if signed
                    `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
                            lip)
                      (inst lda temp1 (1+ (- (* ,offset n-word-bytes) ,lowtag))
                            lip)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))
                    `((inst ldq_u
                            temp
                            (- (* ,offset n-word-bytes) ,lowtag)
                            lip)
                      (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
                                          lip)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed
                    `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
                            lip)
                      (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag)
                            lip)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))
                    `((inst ldq_u temp (- (* ,offset n-word-bytes) ,lowtag)
                            lip)
                      (inst lda temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
                      (inst extwl temp temp1 value)))))))
       (define-vop (,(symbolicate name "-C"))
         ,@(when translate
             `((:translate ,translate)))
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg)))
         (:info index)
         (:arg-types ,type
                     (:constant (load/store-index ,scale
                                                  ,(eval lowtag)
                                                  ,(eval offset))))
         (:results (value :scs ,scs))
         (:result-types ,el-type)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)
         (:generator 4
           ,@(ecase size
               (:byte
                (if signed
                    `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
                                             (* index ,scale)) ,lowtag)
                            object)
                      (inst lda temp1 (1+ (- (+ (* ,offset n-word-bytes)
                                                (* index ,scale)) ,lowtag))
                            object)
                      (inst extqh temp temp1 temp)
                      (inst sra temp 56 value))
                    `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
                                             (* index ,scale)) ,lowtag)
                            object)
                      (inst lda temp1 (- (+ (* ,offset n-word-bytes)
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extbl temp temp1 value))))
               (:short
                (if signed
                    `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
                                             (* index ,scale)) ,lowtag)
                            object)
                      (inst lda temp1 (- (+ (* ,offset n-word-bytes)
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 temp)
                      (inst sll temp 48 temp)
                      (inst sra temp 48 value))
                    `((inst ldq_u temp (- (+ (* ,offset n-word-bytes)
                                             (* index ,scale)) ,lowtag)
                            object)
                      (inst lda temp1 (- (+ (* ,offset n-word-bytes)
                                            (* index ,scale)) ,lowtag)
                            object)
                      (inst extwl temp temp1 value))))))))))

(defmacro define-partial-setter (name type size offset lowtag scs el-type
                                      &optional translate)
  (let ((scale (ecase size (:byte 1) (:short 2))))
    `(progn
       (define-vop (,name)
         ,@(when translate
             `((:translate ,translate)))
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg))
                (index :scs (unsigned-reg))
                (value :scs ,scs :target result))
         (:arg-types ,type positive-fixnum ,el-type)
         (:temporary (:scs (interior-reg)) lip)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)
         (:temporary (:sc non-descriptor-reg) temp2)
         (:results (result :scs ,scs))
         (:result-types ,el-type)
         (:generator 5
           (inst addq object index lip)
           ,@(when (eq size :short)
               '((inst addq lip index lip)))
           ,@(ecase size
               (:byte
                `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
                  (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
                  (inst insbl value  temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)
                  (inst stq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)))
               (:short
                `((inst lda temp (- (* ,offset n-word-bytes) ,lowtag) lip)
                  (inst ldq_u temp1 (- (* ,offset n-word-bytes) ,lowtag) lip)
                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)
                  (inst stq_u temp (- (* ,offset n-word-bytes) ,lowtag) lip))))
           (move value result)))
       (define-vop (,(symbolicate name "-C"))
         ,@(when translate
             `((:translate ,translate)))
         (:policy :fast-safe)
         (:args (object :scs (descriptor-reg))
                (value :scs ,scs :target result))
         (:info index)
         (:arg-types ,type
                     (:constant (load/store-index ,scale
                                                  ,(eval lowtag)
                                                  ,(eval offset)))
                     ,el-type)
         (:temporary (:sc non-descriptor-reg) temp)
         (:temporary (:sc non-descriptor-reg) temp1)
         (:temporary (:sc non-descriptor-reg) temp2)
         (:results (result :scs ,scs))
         (:result-types ,el-type)
         (:generator 4
           ,@(ecase size
               (:byte
                `((inst lda temp (- (+ (* ,offset n-word-bytes)
                                       (* index ,scale))
                                    ,lowtag)
                        object)
                  (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
                                          (* index ,scale))
                                       ,lowtag)
                        object)
                  (inst insbl value temp temp2)
                  (inst mskbl temp1 temp temp1)
                  (inst bis temp1 temp2 temp1)
                  (inst stq_u temp1 (- (+ (* ,offset n-word-bytes)
                                          (* index ,scale))
                                       ,lowtag) object)))
               (:short
                `((inst lda temp (- (+ (* ,offset n-word-bytes)
                                       (* index ,scale))
                                    ,lowtag)
                        object)
                  (inst ldq_u temp1 (- (+ (* ,offset n-word-bytes)
                                          (* index ,scale))
                                       ,lowtag)
                        object)
                  (inst mskwl temp1 temp temp1)
                  (inst inswl value temp temp2)
                  (inst bis temp1 temp2 temp)
                  (inst stq_u temp (- (+ (* ,offset n-word-bytes)
                                         (* index ,scale))
                                      ,lowtag) object))))
           (move value result))))))

(def!macro with-pinned-objects ((&rest objects) &body body)
  "Arrange with the garbage collector that the pages occupied by
OBJECTS will not be moved in memory for the duration of BODY.
Useful for e.g. foreign calls where another thread may trigger
garbage collection.  This is currently implemented by disabling GC"
  (declare (ignore objects))            ;should we eval these for side-effect?
  `(without-gcing
    ,@body))