call.lisp

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

  (: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)
  #!-gengc (:temporary (:scs (interior-reg)) lip)
  #!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:eval 1)) ra)
  (: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 addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
              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 ocfp cfp-tn)
    ;; ADDQ only accepts immediates of type (UNSIGNED-BYTE 8).  Here,
    ;; instead of adding (* NVALS N-WORD-BYTES), we use NARGS that
    ;; we've carefully set up, but protect ourselves by averring that
    ;; FIXNUMIZEation and multiplication by N-WORD-BYTES is the same.
    (aver (= (* nvals n-word-bytes) (fixnumize nvals)))
    (inst addq val-ptr nargs 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 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)
         #!-gengc (lra-arg :scs (descriptor-reg) :target lra)
         #!+gengc (return-pc :scs (any-reg) :target ra)
         (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)
  #!-gengc
  (:temporary (:sc descriptor-reg :offset lra-offset :from (:argument 1)) lra)
  #!+gengc
  (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
  (: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 (non-descriptor-reg)) temp)
  #!-gengc (:temporary (:scs (interior-reg)) lip)
  #!+gengc (:temporary (:scs (any-reg) :from (:argument 0)) 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 addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
                nsp-tn)))

      ;; Check for the single case.
      (inst li (fixnumize 1) a0)
      (inst cmpeq nvals-arg a0 temp)
      (inst ldl a0 0 vals-arg)
      (inst beq temp not-single)

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

      ;; Nope, not the single case.
      (emit-label not-single)
      (move ocfp-arg ocfp)
      (move lra-arg lra)
      (move vals-arg vals)
      (move nvals-arg nvals)
      (inst li (make-fixup 'return-multiple :assembly-routine) temp)
      (inst jmp zero-tn temp))
    (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 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 nl4-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 csp-tn result))
      ;; Allocate the space on the stack.
      (cond ((zerop fixed)
             (inst addq csp-tn nargs-tn csp-tn)
             (inst beq nargs-tn done))
            (t
             (inst subq nargs-tn (fixnumize fixed) count)
             (inst ble count done)
             (inst addq csp-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 &MORE args.
        (inst subq nargs-tn (fixnumize register-arg-count) count))
      ;; Initialize dst to be end of stack.
      (move csp-tn dst)
      ;; Everything of interest in registers.
      (inst ble count do-regs)
      ;; Initialize SRC to be end of args.
      (inst addq cfp-tn nargs-tn src)

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

      (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 subq nargs-tn (fixnumize (1+ fixed)) count)
        (do ((i fixed (1+ i)))
            ((>= i register-arg-count))
          ;; Store it relative to the pointer saved at the start.
          (storew (nth i *register-arg-tns*) result (- i fixed))
          ;; Is this the last one?
          (inst beq count done)
          ;; Decrement count.
          (inst subq count (fixnumize 1) count)))
      (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)
  (: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-arg context)
      (move count-arg count)
      ;; Check to see if there are any arguments.
      (move null-tn result)
      (inst beq count done)

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

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

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

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

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

        ;; 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 subq supplied (fixnumize fixed) count)
    (inst subq csp-tn count context)))

;;; Signal wrong argument count error if NARGS isn't equal 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))
            (t
             (inst subq nargs (fixnumize count) temp)
             (inst bne temp err-lab))))))

;;; 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)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
    ;; Stub! See the PPC backend for an example.
    (note-this-location vop :step-before-vop)))