call.lisp

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

;;;; the VM definition of function call for the Alpha

;;;; 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*
                     register-arg-scn
                     (elt *register-arg-offsets* n))
      (make-wired-tn *backend-t-primitive-type*
                     control-stack-arg-scn n)))


;;; Make a passing location TN for a local call return PC. If standard
;;; is true, then use the standard (full call) location, otherwise use
;;; any legal location. Even in the non-standard case, this may be
;;; restricted by a desire to use a subroutine call instruction.
(!def-vm-support-routine make-return-pc-passing-location (standard)
  (if standard
      (make-wired-tn *backend-t-primitive-type* register-arg-scn lra-offset)
      (make-restricted-tn *backend-t-primitive-type* register-arg-scn)))

;;; This is similar to MAKE-RETURN-PC-PASSING-LOCATION, but makes a
;;; location to pass OLD-FP in. This is (obviously) wired in the
;;; standard convention, but is totally unrestricted in non-standard
;;; conventions, since we can always fetch it off of the stack using
;;; the arg pointer.
(!def-vm-support-routine make-old-fp-passing-location (standard)
  (if standard
      (make-wired-tn *fixnum-primitive-type* immediate-arg-scn ocfp-offset)
      (make-normal-tn *fixnum-primitive-type*)))

;;; These functions 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.
(!def-vm-support-routine make-old-fp-save-location (env)
  (specify-save-tn
   (physenv-debug-live-tn (make-normal-tn *fixnum-primitive-type*) env)
   (make-wired-tn *fixnum-primitive-type*
                  control-stack-arg-scn
                  ocfp-save-offset)))
(!def-vm-support-routine make-return-pc-save-location (env)
  (let ((ptype *backend-t-primitive-type*))
    (specify-save-tn
     (physenv-debug-live-tn (make-normal-tn ptype) env)
     (make-wired-tn ptype control-stack-arg-scn lra-save-offset))))

;;; 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* immediate-arg-scn nargs-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 ()
  (component-live-tn
   (make-wired-tn *fixnum-primitive-type* immediate-arg-scn nfp-offset)))

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

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

;;; 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))
  (dotimes (i code-constants-offset)
    (vector-push-extend nil
                        (ir2-component-constants (component-info component))))
  (values))


;;;; frame hackery

;;; Return the number of bytes needed for the current non-descriptor
;;; stack frame. Non-descriptor stack frames must be multiples of 8
;;; bytes on the PMAX.
(defun bytes-needed-for-non-descriptor-stack-frame ()
  (* (logandc2 (1+ (sb-allocated-size 'non-descriptor-stack)) 1)
     n-word-bytes))

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

;;; This is used for computing the caller's NFP for use in
;;; known-values return. It only works assuming there is no variable
;;; size stuff on the nstack.
(define-vop (compute-old-nfp)
  (:results (val :scs (any-reg)))
  (:vop-var vop)
  (:generator 1
    (let ((nfp (current-nfp-tn vop)))
      (when nfp
        (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))

(define-vop (xep-allocate-frame)
  (:info start-lab copy-more-arg-follows)
  (:ignore copy-more-arg-follows)
  (:vop-var vop)
  (:temporary (:scs (non-descriptor-reg)) temp)
  (:generator 1
    ;; Make sure the function is aligned, and drop a label pointing to
    ;; this function header.
    (emit-alignment n-lowtag-bits)
    (trace-table-entry trace-table-fun-prologue)
    (emit-label start-lab)
    ;; Allocate function header.
    (inst simple-fun-header-word)
    (dotimes (i (1- simple-fun-code-offset))
      (inst lword 0))
    ;; The start of the actual code.
    ;; Compute CODE from the address of this entry point.
    (let ((entry-point (gen-label)))
      (emit-label entry-point)
      (inst compute-code-from-lip code-tn lip-tn entry-point temp)
      ;; ### We should also save it on the stack so that the garbage
      ;; collector won't forget about us if we call anyone else.
      )
    ;; Build our stack frames.
    (inst lda
          csp-tn
          (* n-word-bytes (sb-allocated-size 'control-stack))
          cfp-tn)
    (let ((nfp (current-nfp-tn vop)))
      (when nfp
        (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
              nsp-tn)
        (move nsp-tn nfp)))
    (trace-table-entry trace-table-normal)))

(define-vop (allocate-frame)
  (:results (res :scs (any-reg))
            (nfp :scs (any-reg)))
  (:info callee)
  (:generator 2
    (trace-table-entry trace-table-fun-prologue)
    (move csp-tn res)
    (inst lda
          csp-tn
          (* n-word-bytes (sb-allocated-size 'control-stack))
          csp-tn)
    (when (ir2-physenv-number-stack-p callee)
      (inst subq nsp-tn (bytes-needed-for-non-descriptor-stack-frame)
            nsp-tn)
      (move nsp-tn nfp))
    (trace-table-entry trace-table-normal)))

;;; Allocate a partial frame for passing stack arguments in a full
;;; call. NARGS is the number of arguments passed. If no stack
;;; arguments are passed, then we don't have to do anything.
(define-vop (allocate-full-call-frame)
  (:info nargs)
  (:results (res :scs (any-reg)))
  (:generator 2
    (when (> nargs register-arg-count)
      (move csp-tn res)
      (inst lda csp-tn (* nargs n-word-bytes) csp-tn))))

;;; 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 + 8, 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.
;;;
;;; The general-case code looks like this:
#|
        b regs-defaulted                ; Skip if MVs
        nop

        move a1 null-tn                 ; Default register values
        ...
        loadi nargs 1                   ; Force defaulting of stack values
        move ocfp csp                   ; Set up args for SP resetting

regs-defaulted
        subu temp nargs register-arg-count

        bltz temp default-value-7       ; jump to default code
        addu temp temp -1
        loadw move-temp ocfp-tn 6       ; Move value to correct location.
        store-stack-tn val4-tn move-temp

        bltz temp default-value-8
        addu temp temp -1
        loadw move-temp ocfp-tn 7
        store-stack-tn val5-tn move-temp

        ...

defaulting-done
        move sp ocfp                    ; Reset SP.
<end of code>

<elsewhere>
default-value-7
        store-stack-tn val4-tn null-tn  ; Nil out 7'th value. (first on stack)

default-value-8
        store-stack-tn val5-tn null-tn  ; Nil out 8'th value.

        ...

        br defaulting-done
        nop
|#
(defun default-unknown-values (vop values nvals move-temp temp lra-label)
  (declare (type (or tn-ref null) values)
           (type unsigned-byte nvals) (type tn move-temp temp))
  (if (<= nvals 1)
      (progn
        ;; Note that this is a single-value return point. This is
        ;; actually the multiple-value entry point for a single
        ;; desired value, but the code location has to be here, or the
        ;; debugger backtrace gets confused.
        (without-scheduling ()
          (note-this-location vop :single-value-return)
          (move ocfp-tn csp-tn)
          (inst nop))
        (when lra-label
          (inst compute-code-from-lra code-tn code-tn lra-label temp)))
      (let ((regs-defaulted (gen-label))
            (defaulting-done (gen-label))
            (default-stack-vals (gen-label)))
        (without-scheduling ()
          ;; Note that this is an unknown-values return point.
          (note-this-location vop :unknown-return)
          ;; If there are no stack results, clear the stack now.
          (if (> nvals register-arg-count)
              (inst subq nargs-tn (fixnumize register-arg-count) temp)
              (move ocfp-tn csp-tn))
          ;; Branch off to the MV case.
          (inst br zero-tn regs-defaulted))

        ;; Do the single value case.
        (do ((i 1 (1+ i))
             (val (tn-ref-across values) (tn-ref-across val)))
            ((= i (min nvals register-arg-count)))
          (move null-tn (tn-ref-tn val)))
        (when (> nvals register-arg-count)
          (move csp-tn ocfp-tn)
          (inst br zero-tn default-stack-vals))

        (emit-label regs-defaulted)

        (when (> nvals register-arg-count)
          ;; If there are stack results, we have to default them
          ;; and clear the stack.
          (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 ble temp default-lab)
                (inst ldl move-temp (* i n-word-bytes) ocfp-tn)
                (inst subq temp (fixnumize 1) temp)