call.lisp

开源跨平台Lisp编译器

            ,@(when (eq return :fixed) '(nvals))
            step-instrumenting)

     (:ignore ,@(unless (or variable (eq return :tail)) '(arg-locs))
              ,@(unless variable '(args)))

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

     (:temporary (:sc descriptor-reg
                  :offset lra-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)
           (: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)))

     (:temporary (:scs (descriptor-reg) :to :eval) stepping)

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

     (:temporary (:sc interior-reg) 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))))
              (step-done-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))
                                   '(: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 subu nargs-pass csp-tn new-fp)
                               ,@(let ((index -1))
                                   (mapcar #'(lambda (name)
                                               `(inst lw ,name new-fp
                                                      ,(ash (incf index)
                                                            word-shift)))
                                           register-arg-names)))
                             '((inst li nargs-pass (fixnumize nargs)))))
                      ,@(if (eq return :tail)
                            '((:load-ocfp
                               (sc-case ocfp
                                 (any-reg
                                  (move ocfp-pass ocfp t))
                                 (control-stack
                                  (inst lw ocfp-pass cfp-tn
                                        (ash (tn-offset ocfp)
                                             word-shift)))))
                              (:load-return-pc
                               (sc-case return-pc
                                 (descriptor-reg
                                  (move return-pc-pass return-pc t))
                                 (control-stack
                                  (inst lw return-pc-pass cfp-tn
                                        (ash (tn-offset return-pc)
                                             word-shift)))))
                              (:frob-nfp
                               (inst addu nsp-tn cur-nfp
                                     (bytes-needed-for-non-descriptor-stack-frame))))
                            `((: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
                               (move ocfp-pass cfp-tn t))
                              (:load-fp
                               ,(if variable
                                    '(move cfp-tn new-fp)
                                    '(if (> nargs register-arg-count)
                                         (move cfp-tn new-fp)
                                         (move cfp-tn csp-tn)))
                               (trace-table-entry trace-table-call-site))))
                      ((nil)
                       (inst nop)))))
                (insert-step-instrumenting (callable-tn)
                  ;; Conditionally insert a conditional trap:
                  (when step-instrumenting
                    ;; Get the symbol-value of SB!IMPL::*STEPPING*
                    (inst lw stepping null-tn
                          (- (+ symbol-value-slot
                                (truncate (static-symbol-offset 'sb!impl::*stepping*)
                                          n-word-bytes))
                             other-pointer-lowtag))
                    ;; If it's not NIL, trap.
                    (inst beq stepping null-tn step-done-label)
                    (inst nop)
                    ;; CONTEXT-PC will be pointing here when the
                    ;; interrupt is handled, not after the BREAK.
                    (note-this-location vop :step-before-vop)
                    ;; Construct a trap code with the low bits from
                    ;; SINGLE-STEP-AROUND-TRAP and the high bits from
                    ;; the register number of CALLABLE-TN.
                    (inst break 0 (logior single-step-around-trap
                                          (ash (reg-tn-encoding callable-tn)
                                               5)))
                    (emit-label step-done-label))))

           ,@(if named
                 `((sc-case name
                     (descriptor-reg (move name-pass name))
                     (control-stack
                      (inst lw name-pass cfp-tn
                            (ash (tn-offset name) word-shift))
                      (do-next-filler))
                     (constant
                      (inst lw name-pass code-tn
                            (- (ash (tn-offset name) word-shift)
                               other-pointer-lowtag))
                      (do-next-filler)))
                   ;; The step instrumenting must be done after
                   ;; FUNCTION is loaded, but before ENTRY-POINT is
                   ;; calculated.
                   (insert-step-instrumenting name-pass)
                   (inst lw entry-point name-pass
                         (- (ash fdefn-raw-addr-slot word-shift)
                            other-pointer-lowtag))
                   (do-next-filler))
                 `((sc-case arg-fun
                     (descriptor-reg (move lexenv arg-fun))
                     (control-stack
                      (inst lw lexenv cfp-tn
                            (ash (tn-offset arg-fun) word-shift))
                      (do-next-filler))
                     (constant
                      (inst lw lexenv code-tn
                            (- (ash (tn-offset arg-fun) word-shift)
                               other-pointer-lowtag))
                      (do-next-filler)))
                   (inst lw function lexenv
                         (- (ash closure-fun-slot word-shift)
                            fun-pointer-lowtag))
                   (do-next-filler)
                   ;; The step instrumenting must be done before
                   ;; after FUNCTION is loaded, but before ENTRY-POINT
                   ;; is calculated.
                   (insert-step-instrumenting function)
                   (inst addu entry-point function
                         (- (ash simple-fun-code-offset word-shift)
                            fun-pointer-lowtag))))
           (loop
             (if (cdr filler)
                 (do-next-filler)
                 (return)))

           (do-next-filler)
           (note-this-location vop :call-site)
           (inst j entry-point)
           (inst nop))

         ,@(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)
                (when cur-nfp
                  (load-stack-tn cur-nfp nfp-save))))
             (: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)
                (when cur-nfp
                  (load-stack-tn cur-nfp nfp-save))))
             (: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)


;;; Defined separately, since needs special code that BLT's 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 (descriptor-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 lra-offset :from (:argument 3)) lra)

  (:vop-var vop)

  (:generator 75

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

    ;; Clear the number stack if anything is there and jump to the
    ;; assembly-routine that does the bliting.
    (inst j (make-fixup 'tail-call-variable :assembly-routine))
    (let ((cur-nfp (current-nfp-tn vop)))
      (if cur-nfp
        (inst addu nsp-tn cur-nfp
              (bytes-needed-for-non-descriptor-stack-frame))
        (inst nop)))))


;;;; Unknown values return:

;;; Return a single value using the unknown-values convention.
;;;
(define-vop (return-single)
  (:args (ocfp :scs (any-reg))
         (return-pc :scs (descriptor-reg))
         (value))
  (:ignore value)
  (:temporary (:scs (interior-reg)) lip)
  (: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 addu nsp-tn cur-nfp
              (bytes-needed-for-non-descriptor-stack-frame))))
    ;; Clear the control stack, and restore the frame pointer.
    (move csp-tn cfp-tn)
    (move cfp-tn ocfp)
    ;; Out of here.
    (lisp-return return-pc lip :offset 2)
    (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 (descriptor-reg) :to (:eval 1))
         (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)
  (:temporary (:sc descriptor-reg :offset a5-offset :from (:eval 0)) a5)
  (:temporary (:sc any-reg :offset nargs-offset) nargs)
  (:temporary (:sc any-reg :offset ocfp-offset) val-ptr)
  (:temporary (:scs (interior-reg)) lip)
  (:vop-var vop)
  (:generator 6
    ;; Clear the number stack.
    (trace-table-entry trace-table-fun-epilogue)
    (let ((cur-nfp (current-nfp-tn vop)))