call.lisp

来自「开源跨平台Lisp编译器」· LISP 代码 · 共 1,240 行 · 第 1/4 页

    (cond ((= nvals 1)
           ;; Clear the control stack, and restore the frame pointer.
           (move csp-tn cfp-tn)
           (move cfp-tn old-fp)
           ;; Out of here.
           (lisp-return return-pc :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 old-fp)
           (inst add 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)))
    (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 1)) temp)

  (: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 add nsp-tn cur-nfp
                (- (bytes-needed-for-non-descriptor-stack-frame)
                   number-stack-displacement))))

      ;; Check for the single case.
      (inst cmp nvals-arg (fixnumize 1))
      (inst b :ne not-single)
      (inst ld a0 vals-arg)

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

      ;; Nope, not the single case.
      (emit-label not-single)
      (move old-fp old-fp-arg)
      (move lra lra-arg)
      (move vals vals-arg)
      (move nvals nvals-arg)
      (inst ji temp (make-fixup 'return-multiple :assembly-routine))
      (inst nop))
    (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 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 cmp nargs-tn)
             (inst b :eq done)
             (inst add csp-tn csp-tn nargs-tn))
            (t
             (inst subcc count nargs-tn (fixnumize fixed))
             (inst b :le done)
             (inst nop)
             (inst add 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 subcc count nargs-tn (fixnumize register-arg-count))
        ;; Everything of interest in registers.
        (inst b :le do-regs))
      ;; Initialize dst to be end of stack.
      (move dst csp-tn)
      ;; Initialize src to be end of args.
      (inst add src cfp-tn nargs-tn)

      (emit-label loop)
      ;; *--dst = *--src, --count
      (inst add src src (- n-word-bytes))
      (inst subcc count count (fixnumize 1))
      (loadw temp src)
      (inst add dst dst (- n-word-bytes))
      (inst b :gt 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.
        (inst subcc count nargs-tn (fixnumize fixed))
        (do ((i fixed (1+ i)))
            ((>= i register-arg-count))
          ;; Don't deposit any more than there are.
          (inst b :eq done)
          (inst subcc count (fixnumize 1))
          ;; Store it relative to the pointer saved at the start.
          (storew (nth i *register-arg-tns*) result (- i fixed))))
      (emit-label 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-vop (more-arg word-index-ref)
  (:variant 0 0)
  (:translate %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)
  (: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 cmp count)
      (inst b :eq done)
      (move result null-tn)

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

        ;; Compute the next cons and store it in the current one.
        (emit-label loop)
        (inst add dst dst (* 2 n-word-bytes))
        (storew dst dst -1 list-pointer-lowtag)

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

        ;; Dec count, and if != zero, go back for more.
        (inst subcc count (fixnumize 1))
        (inst b :gt loop)

        ;; Store the value into the car of the current cons (in the 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 sub count supplied (fixnumize fixed))
    (inst sub 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))
  (:info count)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (let ((err-lab
           (generate-error-code vop invalid-arg-count-error nargs)))
      (inst cmp nargs (fixnumize count))
      (if (member :sparc-v9 *backend-subfeatures*)
          ;; Assume we don't take the branch
          (inst b :ne err-lab :pn)
          (inst b :ne err-lab))
      (inst nop))))

;;; Signal various errors.
(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
    (load-symbol-value stepping sb!impl::*stepping*)
    (inst cmp stepping null-tn)
    (inst b :eq DONE)
    (inst nop)
    (note-this-location vop :step-before-vop)
    (inst unimp single-step-before-trap)
    DONE))