call.lisp

开源跨平台Lisp编译器

      (when cur-nfp
        (inst addu nsp-tn cur-nfp
              (bytes-needed-for-non-descriptor-stack-frame))))
    (cond ((= nvals 1)
           ;; 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))
          (t
           ;; Establish the values pointer and values count.
           (move val-ptr cfp-tn)
           (inst li nargs (fixnumize nvals))
           ;; restore the frame pointer and clear as much of the control
           ;; stack as possible.
           (move cfp-tn ocfp)
           (inst addu csp-tn val-ptr (* nvals n-word-bytes))
           ;; 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 reg null-tn)))
           ;; And away we go.
           (lisp-return return-pc lip)))
    (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 (ocfp-arg :scs (any-reg) :target ocfp)
         (lra-arg :scs (descriptor-reg) :target lra)
         (vals-arg :scs (any-reg) :target vals)
         (nvals-arg :scs (any-reg) :target nvals))

  (:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
  (: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 (interior-reg)) lip)

  (:vop-var vop)

  (:generator 13
    (trace-table-entry trace-table-fun-epilogue)
    (let ((not-single (gen-label)))
      ;; Clear the number stack.
      (let ((cur-nfp (current-nfp-tn vop)))
        (when cur-nfp
          (inst addu nsp-tn cur-nfp
                (bytes-needed-for-non-descriptor-stack-frame))))

      ;; Check for the single case.
      (inst li a0 (fixnumize 1))
      (inst bne nvals-arg a0 not-single)
      (inst lw a0 vals-arg)

      ;; Return with one value.
      (move csp-tn cfp-tn)
      (move cfp-tn ocfp-arg)
      (lisp-return lra-arg lip :offset 2)

      ;; Nope, not the single case.
      (emit-label not-single)
      (move ocfp ocfp-arg)
      (move lra lra-arg)
      (move vals vals-arg)

      (inst j (make-fixup 'return-multiple :assembly-routine))
      (move nvals nvals-arg 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 its 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 closure lexenv)))

;;; 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
    (let ((loop (gen-label))
          (do-regs (gen-label))
          (done (gen-label)))
      (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 result csp-tn))
      ;; Allocate the space on the stack.
      (cond ((zerop fixed)
             (inst beq nargs-tn done)
             (inst addu csp-tn csp-tn nargs-tn))
            (t
             (inst addu count nargs-tn (fixnumize (- fixed)))
             (inst blez count done)
             (inst nop)
             (inst addu csp-tn csp-tn count)))
      (when (< fixed register-arg-count)
        ;; We must stop when we run out of stack args, not when we run out of
        ;; more args.
        (inst addu count nargs-tn (fixnumize (- register-arg-count))))
      ;; Everything of interest in registers.
      (inst blez count do-regs)
      ;; Initialize dst to be end of stack.
      (move dst csp-tn t)
      ;; Initialize src to be end of args.
      (inst addu src cfp-tn nargs-tn)

      (emit-label loop)
      ;; *--dst = *--src, --count
      (inst addu src src (- n-word-bytes))
      (inst addu count count (fixnumize -1))
      (loadw temp src)
      (inst addu dst dst (- n-word-bytes))
      (inst bgtz count loop)
      (storew temp dst)

      (emit-label 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 subu count nargs-tn (fixnumize (1+ fixed)))
        (do ((i fixed (1+ i)))
            ((>= i register-arg-count))
          ;; Is this the last one?
          (inst beq count done)
          ;; Store it relative to the pointer saved at the start.
          (storew (nth i *register-arg-tns*) result (- i fixed))
          ;; Decrement count.
          (inst subu count (fixnumize 1))))
      (emit-label done))))


;;; More args are stored consecutively 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 dst)
  (:temporary (:sc non-descriptor-reg :offset nl4-offset) pa-flag)
  (:results (result :scs (descriptor-reg)))
  (:translate %listify-rest-args)
  (:policy :safe)
  (:node-var node)
  (:generator 20
    (let* ((enter (gen-label))
           (loop (gen-label))
           (done (gen-label))
           (dx-p (node-stack-allocate-p node))
           (alloc-area-tn (if dx-p csp-tn alloc-tn)))
      (move context context-arg)
      (move count count-arg)
      ;; Check to see if there are any arguments.
      (inst beq count done)
      (move result null-tn t)

      ;; We need to do this atomically.
      (pseudo-atomic (pa-flag)
        (when dx-p
          (align-csp temp))
        ;; Allocate a cons (2 words) for each item.
        (inst srl result alloc-area-tn n-lowtag-bits)
        (inst sll result n-lowtag-bits)
        (inst or result list-pointer-lowtag)
        (move dst result)
        (inst sll temp count 1)
        (inst b enter)
        (inst addu alloc-area-tn temp)

        ;; Store the current cons in the cdr of the previous cons.
        (emit-label loop)
        (inst addu dst dst (* 2 n-word-bytes))
        (storew dst dst -1 list-pointer-lowtag)

        (emit-label enter)
        ;; Grab one value.
        (loadw temp context)
        (inst addu context n-word-bytes)

        ;; Dec count, and if != zero, go back for more.
        (inst addu count count (fixnumize -1))
        (inst bne count loop)

        ;; Store the value in the car (in delay slot)
        (storew temp dst 0 list-pointer-lowtag)

        ;; NIL out the last cons.
        (storew null-tn dst 1 list-pointer-lowtag))
      (emit-label 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.
;;;
(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 addu count supplied (fixnumize (- fixed)))
    (inst subu context csp-tn count)))


;;; 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))
  (:temporary (:scs (any-reg) :type fixnum) temp)
  (: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 bne nargs err-lab)
             (inst nop))
            (t
             (inst li temp (fixnumize count))
             (inst bne nargs temp err-lab)
             (inst nop))))))

;;; Various other error signalers.
;;;
(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))

;;; Single-stepping

(define-vop (step-instrument-before-vop)
  (:temporary (:scs (descriptor-reg)) stepping)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    ;; 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 DONE)
    (inst nop)
    ;; CONTEXT-PC will be pointing here when the interrupt is handled,
    ;; not after the BREAK.
    (note-this-location vop :step-before-vop)
    ;; CALLEE-REGISTER-OFFSET isn't needed for before-traps, so we
    ;; can just use a bare SINGLE-STEP-BEFORE-TRAP as the code.
    (inst break 0 single-step-before-trap)
    DONE))