call.lisp

开源跨平台Lisp编译器

               ,@(unless variable '((args :more t :scs (descriptor-reg)))))

               ,@(when (eq return :fixed)
               '((: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
               ;; EAX. 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 eax-offset
                    :from (:argument 0)
                    :to :eval)
               eax)

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

               ;; 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! EAX stores the 'lexical environment' needed
               ;; for closures.
               (move eax 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 ecx new-fp))
                              (noise '(inst sub ecx esp-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)
                         (inst xor ecx ecx)
                       (inst mov ecx (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
                                              ebp-tn
                                              (frame-word-offset ocfp-save-offset))))
                                   ((any-reg descriptor-reg)
                                    (format t "** tail-call old-fp in reg not S0~%")
                                    (storew old-fp
                                            ebp-tn
                                            (frame-word-offset ocfp-save-offset))))

                          ;; For tail call, we have to push the
                          ;; return-pc so that it looks like we CALLed
                          ;; despite 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 esp-tn (fixnumize 3)))

                          ;; Save the fp
                          (storew ebp-tn new-fp (frame-word-offset ocfp-save-offset))

                          (move ebp-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)
                     ,(if named
                          '(make-ea-for-object-slot eax fdefn-raw-addr-slot
                                                    other-pointer-lowtag)
                          '(make-ea-for-object-slot eax closure-fun-slot
                                                    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 esi)
         (function :scs (descriptor-reg control-stack) :target eax)
         (old-fp)
         (ret-addr))
  (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) esi)
  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)
;  (:ignore ret-addr old-fp)
  (:generator 75
    ;; Move these into the passing locations if they are not already there.
    (move esi args)
    (move eax 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?"))


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

;;; Return a single-value using the Unknown-Values convention. Specifically,
;;; we jump to clear the stack and jump to return-pc+2.
;;;
;;; We require old-fp to be in a register, because we want to reset ESP before
;;; restoring EBP. 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.
;;;
;;; First off, modifying the return-pc defeats the branch-prediction
;;; optimizations on modern CPUs quite handily. Second, we can do all
;;; this without needing a temp register. Fixed the latter, at least.
;;; -- AB 2006/Feb/04
(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 esp-tn (make-ea :dword :base ebp-tn
                                           :disp (frame-byte-offset ocfp-save-offset)))
                 (inst pop ebp-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 esp 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 esp-tn ebp-tn)
          (move ebp-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 esp-tn (make-ea :dword :base ebp-tn
                                 :disp (frame-byte-offset (tn-offset return-pc))))
       ;; Set single-value return flag
       (inst clc)
       ;; Restore the old frame pointer
       (move ebp-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 ECX with the number of values returned and
;;; EBX with a pointer to the values, set ESP 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 ebx-offset) ebx)
  (:temporary (:sc unsigned-reg :offset ecx-offset) ecx)

  ;; 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 ebx ebp-tn)
    (if (zerop nvals)
        (inst xor ecx ecx) ; smaller
      (inst mov ecx (fixnumize nvals)))
    ;; Restore the frame pointer.
    (move ebp-tn old-fp)
    ;; Clear as much of the stack as possible, but not past the return
    ;; address.
    (inst lea esp-tn (make-ea :dword :base ebx
                              :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 multi-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 EBX instead of EBP.
    (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 :dword :base ebx
                              :disp (frame-byte-offset (tn-offset return-pc))))))

    (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.
;;;
;;; The assembly routine takes the following args:
;;;  EAX -- the return-pc to finally jump to.
;;;  EBX -- pointer to where to put the values.
;;;  ECX -- number of values to find there.
;;;  ESI -- pointer to where to find the values.
(define-vop (return-multiple)
  (:args (old-fp :to (:eval 1) :target old-fp-temp)
         (return-pc :target eax)
         (vals :scs (any-reg) :target esi)
         (nvals :scs (any-reg) :target ecx))

  (:temporary (:sc unsigned-reg :offset eax-offset :from (:argument 1)) eax)