call.lisp

开源跨平台Lisp编译器

;;;; function call for the x86 VM

;;;; This software is part of the SBCL system. See the README file for
;;;; more information.
;;;;
;;;; This software is derived from the CMU CL system, which was
;;;; written at Carnegie Mellon University and released into the
;;;; public domain. The software is in the public domain and is
;;;; provided with absolutely no warranty. See the COPYING and CREDITS
;;;; files for more information.

(in-package "SB!VM")

;;;; interfaces to IR2 conversion

;;; Return a wired TN describing the N'th full call argument passing
;;; location.
(!def-vm-support-routine standard-arg-location (n)
  (declare (type unsigned-byte n))
  (if (< n register-arg-count)
      (make-wired-tn *backend-t-primitive-type* descriptor-reg-sc-number
                     (nth n *register-arg-offsets*))
      (make-wired-tn *backend-t-primitive-type* control-stack-sc-number n)))

;;; Make a passing location TN for a local call return PC.
;;;
;;; Always wire the return PC location to the stack in its standard
;;; location.
(!def-vm-support-routine make-return-pc-passing-location (standard)
  (declare (ignore standard))
  (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
                 sap-stack-sc-number return-pc-save-offset))

;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
;;; location to pass OLD-FP in.
;;;
;;; This is wired in both the standard and the local-call conventions,
;;; because we want to be able to assume it's always there. Besides,
;;; the x86 doesn't have enough registers to really make it profitable
;;; to pass it in a register.
(!def-vm-support-routine make-old-fp-passing-location (standard)
  (declare (ignore standard))
  (make-wired-tn *fixnum-primitive-type* control-stack-sc-number
                 ocfp-save-offset))

;;; Make the TNs used to hold OLD-FP and RETURN-PC within the current
;;; function. We treat these specially so that the debugger can find
;;; them at a known location.
;;;
;;; Without using a save-tn - which does not make much sense if it is
;;; wired to the stack?
(!def-vm-support-routine make-old-fp-save-location (physenv)
  (physenv-debug-live-tn (make-wired-tn *fixnum-primitive-type*
                                        control-stack-sc-number
                                        ocfp-save-offset)
                         physenv))
(!def-vm-support-routine make-return-pc-save-location (physenv)
  (physenv-debug-live-tn
   (make-wired-tn (primitive-type-or-lose 'system-area-pointer)
                  sap-stack-sc-number return-pc-save-offset)
   physenv))

;;; Make a TN for the standard argument count passing location. We only
;;; need to make the standard location, since a count is never passed when we
;;; are using non-standard conventions.
(!def-vm-support-routine make-arg-count-location ()
  (make-wired-tn *fixnum-primitive-type* any-reg-sc-number rcx-offset))

;;; Make a TN to hold the number-stack frame pointer. This is allocated
;;; once per component, and is component-live.
(!def-vm-support-routine make-nfp-tn ()
  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))

(!def-vm-support-routine make-stack-pointer-tn ()
  (make-normal-tn *fixnum-primitive-type*))

(!def-vm-support-routine make-number-stack-pointer-tn ()
  (make-restricted-tn *fixnum-primitive-type* ignore-me-sc-number))

;;; Return a list of TNs that can be used to represent an unknown-values
;;; continuation within a function.
(!def-vm-support-routine make-unknown-values-locations ()
  (list (make-stack-pointer-tn)
        (make-normal-tn *fixnum-primitive-type*)))

;;; This function is called by the ENTRY-ANALYZE phase, allowing
;;; VM-dependent initialization of the IR2-COMPONENT structure. We
;;; push placeholder entries in the CONSTANTS to leave room for
;;; additional noise in the code object header.
(!def-vm-support-routine select-component-format (component)
  (declare (type component component))
  ;; The 1+ here is because for the x86 the first constant is a
  ;; pointer to a list of fixups, or NIL if the code object has none.
  ;; (If I understand correctly, the fixups are needed at GC copy
  ;; time because the X86 code isn't relocatable.)
  ;;
  ;; KLUDGE: It'd be cleaner to have the fixups entry be a named
  ;; element of the CODE (aka component) primitive object. However,
  ;; it's currently a large, tricky, error-prone chore to change
  ;; the layout of any primitive object, so for the foreseeable future
  ;; we'll just live with this ugliness. -- WHN 2002-01-02
  (dotimes (i (1+ code-constants-offset))
    (vector-push-extend nil
                        (ir2-component-constants (component-info component))))
  (values))

;;;; frame hackery

;;; This is used for setting up the Old-FP in local call.
(define-vop (current-fp)
  (:results (val :scs (any-reg control-stack)))
  (:generator 1
    (move val rbp-tn)))

;;; We don't have a separate NFP, so we don't need to do anything here.
(define-vop (compute-old-nfp)
  (:results (val))
  (:ignore val)
  (:generator 1
    nil))

(define-vop (xep-allocate-frame)
  (:info start-lab copy-more-arg-follows)
  (:vop-var vop)
  (:generator 1
    (emit-alignment n-lowtag-bits)
    (trace-table-entry trace-table-fun-prologue)
    (emit-label start-lab)
    ;; Skip space for the function header.
    (inst simple-fun-header-word)
    (dotimes (i (* n-word-bytes (1- simple-fun-code-offset)))
      (inst byte 0))

    ;; The start of the actual code.
    ;; Save the return-pc.
    (popw rbp-tn (- (1+ return-pc-save-offset)))

    ;; If copy-more-arg follows it will allocate the correct stack
    ;; size. The stack is not allocated first here as this may expose
    ;; args on the stack if they take up more space than the frame!
    (unless copy-more-arg-follows
      ;; The args fit within the frame so just allocate the frame.
      (inst lea rsp-tn
            (make-ea :qword :base rbp-tn
                     :disp (- (* n-word-bytes
                                 (max 3 (sb-allocated-size 'stack)))))))

    (trace-table-entry trace-table-normal)))

;;; This is emitted directly before either a known-call-local, call-local,
;;; or a multiple-call-local. All it does is allocate stack space for the
;;; callee (who has the same size stack as us).
(define-vop (allocate-frame)
  (:results (res :scs (any-reg control-stack))
            (nfp))
  (:info callee)
  (:ignore nfp callee)
  (:generator 2
    (move res rsp-tn)
    (inst sub rsp-tn (* n-word-bytes (sb-allocated-size 'stack)))))

;;; Allocate a partial frame for passing stack arguments in a full
;;; call. NARGS is the number of arguments passed. We allocate at
;;; least 3 slots, because the XEP noise is going to want to use them
;;; before it can extend the stack.
(define-vop (allocate-full-call-frame)
  (:info nargs)
  (:results (res :scs (any-reg control-stack)))
  (:generator 2
    (move res rsp-tn)
    (inst sub rsp-tn (* (max nargs 3) n-word-bytes))))

;;; Emit code needed at the return-point from an unknown-values call
;;; for a fixed number of values. Values is the head of the TN-REF
;;; list for the locations that the values are to be received into.
;;; Nvals is the number of values that are to be received (should
;;; equal the length of Values).
;;;
;;; MOVE-TEMP is a DESCRIPTOR-REG TN used as a temporary.
;;;
;;; This code exploits the fact that in the unknown-values convention,
;;; a single value return returns at the return PC + 2, whereas a
;;; return of other than one value returns directly at the return PC.
;;;
;;; If 0 or 1 values are expected, then we just emit an instruction to
;;; reset the SP (which will only be executed when other than 1 value
;;; is returned.)
;;;
;;; In the general case we have to do three things:
;;;  -- Default unsupplied register values. This need only be done
;;;     when a single value is returned, since register values are
;;;     defaulted by the called in the non-single case.
;;;  -- Default unsupplied stack values. This needs to be done whenever
;;;     there are stack values.
;;;  -- Reset SP. This must be done whenever other than 1 value is
;;;     returned, regardless of the number of values desired.
(defun default-unknown-values (vop values nvals)
  (declare (type (or tn-ref null) values)
           (type unsigned-byte nvals))
  (cond
   ((<= nvals 1)
    (note-this-location vop :single-value-return)
    (inst cmov :c rsp-tn rbx-tn))
   ((<= nvals register-arg-count)
    (let ((regs-defaulted (gen-label)))
      (note-this-location vop :unknown-return)
      (inst jmp :c regs-defaulted)
      ;; Default the unsupplied registers.
      (let* ((2nd-tn-ref (tn-ref-across values))
             (2nd-tn (tn-ref-tn 2nd-tn-ref)))
        (inst mov 2nd-tn nil-value)
        (when (> nvals 2)
          (loop
            for tn-ref = (tn-ref-across 2nd-tn-ref)
            then (tn-ref-across tn-ref)
            for count from 2 below register-arg-count
            do (inst mov (tn-ref-tn tn-ref) 2nd-tn))))
      (inst mov rbx-tn rsp-tn)
      (emit-label regs-defaulted)
      (inst mov rsp-tn rbx-tn)))
   ((<= nvals 7)
    ;; The number of bytes depends on the relative jump instructions.
    ;; Best case is 31+(n-3)*14, worst case is 35+(n-3)*18. For
    ;; NVALS=6 that is 73/89 bytes, and for NVALS=7 that is 87/107
    ;; bytes which is likely better than using the blt below.
    (let ((regs-defaulted (gen-label))
          (defaulting-done (gen-label))
          (default-stack-slots (gen-label)))
      (note-this-location vop :unknown-return)
      ;; Branch off to the MV case.
      (inst jmp :c regs-defaulted)
      ;; Do the single value case.
      ;; Default the register args
      (inst mov rax-tn nil-value)
      (do ((i 1 (1+ i))
           (val (tn-ref-across values) (tn-ref-across val)))
          ((= i (min nvals register-arg-count)))
        (inst mov (tn-ref-tn val) rax-tn))

      ;; Fake other registers so it looks like we returned with all the
      ;; registers filled in.
      (move rbx-tn rsp-tn)
      (inst push rdx-tn)
      (inst jmp default-stack-slots)

      (emit-label regs-defaulted)

      (inst mov rax-tn nil-value)
      (storew rdx-tn rbx-tn -1)
      (collect ((defaults))
        (do ((i register-arg-count (1+ i))
             (val (do ((i 0 (1+ i))
                       (val values (tn-ref-across val)))
                      ((= i register-arg-count) val))
                  (tn-ref-across val)))
            ((null val))
          (let ((default-lab (gen-label))
                (tn (tn-ref-tn val)))
            (defaults (cons default-lab tn))

            (inst cmp rcx-tn (fixnumize i))
            (inst jmp :be default-lab)
            (loadw rdx-tn rbx-tn (- (1+ i)))
            (inst mov tn rdx-tn)))

        (emit-label defaulting-done)
        (loadw rdx-tn rbx-tn -1)
        (move rsp-tn rbx-tn)

        (let ((defaults (defaults)))
          (when defaults
            (assemble (*elsewhere*)
              (trace-table-entry trace-table-fun-prologue)
              (emit-label default-stack-slots)
              (dolist (default defaults)
                (emit-label (car default))
                (inst mov (cdr default) rax-tn))
              (inst jmp defaulting-done)
              (trace-table-entry trace-table-normal)))))))
   (t
    (let ((regs-defaulted (gen-label))
          (restore-edi (gen-label))
          (no-stack-args (gen-label))
          (default-stack-vals (gen-label))
          (count-okay (gen-label)))
      (note-this-location vop :unknown-return)
      ;; Branch off to the MV case.
      (inst jmp :c regs-defaulted)

      ;; Default the register args, and set up the stack as if we
      ;; entered the MV return point.
      (inst mov rbx-tn rsp-tn)
      (inst push rdx-tn)
      (inst mov rdi-tn nil-value)
      (inst push rdi-tn)
      (inst mov rsi-tn rdi-tn)
      ;; Compute a pointer to where to put the [defaulted] stack values.
      (emit-label no-stack-args)
      (inst lea rdi-tn
            (make-ea :qword :base rbp-tn
                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
      ;; Load RAX with NIL so we can quickly store it, and set up
      ;; stuff for the loop.
      (inst mov rax-tn nil-value)
      (inst std)
      (inst mov rcx-tn (- nvals register-arg-count))
      ;; Jump into the default loop.
      (inst jmp default-stack-vals)

      ;; The regs are defaulted. We need to copy any stack arguments,
      ;; and then default the remaining stack arguments.
      (emit-label regs-defaulted)
      ;; Save EDI.
      (storew rdi-tn rbx-tn (- (1+ 1)))
      ;; Compute the number of stack arguments, and if it's zero or
      ;; less, don't copy any stack arguments.
      (inst sub rcx-tn (fixnumize register-arg-count))
      (inst jmp :le no-stack-args)

      ;; Throw away any unwanted args.
      (inst cmp rcx-tn (fixnumize (- nvals register-arg-count)))
      (inst jmp :be count-okay)
      (inst mov rcx-tn (fixnumize (- nvals register-arg-count)))
      (emit-label count-okay)
      ;; Save the number of stack values.
      (inst mov rax-tn rcx-tn)
      ;; Compute a pointer to where the stack args go.
      (inst lea rdi-tn
            (make-ea :qword :base rbp-tn
                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
      ;; Save ESI, and compute a pointer to where the args come from.
      (storew rsi-tn rbx-tn (- (1+ 2)))
      (inst lea rsi-tn
            (make-ea :qword :base rbx-tn
                     :disp (* (- (1+ register-arg-count)) n-word-bytes)))
      ;; Do the copy.
      (inst shr rcx-tn word-shift)              ; make word count
      (inst std)
      (inst rep)
      (inst movs :qword)
      ;; Restore RSI.
      (loadw rsi-tn rbx-tn (- (1+ 2)))
      ;; Now we have to default the remaining args. Find out how many.
      (inst sub rax-tn (fixnumize (- nvals register-arg-count)))
      (inst neg rax-tn)
      ;; If none, then just blow out of here.
      (inst jmp :le restore-edi)
      (inst mov rcx-tn rax-tn)
      (inst shr rcx-tn word-shift)      ; word count
      ;; Load RAX with NIL for fast storing.
      (inst mov rax-tn nil-value)
      ;; Do the store.
      (emit-label default-stack-vals)
      (inst rep)
      (inst stos rax-tn)
      ;; Restore EDI, and reset the stack.
      (emit-label restore-edi)
      (loadw rdi-tn rbx-tn (- (1+ 1)))