call.lisp

来自「开源跨平台Lisp编译器」· LISP 代码 · 共 1,244 行 · 第 1/4 页

     (:vop-var vop)
     (:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
            ,@(unless variable '(nargs))
            ,@(when (eq return :fixed) '(nvals))
            step-instrumenting)

     (:ignore #!+gengc ,@(unless (eq return :tail) '(return-pc-pass))
              ,@(unless (or variable (eq return :tail)) '(arg-locs))
              ,@(unless variable '(args))
              ;; Step instrumentation for full calls not implemented yet.
              ;; See the PPC backend for an example.
              step-instrumenting)

     (:temporary (:sc descriptor-reg
                  :offset ocfp-offset
                  :from (:argument 1)
                  ,@(unless (eq return :fixed)
                      '(:to :eval)))
                 ocfp-pass)

     (:temporary (:sc descriptor-reg
                  :offset #!-gengc lra-offset #!+gengc ra-offset
                  :from (:argument ,(if (eq return :tail) 2 1))
                  :to :eval)
                 return-pc-pass)

     ,@(if named
         `((:temporary (:sc descriptor-reg :offset fdefn-offset
                        :from (:argument ,(if (eq return :tail) 0 1))
                        :to :eval)
                       name-pass))

         `((:temporary (:sc descriptor-reg :offset lexenv-offset
                        :from (:argument ,(if (eq return :tail) 0 1))
                        :to :eval)
                       lexenv)
           #!-gengc
           (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
                       function)))

     (:temporary (:sc any-reg :offset nargs-offset :to :eval)
                 nargs-pass)

     ,@(when variable
         (mapcar (lambda (name offset)
                   `(:temporary (:sc descriptor-reg
                                     :offset ,offset
                                     :to :eval)
                                ,name))
                 register-arg-names *register-arg-offsets*))
     ,@(when (eq return :fixed)
         '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))

     ,@(unless (eq return :tail)
         '((:temporary (:scs (non-descriptor-reg)) temp)
           (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))

     (:temporary (:sc interior-reg :offset lip-offset) entry-point)

     (:generator ,(+ (if named 5 0)
                     (if variable 19 1)
                     (if (eq return :tail) 0 10)
                     15
                     (if (eq return :unknown) 25 0))
       (let* ((cur-nfp (current-nfp-tn vop))
              ,@(unless (eq return :tail)
                  '((lra-label (gen-label))))
              (filler
               (remove nil
                       (list :load-nargs
                             ,@(if (eq return :tail)
                                   '((unless (location= ocfp ocfp-pass)
                                       :load-ocfp)
                                     (unless (location= return-pc
                                                        return-pc-pass)
                                       :load-return-pc)
                                     (when cur-nfp
                                       :frob-nfp))
                                   '(#!-gengc
                                     :comp-lra
                                     (when cur-nfp
                                       :frob-nfp)
                                     :save-fp
                                     :load-fp))))))
         (flet ((do-next-filler ()
                  (let* ((next (pop filler))
                         (what (if (consp next) (car next) next)))
                    (ecase what
                      (:load-nargs
                       ,@(if variable
                             `((inst subq csp-tn new-fp nargs-pass)
                               ,@(let ((index -1))
                                   (mapcar (lambda (name)
                                             `(inst ldl ,name
                                                    ,(ash (incf index)
                                                          word-shift)
                                                    new-fp))
                                           register-arg-names)))
                             '((inst li (fixnumize nargs) nargs-pass))))
                      ,@(if (eq return :tail)
                            '((:load-ocfp
                               (sc-case ocfp
                                 (any-reg
                                  (inst move ocfp ocfp-pass))
                                 (control-stack
                                  (inst ldl ocfp-pass
                                        (ash (tn-offset ocfp)
                                             word-shift)
                                        cfp-tn))))
                              (:load-return-pc
                               (sc-case return-pc
                                 (#!-gengc descriptor-reg #!+gengc any-reg
                                  (inst move return-pc return-pc-pass))
                                 (control-stack
                                  (inst ldl return-pc-pass
                                        (ash (tn-offset return-pc)
                                             word-shift)
                                         cfp-tn))))
                              (:frob-nfp
                               (inst addq cur-nfp
                                     (bytes-needed-for-non-descriptor-stack-frame)
                                     nsp-tn)))
                            `(#!-gengc
                              (:comp-lra
                               (inst compute-lra-from-code
                                     return-pc-pass code-tn lra-label temp))
                              (:frob-nfp
                               (store-stack-tn nfp-save cur-nfp))
                              (:save-fp
                               (inst move cfp-tn ocfp-pass))
                              (:load-fp
                               ,(if variable
                                    '(move new-fp cfp-tn)
                                    '(if (> nargs register-arg-count)
                                         (move new-fp cfp-tn)
                                         (move csp-tn cfp-tn)))
                               (trace-table-entry trace-table-call-site))))
                      ((nil))))))

           ,@(if named
                 `((sc-case name
                     (descriptor-reg (move name name-pass))
                     (control-stack
                      (inst ldl name-pass
                            (ash (tn-offset name) word-shift) cfp-tn)
                      (do-next-filler))
                     (constant
                      (inst ldl name-pass
                            (- (ash (tn-offset name) word-shift)
                               other-pointer-lowtag) code-tn)
                      (do-next-filler)))
                   (inst ldl entry-point
                         (- (ash fdefn-raw-addr-slot word-shift)
                            other-pointer-lowtag) name-pass)
                   (do-next-filler))
                 `((sc-case arg-fun
                     (descriptor-reg (move arg-fun lexenv))
                     (control-stack
                      (inst ldl lexenv
                            (ash (tn-offset arg-fun) word-shift) cfp-tn)
                      (do-next-filler))
                     (constant
                      (inst ldl lexenv
                            (- (ash (tn-offset arg-fun) word-shift)
                               other-pointer-lowtag) code-tn)
                      (do-next-filler)))
                   #!-gengc
                   (inst ldl function
                         (- (ash closure-fun-slot word-shift)
                            fun-pointer-lowtag) lexenv)
                   #!-gengc
                   (do-next-filler)
                   #!-gengc
                   (inst addq function
                         (- (ash simple-fun-code-offset word-shift)
                            fun-pointer-lowtag) entry-point)
                   #!+gengc
                   (inst ldl entry-point
                         (- (ash closure-entry-point-slot word-shift)
                            fun-pointer-lowtag) lexenv)
                   #!+gengc
                   (do-next-filler)))
           (loop
             (if (cdr filler)
                 (do-next-filler)
                 (return)))

           (note-this-location vop :call-site)
           (do-next-filler)
           (inst jsr zero-tn entry-point))

         ,@(ecase return
             (:fixed
              '((trace-table-entry trace-table-normal)
                (emit-return-pc lra-label)
                (default-unknown-values vop values nvals
                                        move-temp temp lra-label)
                (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
             (:unknown
              '((trace-table-entry trace-table-normal)
                (emit-return-pc lra-label)
                (note-this-location vop :unknown-return)
                (receive-unknown-values values-start nvals start count
                                        lra-label temp)
                (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
             (:tail))))))

(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
(define-full-call multiple-call nil :unknown nil)
(define-full-call multiple-call-named t :unknown nil)
(define-full-call tail-call nil :tail nil)
(define-full-call tail-call-named t :tail nil)

(define-full-call call-variable nil :fixed t)
(define-full-call multiple-call-variable nil :unknown t)

;;; This is defined separately, since it needs special code that blits
;;; the arguments down.
(define-vop (tail-call-variable)
  (:args
   (args-arg :scs (any-reg) :target args)
   (function-arg :scs (descriptor-reg) :target lexenv)
   (ocfp-arg :scs (any-reg) :target ocfp)
   (lra-arg :scs (#!-gengc descriptor-reg #!+gengc any-reg) :target lra))

  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 0)) args)
  (:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
  (:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp)
  (:temporary (:sc any-reg :offset #!-gengc lra-offset #!+gengc ra-offset
                   :from (:argument 3)) lra)
  (:temporary (:scs (non-descriptor-reg)) temp)

  (:vop-var vop)

  (:generator 75

    ;; Move these into the passing locations if they are not already there.
    (move args-arg args)
    (move function-arg lexenv)
    (move ocfp-arg ocfp)
    (move lra-arg lra)

    ;; Clear the number stack if anything is there.
    (let ((cur-nfp (current-nfp-tn vop)))
      (when cur-nfp
        (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
              nsp-tn)))

    ;; And jump to the assembly-routine that does the bliting.
    (inst li (make-fixup 'tail-call-variable :assembly-routine) temp)
    (inst jmp zero-tn temp)))

;;;; unknown values return

;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
  (:args (ocfp :scs (any-reg))
         #!-gengc (return-pc :scs (descriptor-reg))
         #!+gengc (return-pc :scs (any-reg) :target ra)
         (value))
  (:ignore value)
  #!-gengc (:temporary (:scs (interior-reg)) lip)
  #!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
  #!+gengc (:temporary (:scs (any-reg) :from (:argument 1)) temp)
  (:vop-var vop)
  (:generator 6
    ;; Clear the number stack.
    (trace-table-entry trace-table-fun-epilogue)
    (let ((cur-nfp (current-nfp-tn vop)))
      (when cur-nfp
        (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
              nsp-tn)))
    ;; Clear the control stack, and restore the frame pointer.
    (move cfp-tn csp-tn)
    (move ocfp cfp-tn)
    ;; Out of here.
    #!-gengc (lisp-return return-pc lip :offset 2)
    #!+gengc
    (progn
      (inst addq return-pc (* 2 n-word-bytes) temp)
      (unless (location= ra return-pc)
        (inst move ra return-pc))
      (inst ret zero-tn temp 1))
    (trace-table-entry trace-table-normal)))

;;; Do unknown-values return of a fixed number of values. The Values
;;; are required to be set up in the standard passing locations. Nvals
;;; is the number of values returned.
;;;
;;; If returning a single value, then deallocate the current frame,
;;; restore FP and jump to the single-value entry at Return-PC + 8.
;;;
;;; If returning other than one value, then load the number of values
;;; returned, NIL out unsupplied values registers, restore FP and
;;; return at Return-PC. When there are stack values, we must
;;; initialize the argument pointer to point to the beginning of the
;;; values block (which is the beginning of the current frame.)
(define-vop (return)
  (:args (ocfp :scs (any-reg))
         (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg)
                    :to (:eval 1)
                    #!+gengc :target #!+gengc ra)
         (values :more t))
  (:ignore values)
  (:info nvals)
  (:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
  (:temporary (:sc descriptor-reg :offset a1-offset :from (:eval 0)) a1)
  (:temporary (:sc descriptor-reg :offset a2-offset :from (:eval 0)) a2)
  (:temporary (:sc descriptor-reg :offset a3-offset :from (:eval 0)) a3)
  (:temporary (:sc descriptor-reg :offset a4-offset :from (:eval 0)) a4)