call.lisp

开源跨平台Lisp编译器

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

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

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

;;; BYTES-NEEDED-FOR-NON-DESCRIPTOR-STACK-FRAME -- internal
;;;
;;; 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))

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

;;; Used for computing the caller's NFP for use in known-values return.  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 addu val nfp (bytes-needed-for-non-descriptor-stack-frame))))))


(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 word 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 addu csp-tn cfp-tn
          (* n-word-bytes (sb-allocated-size 'control-stack)))
    (let ((nfp (current-nfp-tn vop)))
      (when nfp
        (inst addu nsp-tn nsp-tn
              (- (bytes-needed-for-non-descriptor-stack-frame)))
        (move nfp nsp-tn)))
    (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 res csp-tn)
    (inst addu csp-tn csp-tn
          (* n-word-bytes (sb-allocated-size 'control-stack)))
    (when (ir2-physenv-number-stack-p callee)
      (inst addu nsp-tn nsp-tn
            (- (bytes-needed-for-non-descriptor-stack-frame)))
      (move nfp nsp-tn))
    (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 res csp-tn)
      (inst addu csp-tn csp-tn (* nargs 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 + 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
;;;     callee 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 csp 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 csp-tn ocfp-tn t)
          (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)
          ;; Branch off to the MV case.
          (inst b regs-defaulted)
          ;; If there are no stack results, clear the stack now.
          (if (> nvals register-arg-count)
              (inst addu temp nargs-tn (fixnumize (- register-arg-count)))
              (move csp-tn ocfp-tn t)))

        ;; 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 (tn-ref-tn val) null-tn))
        (when (> nvals register-arg-count)
          (inst b default-stack-vals)
          (move ocfp-tn csp-tn t))

        (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 blez temp default-lab)
                (inst lw move-temp ocfp-tn (* i n-word-bytes))
                (inst addu temp temp (fixnumize -1))
                (store-stack-tn tn move-temp)))

            (emit-label defaulting-done)
            (move csp-tn ocfp-tn)

            (let ((defaults (defaults)))
              (aver defaults)
              (assemble (*elsewhere*)
                (emit-label default-stack-vals)
                (trace-table-entry trace-table-fun-prologue)
                (do ((remaining defaults (cdr remaining)))