call.lisp

开源跨平台Lisp编译器

      (inst mov rsp-tn rbx-tn)
      (inst cld))))
  (values))

;;;; unknown values receiving

;;; Emit code needed at the return point for an unknown-values call
;;; for an arbitrary number of values.
;;;
;;; We do the single and non-single cases with no shared code: there
;;; doesn't seem to be any potential overlap, and receiving a single
;;; value is more important efficiency-wise.
;;;
;;; When there is a single value, we just push it on the stack,
;;; returning the old SP and 1.
;;;
;;; When there is a variable number of values, we move all of the
;;; argument registers onto the stack, and return ARGS and NARGS.
;;;
;;; ARGS and NARGS are TNs wired to the named locations. We must
;;; explicitly allocate these TNs, since their lifetimes overlap with
;;; the results start and count. (Also, it's nice to be able to target
;;; them.)
(defun receive-unknown-values (args nargs start count)
  (declare (type tn args nargs start count))
  (let ((variable-values (gen-label))
        (done (gen-label)))
    (inst jmp :c variable-values)

    (cond ((location= start (first *register-arg-tns*))
           (inst push (first *register-arg-tns*))
           (inst lea start (make-ea :qword :base rsp-tn :disp 8)))
          (t (inst mov start rsp-tn)
             (inst push (first *register-arg-tns*))))
    (inst mov count (fixnumize 1))
    (inst jmp done)

    (emit-label variable-values)
    ;; dtc: this writes the registers onto the stack even if they are
    ;; not needed, only the number specified in rcx are used and have
    ;; stack allocated to them. No harm is done.
    (loop
      for arg in *register-arg-tns*
      for i downfrom -1
      do (storew arg args i))
    (move start args)
    (move count nargs)

    (emit-label done))
  (values))

;;; VOP that can be inherited by unknown values receivers. The main thing this
;;; handles is allocation of the result temporaries.
(define-vop (unknown-values-receiver)
  (:temporary (:sc descriptor-reg :offset rbx-offset
                   :from :eval :to (:result 0))
              values-start)
  (:temporary (:sc any-reg :offset rcx-offset
               :from :eval :to (:result 1))
              nvals)
  (:results (start :scs (any-reg control-stack))
            (count :scs (any-reg control-stack))))

;;;; local call with unknown values convention return

;;; Non-TR local call for a fixed number of values passed according to
;;; the unknown values convention.
;;;
;;; FP is the frame pointer in install before doing the call.
;;;
;;; NFP would be the number-stack frame pointer if we had a separate
;;; number stack.
;;;
;;; Args are the argument passing locations, which are specified only
;;; to terminate their lifetimes in the caller.
;;;
;;; VALUES are the return value locations (wired to the standard
;;; passing locations). NVALS is the number of values received.
;;;
;;; Save is the save info, which we can ignore since saving has been
;;; done.
;;;
;;; TARGET is a continuation pointing to the start of the called
;;; function.
(define-vop (call-local)
  (:args (fp)
         (nfp)
         (args :more t))
  (:temporary (:sc unsigned-reg) return-label)
  (:results (values :more t))
  (:save-p t)
  (:move-args :local-call)
  (:info arg-locs callee target nvals)
  (:vop-var vop)
  (:ignore nfp arg-locs args #+nil callee)
  (:generator 5
    (trace-table-entry trace-table-call-site)
    (move rbp-tn fp)

    (let ((ret-tn (callee-return-pc-tn callee)))
      #+nil
      (format t "*call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))

      ;; Is the return-pc on the stack or in a register?
      (sc-case ret-tn
        ((sap-stack)
         #+nil (format t "*call-local: ret-tn on stack; offset=~S~%"
                       (tn-offset ret-tn))
         (inst lea return-label (make-fixup nil :code-object RETURN))
         (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
        ((sap-reg)
         (inst lea ret-tn (make-fixup nil :code-object RETURN)))))

    (note-this-location vop :call-site)
    (inst jmp target)
    RETURN
    (default-unknown-values vop values nvals)
    (trace-table-entry trace-table-normal)))

;;; Non-TR local call for a variable number of return values passed according
;;; to the unknown values convention. The results are the start of the values
;;; glob and the number of values received.
(define-vop (multiple-call-local unknown-values-receiver)
  (:args (fp)
         (nfp)
         (args :more t))
  (:temporary (:sc unsigned-reg) return-label)
  (:save-p t)
  (:move-args :local-call)
  (:info save callee target)
  (:ignore args save nfp #+nil callee)
  (:vop-var vop)
  (:generator 20
    (trace-table-entry trace-table-call-site)
    (move rbp-tn fp)

    (let ((ret-tn (callee-return-pc-tn callee)))
      #+nil
      (format t "*multiple-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))

      ;; Is the return-pc on the stack or in a register?
      (sc-case ret-tn
        ((sap-stack)
         #+nil (format t "*multiple-call-local: ret-tn on stack; offset=~S~%"
                       (tn-offset ret-tn))
         ;; Stack
         (inst lea return-label (make-fixup nil :code-object RETURN))
         (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
        ((sap-reg)
         ;; Register
         (inst lea ret-tn (make-fixup nil :code-object RETURN)))))

    (note-this-location vop :call-site)
    (inst jmp target)
    RETURN
    (note-this-location vop :unknown-return)
    (receive-unknown-values values-start nvals start count)
    (trace-table-entry trace-table-normal)))

;;;; local call with known values return

;;; Non-TR local call with known return locations. Known-value return
;;; works just like argument passing in local call.
;;;
;;; Note: we can't use normal load-tn allocation for the fixed args,
;;; since all registers may be tied up by the more operand. Instead,
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (known-call-local)
  (:args (fp)
         (nfp)
         (args :more t))
  (:temporary (:sc unsigned-reg) return-label)
  (:results (res :more t))
  (:move-args :local-call)
  (:save-p t)
  (:info save callee target)
  (:ignore args res save nfp #+nil callee)
  (:vop-var vop)
  (:generator 5
    (trace-table-entry trace-table-call-site)
    (move rbp-tn fp)

    (let ((ret-tn (callee-return-pc-tn callee)))

      #+nil
      (format t "*known-call-local ~S; tn-kind ~S; tn-save-tn ~S; its tn-kind ~S~%"
              ret-tn (sb!c::tn-kind ret-tn) (sb!c::tn-save-tn ret-tn)
              (sb!c::tn-kind (sb!c::tn-save-tn ret-tn)))

      ;; Is the return-pc on the stack or in a register?
      (sc-case ret-tn
        ((sap-stack)
         #+nil (format t "*known-call-local: ret-tn on stack; offset=~S~%"
                       (tn-offset ret-tn))
         ;; Stack
         (inst lea return-label (make-fixup nil :code-object RETURN))
         (storew return-label rbp-tn (- (1+ (tn-offset ret-tn)))))
        ((sap-reg)
         ;; Register
         (inst lea ret-tn (make-fixup nil :code-object RETURN)))))

    (note-this-location vop :call-site)
    (inst jmp target)
    RETURN
    (note-this-location vop :known-return)
    (trace-table-entry trace-table-normal)))

;;; Return from known values call. We receive the return locations as
;;; arguments to terminate their lifetimes in the returning function. We
;;; restore FP and CSP and jump to the Return-PC.
;;;
;;; We can assume we know exactly where old-fp and return-pc are because
;;; make-old-fp-save-location and make-return-pc-save-location always
;;; return the same place.
#+nil
(define-vop (known-return)
  (:args (old-fp)
         (return-pc :scs (any-reg immediate-stack) :target rpc)
         (vals :more t))
  (:move-args :known-return)
  (:info val-locs)
  (:temporary (:sc unsigned-reg :from (:argument 1)) rpc)
  (:ignore val-locs vals)
  (:vop-var vop)
  (:generator 6
    (trace-table-entry trace-table-fun-epilogue)
    ;; Save the return-pc in a register 'cause the frame-pointer is
    ;; going away. Note this not in the usual stack location so we
    ;; can't use RET
    (move rpc return-pc)
    ;; Restore the stack.
    (move rsp-tn rbp-tn)
    ;; Restore the old fp. We know OLD-FP is going to be in its stack
    ;; save slot, which is a different frame that than this one,
    ;; so we don't have to worry about having just cleared
    ;; most of the stack.
    (move rbp-tn old-fp)
    (inst jmp rpc)
    (trace-table-entry trace-table-normal)))

;;; From Douglas Crosher
;;; Return from known values call. We receive the return locations as
;;; arguments to terminate their lifetimes in the returning function. We
;;; restore FP and CSP and jump to the Return-PC.
;;;
;;; The old-fp may be either in a register or on the stack in its
;;; standard save locations - slot 0.
;;;
;;; The return-pc may be in a register or on the stack in any slot.
(define-vop (known-return)
  (:args (old-fp)
         (return-pc)
         (vals :more t))
  (:move-args :known-return)
  (:info val-locs)
  (:ignore val-locs vals)
  (:vop-var vop)
  (:generator 6
    (trace-table-entry trace-table-fun-epilogue)
    ;; return-pc may be either in a register or on the stack.
    (sc-case return-pc
      ((sap-reg)
       (sc-case old-fp
         ((control-stack)
          (cond ((zerop (tn-offset old-fp))
                 ;; Zot all of the stack except for the old-fp.
                 (inst lea rsp-tn (make-ea :qword :base rbp-tn
                                           :disp (- (* (1+ ocfp-save-offset)
                                                       n-word-bytes))))
                 ;; Restore the old fp from its save location on the stack,
                 ;; and zot the stack.
                 (inst pop rbp-tn))

                (t
                 (cerror "Continue anyway"
                         "VOP return-local doesn't work if old-fp (in slot ~
                          ~S) is not in slot 0"
                         (tn-offset old-fp)))))

         ((any-reg descriptor-reg)
          ;; Zot all the stack.
          (move rsp-tn rbp-tn)
          ;; Restore the old-fp.
          (move rbp-tn old-fp)))

       ;; Return; return-pc is in a register.
       (inst jmp return-pc))

      ((sap-stack)
       (inst lea rsp-tn
             (make-ea :qword :base rbp-tn
                      :disp (- (* (1+ (tn-offset return-pc)) n-word-bytes))))
       (move rbp-tn old-fp)
       (inst ret (* (tn-offset return-pc) n-word-bytes))))

    (trace-table-entry trace-table-normal)))

;;;; full call
;;;
;;; There is something of a cross-product effect with full calls.
;;; Different versions are used depending on whether we know the
;;; number of arguments or the name of the called function, and
;;; whether we want fixed values, unknown values, or a tail call.
;;;
;;; In full call, the arguments are passed creating a partial frame on
;;; the stack top and storing stack arguments into that frame. On
;;; entry to the callee, this partial frame is pointed to by FP.

;;; This macro helps in the definition of full call VOPs by avoiding
;;; code replication in defining the cross-product VOPs.
;;;
;;; NAME is the name of the VOP to define.
;;;
;;; NAMED is true if the first argument is an fdefinition object whose
;;; definition is to be called.
;;;
;;; RETURN is either :FIXED, :UNKNOWN or :TAIL:
;;; -- If :FIXED, then the call is for a fixed number of values, returned in
;;;    the standard passing locations (passed as result operands).
;;; -- If :UNKNOWN, then the result values are pushed on the stack, and the
;;;    result values are specified by the Start and Count as in the
;;;    unknown-values continuation representation.
;;; -- If :TAIL, then do a tail-recursive call. No values are returned.
;;;    The Old-Fp and Return-PC are passed as the second and third arguments.
;;;
;;; In non-tail calls, the pointer to the stack arguments is passed as
;;; the last fixed argument. If Variable is false, then the passing
;;; locations are passed as a more arg. Variable is true if there are
;;; a variable number of arguments passed on the stack. Variable
;;; cannot be specified with :TAIL return. TR variable argument call
;;; is implemented separately.
;;;
;;; In tail call with fixed arguments, the passing locations are
;;; passed as a more arg, but there is no new-FP, since the arguments
;;; have been set up in the current frame.
(macrolet ((define-full-call (name named return variable)
            (aver (not (and variable (eq return :tail))))
            `(define-vop (,name
                          ,@(when (eq return :unknown)
                              '(unknown-values-receiver)))
               (:args
               ,@(unless (eq return :tail)
                   '((new-fp :scs (any-reg) :to (:argument 1))))

               (fun :scs (descriptor-reg control-stack)
                    :target rax :to (:argument 0))

               ,@(when (eq return :tail)
                   '((old-fp)
                     (return-pc)))

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

               ,@(when (eq return :fixed)