call.lisp

开源跨平台Lisp编译器

;;; The assembly routine takes the following args:
;;;  RAX -- the return-pc to finally jump to.
;;;  RBX -- pointer to where to put the values.
;;;  RCX -- number of values to find there.
;;;  RSI -- pointer to where to find the values.
(define-vop (return-multiple)
  (:args (old-fp :to (:eval 1) :target old-fp-temp)
         (return-pc :target rax)
         (vals :scs (any-reg) :target rsi)
         (nvals :scs (any-reg) :target rcx))

  (:temporary (:sc unsigned-reg :offset rax-offset :from (:argument 1)) rax)
  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 2)) rsi)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 3)) rcx)
  (:temporary (:sc unsigned-reg :offset rbx-offset :from (:eval 0)) rbx)
  (:temporary (:sc unsigned-reg) return-asm)
  (:temporary (:sc descriptor-reg :offset (first *register-arg-offsets*)
                   :from (:eval 0)) a0)
  (:temporary (:sc unsigned-reg :from (:eval 1)) old-fp-temp)
  (:node-var node)

  (:generator 13
    (trace-table-entry trace-table-fun-epilogue)
    ;; Load the return-pc.
    (move rax return-pc)
    (unless (policy node (> space speed))
      ;; Check for the single case.
      (let ((not-single (gen-label)))
        (inst cmp nvals (fixnumize 1))
        (inst jmp :ne not-single)

        ;; Return with one value.
        (loadw a0 vals -1)
        ;; Clear the stack. We load old-fp into a register before clearing
        ;; the stack.
        (move old-fp-temp old-fp)
        (move rsp-tn rbp-tn)
        (move rbp-tn old-fp-temp)
        ;; clear the multiple-value return flag
        (inst clc)
        ;; Out of here.
        (inst jmp rax)

        ;; Nope, not the single case. Jump to the assembly routine.
        (emit-label not-single)))
    (move rsi vals)
    (move rcx nvals)
    (move rbx rbp-tn)
    (move rbp-tn old-fp)
    (inst lea return-asm
          (make-ea :qword :disp (make-fixup 'return-multiple
                                            :assembly-routine)))
    (inst jmp return-asm)
    (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.
    nil))

;;; Get the lexical environment from its passing location.
(define-vop (setup-closure-environment)
  (:results (closure :scs (descriptor-reg)))
  (:info label)
  (:ignore label)
  (:generator 6
    ;; Get result.
    (move closure rax-tn)))

;;; 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 r8-offset) copy-index)
  (:temporary (:sc any-reg :offset r9-offset) source)
  (:temporary (:sc descriptor-reg :offset r10-offset) temp)
  (:info fixed)
  (:generator 20
    ;; Avoid the copy if there are no more args.
    (cond ((zerop fixed)
           (inst jrcxz JUST-ALLOC-FRAME))
          (t
           (inst cmp rcx-tn (fixnumize fixed))
           (inst jmp :be JUST-ALLOC-FRAME)))

    ;; Allocate the space on the stack.
    ;; stack = rbp - (max 3 frame-size) - (nargs - fixed)
    (inst lea rbx-tn
          (make-ea :qword :base rbp-tn
                   :disp (- (fixnumize fixed)
                            (* n-word-bytes
                               (max 3 (sb-allocated-size 'stack))))))
    (inst sub rbx-tn rcx-tn)  ; Got the new stack in rbx
    (inst mov rsp-tn rbx-tn)

    ;; Now: nargs>=1 && nargs>fixed

    ;; Save the original count of args.
    (inst mov rbx-tn rcx-tn)

    (cond ((< fixed register-arg-count)
           ;; We must stop when we run out of stack args, not when we
           ;; run out of more args.
           ;; Number to copy = nargs-3
           (inst sub rcx-tn (fixnumize register-arg-count))
           ;; Everything of interest in registers.
           (inst jmp :be DO-REGS))
          (t
           ;; Number to copy = nargs-fixed
           (inst sub rcx-tn (fixnumize fixed))))

    ;; Initialize R8 to be the end of args.
    (inst mov source rbp-tn)
    (inst sub source rbx-tn)

    ;; We need to copy from downwards up to avoid overwriting some of
    ;; the yet uncopied args. So we need to use R9 as the copy index
    ;; and RCX as the loop counter, rather than using RCX for both.
    (zeroize copy-index)

    ;; We used to use REP MOVS here, but on modern x86 it performs
    ;; much worse than an explicit loop for small blocks.
    COPY-LOOP
    (inst mov temp (make-ea :qword :base source :index copy-index))
    (inst mov (make-ea :qword :base rsp-tn :index copy-index) temp)
    (inst add copy-index n-word-bytes)
    (inst sub rcx-tn n-word-bytes)
    (inst jmp :nz COPY-LOOP)

    DO-REGS

    ;; Restore RCX
    (inst mov rcx-tn rbx-tn)

    ;; Here: nargs>=1 && nargs>fixed
    (when (< fixed register-arg-count)
      ;; Now we have to deposit any more args that showed up in
      ;; registers.
      (do ((i fixed))
          ( nil )
        ;; Store it relative to rbp
        (inst mov (make-ea :qword :base rbp-tn
                           :disp (- (* n-word-bytes
                                       (+ 1 (- i fixed)
                                          (max 3 (sb-allocated-size 'stack))))))
              (nth i *register-arg-tns*))

        (incf i)
        (when (>= i register-arg-count)
          (return))

        ;; Don't deposit any more than there are.
        (if (zerop i)
            (inst test rcx-tn rcx-tn)
            (inst cmp rcx-tn (fixnumize i)))
        (inst jmp :eq DONE)))

    (inst jmp DONE)

    JUST-ALLOC-FRAME
    (inst lea rsp-tn
          (make-ea :qword :base rbp-tn
                   :disp (- (* n-word-bytes
                               (max 3 (sb-allocated-size 'stack))))))

    DONE))

(define-vop (more-kw-arg)
  (:translate sb!c::%more-kw-arg)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg) :to (:result 1))
         (index :scs (any-reg) :to (:result 1) :target keyword))
  (:arg-types * tagged-num)
  (:results (value :scs (descriptor-reg any-reg))
            (keyword :scs (descriptor-reg any-reg)))
  (:result-types * *)
  (:generator 4
     (inst mov value (make-ea :qword :base object :index index))
     (inst mov keyword (make-ea :qword :base object :index index
                                :disp n-word-bytes))))

(define-vop (more-arg)
    (:translate sb!c::%more-arg)
  (:policy :fast-safe)
  (:args (object :scs (descriptor-reg) :to (:result 1))
         (index :scs (any-reg) :to (:result 1) :target value))
  (:arg-types * tagged-num)
  (:results (value :scs (descriptor-reg any-reg)))
  (:result-types *)
  (:generator 4
    (move value index)
    (inst neg value)
    (inst mov value (make-ea :qword :base object :index value))))

;;; Turn more arg (context, count) into a list.
(define-vop (listify-rest-args)
  (:translate %listify-rest-args)
  (:policy :safe)
  (:args (context :scs (descriptor-reg) :target src)
         (count :scs (any-reg) :target rcx))
  (:arg-types * tagged-num)
  (:temporary (:sc unsigned-reg :offset rsi-offset :from (:argument 0)) src)
  (:temporary (:sc unsigned-reg :offset rcx-offset :from (:argument 1)) rcx)
  (:temporary (:sc unsigned-reg :offset rax-offset) rax)
  (:temporary (:sc unsigned-reg) dst)
  (:results (result :scs (descriptor-reg)))
  (:node-var node)
  (:generator 20
    (let ((enter (gen-label))
          (loop (gen-label))
          (done (gen-label))
          (stack-allocate-p (node-stack-allocate-p node)))
      (move src context)
      (move rcx count)
      ;; Check to see whether there are no args, and just return NIL if so.
      (inst mov result nil-value)
      (inst jrcxz done)
      (inst lea dst (make-ea :qword :base rcx :index rcx))
      (maybe-pseudo-atomic stack-allocate-p
       (allocation dst dst node stack-allocate-p list-pointer-lowtag)
       (inst shr rcx (1- n-lowtag-bits))
       ;; Set decrement mode (successive args at lower addresses)
       (inst std)
       ;; Set up the result.
       (move result dst)
       ;; Jump into the middle of the loop, 'cause that's where we want
       ;; to start.
       (inst jmp enter)
       (emit-label loop)
       ;; Compute a pointer to the next cons.
       (inst add dst (* cons-size n-word-bytes))
       ;; Store a pointer to this cons in the CDR of the previous cons.
       (storew dst dst -1 list-pointer-lowtag)
       (emit-label enter)
       ;; Grab one value and stash it in the car of this cons.
       (inst lods rax)
       (storew rax dst 0 list-pointer-lowtag)
       ;; Go back for more.
       (inst sub rcx 1)
       (inst jmp :nz loop)
       ;; NIL out the last cons.
       (storew nil-value dst 1 list-pointer-lowtag)
       (inst cld))
      (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 RCX). 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) :target count))
  (:arg-types positive-fixnum (:constant fixnum))
  (:info fixed)
  (:results (context :scs (descriptor-reg))
            (count :scs (any-reg)))
  (:result-types t tagged-num)
  (:note "more-arg-context")
  (:generator 5
    (move count supplied)
    ;; SP at this point points at the last arg pushed.
    ;; Point to the first more-arg, not above it.
    (inst lea context (make-ea :qword :base rsp-tn
                               :index count :scale 1
                               :disp (- (+ (fixnumize fixed) n-word-bytes))))
    (unless (zerop fixed)
      (inst sub count (fixnumize fixed)))))

;;; 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))
  (:info count)
  (:vop-var vop)
  (:save-p :compute-only)
  (:generator 3
    (let ((err-lab
           (generate-error-code vop 'invalid-arg-count-error nargs)))
      (if (zerop count)
          (inst test nargs nargs)  ; smaller instruction
        (inst cmp nargs (fixnumize count)))
      (inst jmp :ne err-lab))))

;;; Various other error signallers.
(macrolet ((def (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)))))
  (def arg-count-error invalid-arg-count-error
    sb!c::%arg-count-error nargs)
  (def type-check-error object-not-type-error sb!c::%type-check-error
    object type)
  (def layout-invalid-error layout-invalid-error sb!c::%layout-invalid-error
    object layout)
  (def odd-key-args-error odd-key-args-error
    sb!c::%odd-key-args-error)
  (def unknown-key-arg-error unknown-key-arg-error
    sb!c::%unknown-key-arg-error key)
  (def nil-fun-returned-error nil-fun-returned-error nil fun))

;;; Single-stepping

(defun emit-single-step-test ()
  ;; We use different ways of representing whether stepping is on on
  ;; +SB-THREAD / -SB-THREAD: on +SB-THREAD, we use a slot in the
  ;; thread structure. On -SB-THREAD we use the value of a static
  ;; symbol. Things are done this way, since reading a thread-local
  ;; slot from a symbol would require an extra register on +SB-THREAD,
  ;; and reading a slot from a thread structure would require an extra
  ;; register on -SB-THREAD. While this isn't critical for x86-64,
  ;; it's more serious for x86.
  #!+sb-thread
  (inst cmp (make-ea :qword
                     :base thread-base-tn
                     :disp (* thread-stepping-slot n-word-bytes))
        nil-value)
  #!-sb-thread
  (inst cmp (make-ea :qword
                     :disp (+ nil-value (static-symbol-offset
                                         'sb!impl::*stepping*)
                              (* symbol-value-slot n-word-bytes)
                              (- other-pointer-lowtag)))
        nil-value))

(define-vop (step-instrument-before-vop)
  (:policy :fast-safe)
  (:vop-var vop)
  (:generator 3
     (emit-single-step-test)
     (inst jmp :eq DONE)
     (inst break single-step-before-trap)
     DONE
     (note-this-location vop :step-before-vop)))