call.lisp

开源跨平台Lisp编译器

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

;;;; 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)
  (specify-save-tn
   (physenv-debug-live-tn (make-normal-tn *backend-t-primitive-type*) env)
   (make-wired-tn *backend-t-primitive-type*
                  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.
;;; We have to allocate multiples of 64 bytes.
(defun bytes-needed-for-non-descriptor-stack-frame ()
  (logandc2 (+ (* (sb-allocated-size 'non-descriptor-stack) n-word-bytes) 63)
            63))

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

;;; 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 addi (- (bytes-needed-for-non-descriptor-stack-frame))
              nfp 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 fun-header-word)
    (dotimes (i (1- simple-fun-code-offset))
      (inst word 0))
    ;; The start of the actual code.
    ;; Fix CODE, cause the function object was passed in.
    (let ((entry-point (gen-label)))
      (emit-label entry-point)
      (inst compute-code-from-lip lip-tn entry-point temp code-tn))
    ;; Build our stack frames.
    (inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
          cfp-tn csp-tn)
    (let ((nfp (current-nfp-tn vop)))
      (when nfp
        (move nsp-tn nfp)
        (inst addi (bytes-needed-for-non-descriptor-stack-frame)
              nsp-tn 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
    (move csp-tn res)
    (inst addi (* n-word-bytes (sb-allocated-size 'control-stack))
          csp-tn csp-tn)
    (when (ir2-physenv-number-stack-p callee)
      (move nsp-tn nfp)
      (inst addi (bytes-needed-for-non-descriptor-stack-frame)
            nsp-tn nsp-tn))))

;;; 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 addi (* nargs n-word-bytes) csp-tn 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 old-fp 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 old-fp-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 old-fp-tn 7
        store-stack-tn val5-tn move-temp

        ...

defaulting-done
        move sp old-fp                  ; 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))
  (cond
   ((<= nvals 1)
    (assemble ()
      ;; 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.
      (note-this-location vop :single-value-return)
      (move ocfp-tn csp-tn)
      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
   ((<= nvals register-arg-count)
    (assemble ()
      ;; 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 :nullify t)

      ;; Default any unsupplied values.
      (do ((val (tn-ref-across values) (tn-ref-across val)))
          ((null val))
        (inst move null-tn (tn-ref-tn val)
              (if (tn-ref-across val)
                  :never
                  :tr)))

      REGS-DEFAULTED

      ;; Clear the stack.  Note: the last move in the single value reg
      ;; defaulting nullifies this, so this only happens in the mv case.
      (move ocfp-tn csp-tn)

      ;; Fix CODE.
      (inst compute-code-from-lra code-tn lra-label temp code-tn)))
   (t
    (collect ((defaults))
      (assemble (nil nil :labels (default-stack-vals))
        ;; 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 :nullify t)

        ;; Default any unsupplied register values.
        (do ((i 1 (1+ i))
             (val (tn-ref-across values) (tn-ref-across val)))
            ((= i register-arg-count))
          (inst move null-tn (tn-ref-tn val)))
        (inst b default-stack-vals)
        (move ocfp-tn csp-tn)

        REGS-DEFAULTED

        (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 bci :>= nil (fixnumize i) nargs-tn default-lab)
            (loadw move-temp ocfp-tn i)
            (store-stack-tn tn move-temp)))

        DEFAULTING-DONE
        (move ocfp-tn csp-tn)
        (inst compute-code-from-lra code-tn lra-label temp code-tn)

        (let ((defaults (defaults)))
          (aver defaults)
          (assemble (*elsewhere*)
            (trace-table-entry trace-table-call-site)
            DEFAULT-STACK-VALS
            (do ((remaining defaults (cdr remaining)))
                ((null remaining))
              (let ((def (car remaining)))
                (emit-label (car def))
                (when (null (cdr remaining))
                  (inst b defaulting-done))
                (store-stack-tn (cdr def) null-tn)))
            (trace-table-entry trace-table-normal)))))))
  (values))


;;;; Unknown values receiving:

;;;    Emit code needed at the return point for an unknown-values call for an
;;; arbitrary number of values.
;;;
;;;    We do the single and non-single cases with no shared code: there doesn't
;;; seem to be any potential overlap, and receiving a single value is more
;;; important efficiency-wise.
;;;
;;;    When there is a single value, we just push it on the stack, returning
;;; the old SP and 1.
;;;
;;;    When there is a variable number of values, we move all of the argument
;;; registers onto the stack, and return Args and Nargs.
;;;
;;;    Args and Nargs are TNs wired to the named locations.  We must
;;; explicitly allocate these TNs, since their lifetimes overlap with the
;;; results Start and Count (also, it's nice to be able to target them).
;;;
(defun receive-unknown-values (args nargs start count lra-label temp)
  (declare (type tn args nargs start count temp))
  (assemble (nil nil :labels (variable-values))
    (inst b variable-values :nullify t)

    (inst compute-code-from-lra code-tn lra-label temp code-tn)
    (inst move csp-tn start)
    (inst stwm (first register-arg-tns) n-word-bytes csp-tn)
    (inst li (fixnumize 1) count)

    DONE

    (assemble (*elsewhere*)
      (trace-table-entry trace-table-call-site)
      VARIABLE-VALUES
      (inst compute-code-from-lra code-tn lra-label temp code-tn)
      (do ((arg register-arg-tns (rest arg))
           (i 0 (1+ i)))
          ((null arg))
        (storew (first arg) args i))
      (move args start)
      (move nargs count)
      (inst b done :nullify t)
      (trace-table-entry trace-table-normal)))
  (values))

;;; VOP that can be inherited by unknown values receivers.  The main thing this
;;; handles is allocation of the result temporaries.
;;;
(define-vop (unknown-values-receiver)
  (:results (start :scs (any-reg))
            (count :scs (any-reg)))
  (:temporary (:sc descriptor-reg :offset ocfp-offset
                   :from :eval :to (:result 0))
              values-start)
  (:temporary (:sc any-reg :offset nargs-offset
               :from :eval :to (:result 1))
              nvals)
  (:temporary (:scs (non-descriptor-reg)) temp))



;;;; Local call with unknown values convention return: