call.lisp

开源跨平台Lisp编译器

  (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 2)) esi)
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 3)) ecx)
  (:temporary (:sc unsigned-reg :offset ebx-offset :from (:eval 0)) ebx)
  (: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 eax 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 esp-tn ebp-tn)
        (move ebp-tn old-fp-temp)
        ;; Set the single-value return flag.
        (inst clc)
        ;; Out of here.
        (inst jmp eax)

        ;; Nope, not the single case. Jump to the assembly routine.
        (emit-label not-single)))
    (move esi vals)
    (move ecx nvals)
    (move ebx ebp-tn)
    (move ebp-tn old-fp)
    (inst jmp (make-fixup 'return-multiple :assembly-routine))
    (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 eax-tn)))

;;; Copy a &MORE arg from the argument area to the end of the current
;;; frame. FIXED is the number of non-&MORE arguments.
;;;
;;; The tricky part is doing this without trashing any of the calling
;;; convention registers that are still needed. This vop is emitted
;;; directly after the xep-allocate frame. That means the registers
;;; are in use as follows:
;;;
;;;  EAX -- The lexenv.
;;;  EBX -- Available.
;;;  ECX -- The total number of arguments.
;;;  EDX -- The first arg.
;;;  EDI -- The second arg.
;;;  ESI -- The third arg.
;;;
;;; So basically, we have one register available for our use: EBX.
;;;
;;; What we can do is push the other regs onto the stack, and then
;;; restore their values by looking directly below where we put the
;;; more-args.
(define-vop (copy-more-arg)
  (:info fixed)
  (:generator 20
    ;; Avoid the copy if there are no more args.
    (cond ((zerop fixed)
           (inst jecxz just-alloc-frame))
          (t
           (inst cmp ecx-tn (fixnumize fixed))
           (inst jmp :be just-alloc-frame)))

    ;; Allocate the space on the stack.
    ;; stack = ebp - (max 3 frame-size) - (nargs - fixed)
    (inst lea ebx-tn
          (make-ea :dword :base ebp-tn
                   :disp (- (fixnumize fixed)
                            (* n-word-bytes
                               (max 3 (sb-allocated-size 'stack))))))
    (inst sub ebx-tn ecx-tn)  ; Got the new stack in ebx
    (inst mov esp-tn ebx-tn)

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

    ;; Save the original count of args.
    (inst mov ebx-tn ecx-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 ecx-tn (fixnumize register-arg-count))
           ;; Everything of interest in registers.
           (inst jmp :be do-regs))
          (t
           ;; Number to copy = nargs-fixed
           (inst sub ecx-tn (fixnumize fixed))))

    ;; Save edi and esi register args.
    (inst push edi-tn)
    (inst push esi-tn)
    (inst push ebx-tn)
    ;; Okay, we have pushed the register args. We can trash them
    ;; now.

    ;; Initialize src to be end of args.
    (inst mov esi-tn ebp-tn)
    (inst sub esi-tn ebx-tn)

    ;; We need to copy from downwards up to avoid overwriting some of
    ;; the yet uncopied args. So we need to use EBX as the copy index
    ;; and ECX as the loop counter, rather than using ECX for both.
    (inst xor ebx-tn ebx-tn)

    ;; 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 edi-tn (make-ea :dword :base esi-tn :index ebx-tn))
    ;; The :DISP is to account for the registers saved on the stack
    (inst mov (make-ea :dword :base esp-tn :disp (* 3 n-word-bytes)
                       :index ebx-tn)
          edi-tn)
    (inst add ebx-tn n-word-bytes)
    (inst sub ecx-tn n-word-bytes)
    (inst jmp :nz COPY-LOOP)

    ;; So now we need to restore EDI and ESI.
    (inst pop ebx-tn)
    (inst pop esi-tn)
    (inst pop edi-tn)

    DO-REGS

    ;; Restore ECX
    (inst mov ecx-tn ebx-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 ebp
              (inst mov (make-ea :dword :base ebp-tn
                                 :disp (- (* 4
                                             (+ 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 ecx-tn ecx-tn)
                (inst cmp ecx-tn (fixnumize i)))
              (inst jmp :eq done)))

    (inst jmp done)

    JUST-ALLOC-FRAME
    (inst lea esp-tn
          (make-ea :dword :base ebp-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 immediate) :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
    (sc-case index
      (immediate
       (inst mov value (make-ea :dword :base object :disp (tn-value index)))
       (inst mov keyword (make-ea :dword :base object
                                  :disp (+ (tn-value index) n-word-bytes))))
      (t
       (inst mov value (make-ea :dword :base object :index index))
       (inst mov keyword (make-ea :dword :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 :dword :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 ecx))
  (:arg-types * tagged-num)
  (:temporary (:sc unsigned-reg :offset esi-offset :from (:argument 0)) src)
  (:temporary (:sc unsigned-reg :offset ecx-offset :from (:argument 1)) ecx)
  (:temporary (:sc unsigned-reg :offset eax-offset) eax)
  (: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 ecx count)
      ;; Check to see whether there are no args, and just return NIL if so.
      (inst mov result nil-value)
      (inst jecxz done)
      (inst lea dst (make-ea :dword :base ecx :index ecx))
      (maybe-pseudo-atomic stack-allocate-p
       (allocation dst dst node stack-allocate-p list-pointer-lowtag)
       (inst shr ecx 2)
       ;; 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 were 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 eax)
       (storew eax dst 0 list-pointer-lowtag)
       ;; Go back for more.
       (inst sub ecx 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 ECX). 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 :dword :base esp-tn
                               :index count :scale 1
                               :disp (- (+ (fixnumize fixed) 4))))
    (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.
  #!+sb-thread
  (progn
    (inst cmp (make-ea :dword
                       :disp (* thread-stepping-slot n-word-bytes))
          nil-value :fs))
  #!-sb-thread
  (inst cmp (make-ea-for-symbol-value sb!impl::*stepping*)
        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)))