call.lisp

开源跨平台Lisp编译器

           (do-next-filler))

         ,@(ecase return
             (:fixed
              '((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
              '((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)))
       (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))


;;; 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)
         (old-fp-arg :scs (any-reg) :target old-fp)
         (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)) old-fp)
  (:temporary (:sc any-reg :offset lra-offset :from (:argument 3)) lra)
  (:temporary (:scs (any-reg) :from (:argument 3)) tmp)

  (: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 old-fp-arg old-fp)
    (move lra-arg lra)

    ;; Clear the number stack if anything is there.
    (let ((cur-nfp (current-nfp-tn vop)))
      (when cur-nfp
        (inst move cur-nfp nsp-tn)))

    ;; And jump to the assembly-routine that does the bliting.
    (let ((fixup (make-fixup 'tail-call-variable :assembly-routine)))
      (inst ldil fixup tmp)
      (inst be fixup lisp-heap-space tmp :nullify t))))


;;;; Unknown values return:

;;; Return a single value using the unknown-values convention.
;;;
(define-vop (return-single)
  (:args (old-fp :scs (any-reg))
         (return-pc :scs (descriptor-reg))
         (value))
  (:ignore value)
  (: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 move cur-nfp nsp-tn)))
    ;; Clear the control stack, and restore the frame pointer.
    (move cfp-tn csp-tn)
    (move old-fp cfp-tn)
    ;; Out of here.
    (lisp-return return-pc :offset 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
   (old-fp :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)
  (: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 move cur-nfp nsp-tn)))
    ;; Establish the values pointer and values count.
    (move cfp-tn val-ptr)
    (inst li (fixnumize nvals) nargs)
    ;; restore the frame pointer and clear as much of the control
    ;; stack as possible.
    (move old-fp cfp-tn)
    (inst addi (* nvals n-word-bytes) val-ptr csp-tn)
    ;; pre-default any argument register that need it.
    (when (< nvals register-arg-count)
      (dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
        (move null-tn reg)))
    ;; And away we go.
    (lisp-return 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.
;;;
(define-vop (return-multiple)
  (:args
   (old-fp-arg :scs (any-reg) :to (:eval 1))
   (lra-arg :scs (descriptor-reg) :to (:eval 1))
   (vals-arg :scs (any-reg) :target vals)
   (nvals-arg :scs (any-reg) :target nvals))

  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) old-fp)
  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
  (:temporary (:sc any-reg :offset nl0-offset :from (:argument 2)) vals)
  (:temporary (:sc any-reg :offset nargs-offset :from (:argument 3)) nvals)
  (:temporary (:sc descriptor-reg :offset a0-offset) a0)
  (:temporary (:scs (any-reg) :from (:eval 0)) tmp)

  (:vop-var vop)
  (:node-var node)

  (:generator 13
    (trace-table-entry trace-table-fun-epilogue)
    ;; Clear the number stack.
    (let ((cur-nfp (current-nfp-tn vop)))
      (when cur-nfp
        (inst move cur-nfp nsp-tn)))

    (unless (policy node (> space speed))
      ;; Check for the single case.
      (inst comib :<> (fixnumize 1) nvals-arg not-single)
      (loadw a0 vals-arg)

      ;; Return with one value.
      (move cfp-tn csp-tn)
      (move old-fp-arg cfp-tn)
      (lisp-return lra-arg :offset 1))

    ;; Nope, not the single case.
    NOT-SINGLE
    (move old-fp-arg old-fp)
    (move lra-arg lra)
    (move vals-arg vals)
    (move nvals-arg nvals)
    (let ((fixup (make-fixup 'return-multiple :assembly-routine)))
      (inst ldil fixup tmp)
      (inst be fixup lisp-heap-space tmp :nullify t))
    (trace-table-entry trace-table-normal)))



;;;; XEP hackery:

;;; We don't need to do anything special for regular functions.
;;;
(define-vop (setup-environment)
  (:info label)
  (:ignore label)
  (:generator 0
    ;; Don't bother doing anything.
    ))

;;; Get the lexical environment from it's passing location.
;;;
(define-vop (setup-closure-environment)
  (:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
               :to (:result 0))
              lexenv)
  (:results (closure :scs (descriptor-reg)))
  (:info label)
  (:ignore label)
  (:generator 6
    ;; Get result.
    (move lexenv closure)))

;;; Copy a more arg from the argument area to the end of the current frame.
;;; Fixed is the number of non-more arguments.
;;;
(define-vop (copy-more-arg)
  (:temporary (:sc any-reg :offset nl0-offset) result)
  (:temporary (:sc any-reg :offset nl1-offset) count)
  (:temporary (:sc any-reg :offset nl2-offset) src)
  (:temporary (:sc any-reg :offset nl3-offset) dst)
  (:temporary (:sc descriptor-reg :offset l0-offset) temp)
  (:info fixed)
  (:generator 20
    ;; Figure out how many things we are going to copy.
    (unless (zerop fixed)
      (inst addi (- (fixnumize fixed)) nargs-tn count))

    ;; Blow out of here if is nothing to copy.
    (inst comb :<= (if (zerop fixed) nargs-tn count) zero-tn done :nullify t)

    (when (< fixed register-arg-count)
      ;; Save a pointer to the results so we can fill in register args.
      ;; We don't need this if there are more fixed args than reg args.
      (move csp-tn result))

    ;; Allocate the space on the stack.
    (inst add csp-tn (if (zerop fixed) nargs-tn count) csp-tn)

    (when (< fixed register-arg-count)
      ;; We must stop when we run out of stack args, not when we run out of
      ;; args in general.
      (inst addi (fixnumize (- register-arg-count)) nargs-tn count)
      ;; Everything of interest in registers.
      (inst comb :<= count zero-tn do-regs))
    ;; Initialize dst to be end of stack.
    (move csp-tn dst)

    ;; Initialize src to be end of args.
    (inst add cfp-tn nargs-tn src)

    LOOP
    ;; *--dst = *--src, --count
    (inst ldwm (- n-word-bytes) src temp)
    (inst addib :> (fixnumize -1) count loop)
    (inst stwm temp (- n-word-bytes) dst)

    DO-REGS
    (when (< fixed register-arg-count)
      ;; Now we have to deposit any more args that showed up in registers.
      ;; We know there is at least one more arg, otherwise we would have
      ;; branched to done up at the top.
      (inst addi (fixnumize (- fixed)) nargs-tn count)
      (do ((i fixed (1+ i)))
          ((>= i register-arg-count))
        ;; Is this the last one?
        (inst addib :<= (fixnumize -1) count done)
        ;; Store it relative to the pointer saved at the start.
        (storew (nth i register-arg-tns) result (- i fixed))))
    DONE))

;;; More args are stored consequtively on the stack, starting immediately at
;;; the context pointer.  The context pointer is not typed, so the lowtag is 0.
;;;
(define-full-reffer more-arg * 0 0 (descriptor-reg any-reg) * %more-arg)


;;; Turn more arg (context, count) into a list.
;;;
(define-vop (listify-rest-args)
  (:args (context-arg :target context :scs (descriptor-reg))
         (count-arg :target count :scs (any-reg)))
  (:arg-types * tagged-num)
  (:temporary (:scs (any-reg) :from (:argument 0)) context)
  (:temporary (:scs (any-reg) :from (:argument 1)) count)
  (:temporary (:scs (descriptor-reg) :from :eval) temp)
  (:temporary (:scs (non-descriptor-reg) :from :eval) dst)
  (:results (result :scs (descriptor-reg)))
  (:translate %listify-rest-args)
  (:policy :safe)
  (:generator 20
    (move context-arg context)
    (move count-arg count)
    ;; Check to see if there are any arguments.
    (inst comb := count zero-tn done)
    (move null-tn result)

    ;; We need to do this atomically.
    (pseudo-atomic ()
      (assemble ()
        ;; Allocate a cons (2 words) for each item.
        (inst move alloc-tn result)
        (inst dep list-pointer-lowtag 31 3 result)
        (move result dst)
        (inst sll count 1 temp)
        (inst add alloc-tn temp alloc-tn)

        LOOP
        ;; Grab one value and stash it in the car of this cons.
        (inst ldwm n-word-bytes context temp)
        (storew temp dst 0 list-pointer-lowtag)

        ;; Dec count, and if != zero, go back for more.
        (inst addi (* 2 n-word-bytes) dst dst)
        (inst addib :> (fixnumize -1) count loop :nullify t)
        (storew dst dst -1 list-pointer-lowtag)

        ;; NIL out the last cons.
        (storew null-tn dst -1 list-pointer-lowtag)
        ;; Clear out dst, because it points past the last cons.
        (move null-tn dst)))
    DONE))

;;; Return the location and size of the more arg glob created by Copy-More-Arg.
;;; Supplied is the total number of arguments supplied (originally passed in
;;; NARGS.)  Fixed is the number of non-rest arguments.
;;;
;;; We must duplicate some of the work done by Copy-More-Arg, since at that
;;; time the environment is in a pretty brain-damaged state, preventing this
;;; info from being returned as values.  What we do is compute
;;; supplied - fixed, and return a pointer that many words below the current
;;; stack top.
;;;

;;; WTF? FIXME -- CSR
;;;(setf (info function source-transform 'c::%more-arg-context) nil)
;;;
(define-vop (more-arg-context)
  (:policy :fast-safe)
  (:translate sb!c::%more-arg-context)
  (:args (supplied :scs (any-reg)))
  (:arg-types tagged-num (:constant fixnum))
  (:info fixed)
  (:results (context :scs (descriptor-reg))
            (count :scs (any-reg)))
  (:result-types t tagged-num)
  (:note "more-arg-context")
  (:generator 5
    (inst addi (fixnumize (- fixed)) supplied count)
    (inst sub csp-tn count context)))


;;; Signal wrong argument count error if Nargs isn't = to Count.
;;;
(define-vop (verify-arg-count)
  (:policy :fast-safe)
  (:translate sb!c::%verify-arg-count)
  (:args (nargs :scs (any-reg)))
  (:arg-types positive-fixnum (:constant t))
  (:info count)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (let ((err-lab
           (generate-error-code vop invalid-arg-count-error nargs)))
      (cond ((zerop count)
             (inst bc :<> nil nargs zero-tn err-lab))
            (t
             (inst bci :<> nil (fixnumize count) nargs err-lab))))))

;;; Signal an argument count error.
;;;
(macrolet ((frob (name error translate &rest args)
             `(define-vop (,name)
                ,@(when translate
                    `((:policy :fast-safe)
                      (:translate ,translate)))
                (:args ,@(mapcar #'(lambda (arg)
                                     `(,arg :scs (any-reg descriptor-reg)))
                                 args))
                (:vop-var vop)
                (:save-p :compute-only)
                (:generator 1000
                  (error-call vop ,error ,@args)))))
  (frob arg-count-error invalid-arg-count-error
    sb!c::%arg-count-error nargs)
  (frob type-check-error object-not-type-error sb!c::%type-check-error
    object type)
  (frob layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
    object layout)
  (frob odd-key-args-error odd-key-args-error
    sb!c::%odd-key-args-error)
  (frob unknown-key-arg-error unknown-key-arg-error
    sb!c::%unknown-key-arg-error key)
  (frob nil-fun-returned-error nil-fun-returned-error nil fun))