call.lisp

开源跨平台Lisp编译器

      (when cur-nfp
        (inst addi nsp-tn cur-nfp
              (- (bytes-needed-for-non-descriptor-stack-frame)
                 number-stack-displacement))))
    (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 lip :offset 2))
          (t
           ;; Establish the values pointer and values count.
           (move val-ptr cfp-tn)
           (inst lr nargs (fixnumize nvals))
           ;; restore the frame pointer and clear as much of the control
           ;; stack as possible.
           (move cfp-tn old-fp)
           (inst addi 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) 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
   (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 (interior-reg)) lip)
  (:temporary (:sc any-reg) 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 addi nsp-tn cur-nfp
                (- (bytes-needed-for-non-descriptor-stack-frame)
                   number-stack-displacement))))
      ;; Check for the single case.
      (inst cmpwi nvals-arg (fixnumize 1))
      (inst lwz a0 vals-arg 0)
      (inst bne not-single)
      ;; Return with one value.
      (move csp-tn cfp-tn)
      (move cfp-tn old-fp-arg)
      (lisp-return lra-arg lip :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 lr temp (make-fixup 'return-multiple :assembly-routine))
      (inst mtlr temp)
      (inst blr))
    (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 cmpwi nargs-tn 0)
             (inst add csp-tn csp-tn nargs-tn)
             (inst beq done))
            (t
             (inst addic. count nargs-tn (- (fixnumize fixed)))
             (inst ble done)
             (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 addic. count nargs-tn (- (fixnumize register-arg-count)))
        ;; Everything of interest is in registers.
        (inst ble 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 lwzu temp src (- n-word-bytes))
      (inst addic. count count (- (fixnumize 1)))
      (inst stwu temp dst (- n-word-bytes))
      (inst bgt loop)

      (emit-label do-regs)
      (when (< fixed register-arg-count)
        ;; Now we have to deposit any more args that showed up in registers.
        (inst subic. count nargs-tn (fixnumize fixed))
        (do ((i fixed (1+ i)))
            ((>= i register-arg-count))
          ;; Don't deposit any more than there are.
          (inst beq done)
          (inst subic. count 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 consecutively 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)
  (:temporary (:sc non-descriptor-reg :offset nl3-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)))
      (move context context-arg)
      (move count count-arg)
      ;; Check to see if there are any arguments.
      (inst cmpwi count 0)
      (move result null-tn)
      (inst beq done)

    ;; We need to do this atomically.
    (pseudo-atomic (pa-flag)
      ;; Allocate a cons (2 words) for each item.
      (if dx-p
          (progn
            (align-csp temp)
            (inst clrrwi result csp-tn n-lowtag-bits)
            (inst ori result result list-pointer-lowtag)
            (move dst result)
            (inst slwi temp count 1)
            (inst add csp-tn csp-tn temp))
          (progn
            (inst slwi temp count 1)
            (allocation result temp list-pointer-lowtag
                        :temp-tn dst
                        :flag-tn pa-flag)
            (move dst result)))
      (inst b enter)

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

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

      ;; Dec count, and if != zero, go back for more.
      (inst addic. count count (- (fixnumize 1)))
      ;; Store the value into the car of the current cons (in the delay
      ;; slot).
      (storew temp dst 0 list-pointer-lowtag)
      (inst bgt 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 subi count supplied (fixnumize fixed))
    (inst sub context csp-tn 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
   (inst twi :ne nargs (fixnumize count))))

;;; 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))

(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*
    (loadw stepping
           null-tn
           (+ symbol-value-slot
              (truncate (static-symbol-offset 'sb!impl::*stepping*)
                        n-word-bytes))
           other-pointer-lowtag)
    (inst cmpw stepping null-tn)
    ;; If it's not null, trap.
    (inst beq DONE)
    ;; CONTEXT-PC will be pointing here when the interrupt is handled,
    ;; not after the UNIMP.
    (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 unimp single-step-before-trap)
    DONE))