call.lisp

开源跨平台Lisp编译器

               '((:results (values :more t))))

               (:save-p ,(if (eq return :tail) :compute-only t))

               ,@(unless (or (eq return :tail) variable)
               '((:move-args :full-call)))

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

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

               ;; We pass either the fdefn object (for named call) or
               ;; the actual function object (for unnamed call) in
               ;; RAX. With named call, closure-tramp will replace it
               ;; with the real function and invoke the real function
               ;; for closures. Non-closures do not need this value,
               ;; so don't care what shows up in it.
               (:temporary
               (:sc descriptor-reg
                    :offset rax-offset
                    :from (:argument 0)
                    :to :eval)
               rax)

               ;; We pass the number of arguments in RCX.
               (:temporary (:sc unsigned-reg :offset rcx-offset :to :eval) rcx)

               ;; With variable call, we have to load the
               ;; register-args out of the (new) stack frame before
               ;; doing the call. Therefore, we have to tell the
               ;; lifetime stuff that we need to use them.
               ,@(when variable
                   (mapcar (lambda (name offset)
                             `(:temporary (:sc descriptor-reg
                                               :offset ,offset
                                               :from (:argument 0)
                                               :to :eval)
                                          ,name))
                           *register-arg-names* *register-arg-offsets*))

               ,@(when (eq return :tail)
                   '((:temporary (:sc unsigned-reg
                                      :from (:argument 1)
                                      :to (:argument 2))
                                 old-fp-tmp)))

               (:generator ,(+ (if named 5 0)
                               (if variable 19 1)
                               (if (eq return :tail) 0 10)
                               15
                               (if (eq return :unknown) 25 0))
               (trace-table-entry trace-table-call-site)

               ;; This has to be done before the frame pointer is
               ;; changed! RAX stores the 'lexical environment' needed
               ;; for closures.
               (move rax fun)


               ,@(if variable
                     ;; For variable call, compute the number of
                     ;; arguments and move some of the arguments to
                     ;; registers.
                     (collect ((noise))
                              ;; Compute the number of arguments.
                              (noise '(inst mov rcx new-fp))
                              (noise '(inst sub rcx rsp-tn))
                              ;; Move the necessary args to registers,
                              ;; this moves them all even if they are
                              ;; not all needed.
                              (loop
                               for name in *register-arg-names*
                               for index downfrom -1
                               do (noise `(loadw ,name new-fp ,index)))
                              (noise))
                   '((if (zerop nargs)
                         (zeroize rcx)
                       (inst mov rcx (fixnumize nargs)))))
               ,@(cond ((eq return :tail)
                        '(;; Python has figured out what frame we should
                          ;; return to so might as well use that clue.
                          ;; This seems really important to the
                          ;; implementation of things like
                          ;; (without-interrupts ...)
                          ;;
                          ;; dtc; Could be doing a tail call from a
                          ;; known-local-call etc in which the old-fp
                          ;; or ret-pc are in regs or in non-standard
                          ;; places. If the passing location were
                          ;; wired to the stack in standard locations
                          ;; then these moves will be un-necessary;
                          ;; this is probably best for the x86.
                          (sc-case old-fp
                                   ((control-stack)
                                    (unless (= ocfp-save-offset
                                               (tn-offset old-fp))
                                      ;; FIXME: FORMAT T for stale
                                      ;; diagnostic output (several of
                                      ;; them around here), ick
                                      (format t "** tail-call old-fp not S0~%")
                                      (move old-fp-tmp old-fp)
                                      (storew old-fp-tmp
                                              rbp-tn
                                              (- (1+ ocfp-save-offset)))))
                                   ((any-reg descriptor-reg)
                                    (format t "** tail-call old-fp in reg not S0~%")
                                    (storew old-fp
                                            rbp-tn
                                            (- (1+ ocfp-save-offset)))))

                          ;; For tail call, we have to push the
                          ;; return-pc so that it looks like we CALLed
                          ;; drspite the fact that we are going to JMP.
                          (inst push return-pc)
                          ))
                       (t
                        ;; For non-tail call, we have to save our
                        ;; frame pointer and install the new frame
                        ;; pointer. We can't load stack tns after this
                        ;; point.
                        `(;; Python doesn't seem to allocate a frame
                          ;; here which doesn't leave room for the
                          ;; ofp/ret stuff.

                          ;; The variable args are on the stack and
                          ;; become the frame, but there may be <3
                          ;; args and 3 stack slots are assumed
                          ;; allocate on the call. So need to ensure
                          ;; there are at least 3 slots. This hack
                          ;; just adds 3 more.
                          ,(if variable
                               '(inst sub rsp-tn (fixnumize 3)))

                          ;; Save the fp
                          (storew rbp-tn new-fp (- (1+ ocfp-save-offset)))

                          (move rbp-tn new-fp) ; NB - now on new stack frame.
                          )))

               (when step-instrumenting
                 (emit-single-step-test)
                 (inst jmp :eq DONE)
                 (inst break single-step-around-trap))
               DONE

               (note-this-location vop :call-site)

               (inst ,(if (eq return :tail) 'jmp 'call)
                     (make-ea :qword :base rax
                              :disp ,(if named
                                         '(- (* fdefn-raw-addr-slot
                                                n-word-bytes)
                                             other-pointer-lowtag)
                                       '(- (* closure-fun-slot n-word-bytes)
                                           fun-pointer-lowtag))))
               ,@(ecase return
                   (:fixed
                    '((default-unknown-values vop values nvals)))
                   (:unknown
                    '((note-this-location vop :unknown-return)
                      (receive-unknown-values values-start nvals start count)))
                   (:tail))
               (trace-table-entry trace-table-normal)))))

  (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 BLT's
;;; the arguments down. All the real work is done in the assembly
;;; routine. We just set things up so that it can find what it needs.
(define-vop (tail-call-variable)
  (:args (args :scs (any-reg control-stack) :target rsi)
         (function :scs (descriptor-reg control-stack) :target rax)
         (old-fp)
         (ret-addr))
  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) rsi)
  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
  (:temporary (:sc unsigned-reg) call-target)
;  (:ignore ret-addr old-fp)
  (:generator 75
    ;; Move these into the passing locations if they are not already there.
    (move rsi args)
    (move rax function)

    ;; The following assumes that the return-pc and old-fp are on the
    ;; stack in their standard save locations - Check this.
    (unless (and (sc-is old-fp control-stack)
                 (= (tn-offset old-fp) ocfp-save-offset))
            (error "tail-call-variable: ocfp not on stack in standard save location?"))
    (unless (and (sc-is ret-addr sap-stack)
                 (= (tn-offset ret-addr) return-pc-save-offset))
            (error "tail-call-variable: ret-addr not on stack in standard save location?"))


    (inst lea call-target
          (make-ea :qword
                   :disp (make-fixup 'tail-call-variable :assembly-routine)))
    ;; And jump to the assembly routine.
    (inst jmp call-target)))

;;;; unknown values return

;;; Return a single-value using the Unknown-Values convention. Specifically,
;;; we jump to clear the stack and jump to return-pc+3.
;;;
;;; We require old-fp to be in a register, because we want to reset RSP before
;;; restoring RBP. If old-fp were still on the stack, it could get clobbered
;;; by a signal.
;;;
;;; pfw--get wired-tn conflicts sometimes if register sc specd for args
;;; having problems targeting args to regs -- using temps instead.
(define-vop (return-single)
  (:args (old-fp)
         (return-pc)
         (value))
  (:ignore value)
  (:generator 6
    (trace-table-entry trace-table-fun-epilogue)
    ;; Code structure lifted from known-return.
    (sc-case return-pc
      ((sap-reg)
       ;; return PC in register for some reason (local call?)
       ;; we jmp to the return pc after fixing the stack and frame.
       (sc-case old-fp
         ((control-stack)
          ;; ofp on stack must be in slot 0 (the traditional storage place).
          ;; Drop the stack above it and pop it off.
          (cond ((zerop (tn-offset old-fp))
                 (inst lea rsp-tn (make-ea :dword :base rbp-tn
                                           :disp (- (* (1+ ocfp-save-offset)
                                                       n-word-bytes))))
                 (inst pop rbp-tn))
                (t
                 ;; Should this ever happen, we do the same as above, but
                 ;; using (tn-offset old-fp) instead of ocfp-save-offset
                 ;; (which is 0 anyway, see src/compiler/x86/vm.lisp) and
                 ;; then lea rsp again against itself with a displacement
                 ;; of (* (tn-offset old-fp) n-word-bytes) to clear the
                 ;; rest of the stack.
                 (cerror "Continue anyway"
                         "VOP return-single doesn't work if old-fp (in slot ~S) is not in slot 0" (tn-offset old-fp)))))
         ((any-reg descriptor-reg)
          ;; ofp in reg, drop the stack and load the real fp.
          (move rsp-tn rbp-tn)
          (move rbp-tn old-fp)))

       ;; Set single-value-return flag
       (inst clc)
       ;; And return
       (inst jmp return-pc))

      ((sap-stack)
       ;; Note that this will only work right if, when old-fp is on
       ;; the stack, it has a lower tn-offset than return-pc. One of
       ;; the comments in known-return indicate that this is the case
       ;; (in that it will be in its save location), but we may wish
       ;; to assert that (in either the weaker or stronger forms).
       ;; Should this ever not be the case, we should load old-fp
       ;; into a temp reg while we fix the stack.
       ;; Drop stack above return-pc
       (inst lea rsp-tn (make-ea :dword :base rbp-tn
                                 :disp (- (* (1+ (tn-offset return-pc))
                                             n-word-bytes))))
       ;; Set single-value return flag
       (inst clc)
       ;; Restore the old frame pointer
       (move rbp-tn old-fp)
       ;; And return, dropping the rest of the stack as we go.
       (inst ret (* (tn-offset return-pc) n-word-bytes))))))

;;; Do unknown-values return of a fixed (other than 1) number of
;;; values. The VALUES are required to be set up in the standard
;;; passing locations. NVALS is the number of values returned.
;;;
;;; Basically, we just load RCX with the number of values returned and
;;; RBX with a pointer to the values, set RSP to point to the end of
;;; the values, and jump directly to return-pc.
(define-vop (return)
  (:args (old-fp)
         (return-pc :to (:eval 1))
         (values :more t))
  (:ignore values)
  (:info nvals)

  ;; In the case of other than one value, we need these registers to
  ;; tell the caller where they are and how many there are.
  (:temporary (:sc unsigned-reg :offset rbx-offset) rbx)
  (:temporary (:sc unsigned-reg :offset rcx-offset) rcx)

  ;; We need to stretch the lifetime of return-pc past the argument
  ;; registers so that we can default the argument registers without
  ;; trashing return-pc.
  (:temporary (:sc unsigned-reg :offset (first *register-arg-offsets*)
                   :from :eval) a0)
  (:temporary (:sc unsigned-reg :offset (second *register-arg-offsets*)
                   :from :eval) a1)
  (:temporary (:sc unsigned-reg :offset (third *register-arg-offsets*)
                   :from :eval) a2)

  (:generator 6
    (trace-table-entry trace-table-fun-epilogue)
    ;; Establish the values pointer and values count.
    (move rbx rbp-tn)
    (if (zerop nvals)
        (zeroize rcx) ; smaller
      (inst mov rcx (fixnumize nvals)))
    ;; Restore the frame pointer.
    (move rbp-tn old-fp)
    ;; Clear as much of the stack as possible, but not past the return
    ;; address.
    (inst lea rsp-tn (make-ea :qword :base rbx
                              :disp (- (* (max nvals 2) n-word-bytes))))
    ;; Pre-default any argument register that need it.
    (when (< nvals register-arg-count)
      (let* ((arg-tns (nthcdr nvals (list a0 a1 a2)))
             (first (first arg-tns)))
        (inst mov first nil-value)
        (dolist (tn (cdr arg-tns))
          (inst mov tn first))))
    ;; Set the multiple value return flag.
    (inst stc)
    ;; And away we go. Except that return-pc is still on the
    ;; stack and we've changed the stack pointer. So we have to
    ;; tell it to index off of RBX instead of RBP.
    (cond ((zerop nvals)
           ;; Return popping the return address and the OCFP.
           (inst ret n-word-bytes))
          ((= nvals 1)
           ;; Return popping the return, leaving 1 slot. Can this
           ;; happen, or is a single value return handled elsewhere?
           (inst ret))
          (t
           (inst jmp (make-ea :qword :base rbx
                              :disp (- (* (1+ (tn-offset return-pc))
                                          n-word-bytes))))))

    (trace-table-entry trace-table-normal)))

;;; Do unknown-values return of an arbitrary number of values (passed
;;; on the stack.) We check for the common case of a single return
;;; value, and do that inline using the normal single value return
;;; convention. Otherwise, we branch off to code that calls an
;;; assembly-routine.
;;;