(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))
+ register-arg-scn
+ (elt *register-arg-offsets* n))
(make-wired-tn *backend-t-primitive-type*
- control-stack-arg-scn n)))
+ control-stack-arg-scn n)))
;;; Make a passing location TN for a local call return PC. If standard
(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)))
+ 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
;;; 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*)))
+ (make-normal-tn *fixnum-primitive-type*)))
;;; This function is called by the ENTRY-ANALYZE phase, allowing
(declare (type component component))
(dotimes (i code-constants-offset)
(vector-push-extend nil
- (ir2-component-constants (component-info component))))
+ (ir2-component-constants (component-info component))))
(values))
\f
(:generator 1
(let ((nfp (current-nfp-tn vop)))
(when nfp
- (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))
+ (inst addq nfp (bytes-needed-for-non-descriptor-stack-frame) val)))))
(define-vop (xep-allocate-frame)
(:info start-lab copy-more-arg-follows)
)
;; Build our stack frames.
(inst lda
- csp-tn
- (* n-word-bytes (sb-allocated-size 'control-stack))
- cfp-tn)
+ 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)))
+ (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)))
+ (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)
+ 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)
+ nsp-tn)
(move nsp-tn nfp))
(trace-table-entry trace-table-normal)))
;;;
;;; The general-case code looks like this:
#|
- b regs-defaulted ; Skip if MVs
- nop
+ 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
+ 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
+ subu temp nargs register-arg-count
- bltz temp default-value-7 ; jump to default code
+ 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
+ loadw move-temp ocfp-tn 6 ; Move value to correct location.
+ store-stack-tn val4-tn move-temp
- bltz temp default-value-8
+ bltz temp default-value-8
addu temp temp -1
- loadw move-temp ocfp-tn 7
- store-stack-tn val5-tn move-temp
+ loadw move-temp ocfp-tn 7
+ store-stack-tn val5-tn move-temp
- ...
+ ...
defaulting-done
- move sp ocfp ; Reset SP.
+ 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)
+ 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.
+ store-stack-tn val5-tn null-tn ; Nil out 8'th value.
- ...
+ ...
- br defaulting-done
+ 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))
+ (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)))
+ ;; 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)
- (store-stack-tn tn move-temp)))
-
- (emit-label defaulting-done)
- (move ocfp-tn csp-tn)
-
- (let ((defaults (defaults)))
- (aver defaults)
- (assemble (*elsewhere*)
- (emit-label default-stack-vals)
- (do ((remaining defaults (cdr remaining)))
- ((null remaining))
- (let ((def (car remaining)))
- (emit-label (car def))
- (store-stack-tn (cdr def) null-tn)))
- (inst br zero-tn defaulting-done)))))
-
- (when lra-label
- (inst compute-code-from-lra code-tn code-tn lra-label temp))))
+ (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)
+ (store-stack-tn tn move-temp)))
+
+ (emit-label defaulting-done)
+ (move ocfp-tn csp-tn)
+
+ (let ((defaults (defaults)))
+ (aver defaults)
+ (assemble (*elsewhere*)
+ (emit-label default-stack-vals)
+ (do ((remaining defaults (cdr remaining)))
+ ((null remaining))
+ (let ((def (car remaining)))
+ (emit-label (car def))
+ (store-stack-tn (cdr def) null-tn)))
+ (inst br zero-tn defaulting-done)))))
+
+ (when lra-label
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))))
(values))
\f
;;;; unknown values receiving
(defun receive-unknown-values (args nargs start count lra-label temp)
(declare (type tn args nargs start count temp))
(let ((variable-values (gen-label))
- (done (gen-label)))
+ (done (gen-label)))
(without-scheduling ()
(inst br zero-tn variable-values)
(inst nop))
(storew (first *register-arg-tns*) csp-tn -1)
(inst subq csp-tn 4 start)
(inst li (fixnumize 1) count)
-
+
(emit-label done)
-
+
(assemble (*elsewhere*)
(emit-label variable-values)
(when lra-label
- (inst compute-code-from-lra code-tn code-tn lra-label temp))
+ (inst compute-code-from-lra code-tn code-tn lra-label temp))
(do ((arg *register-arg-tns* (rest arg))
- (i 0 (1+ i)))
- ((null arg))
- (storew (first arg) args i))
+ (i 0 (1+ i)))
+ ((null arg))
+ (storew (first arg) args i))
(move args start)
(move nargs count)
(inst br zero-tn done)))
(start :scs (any-reg))
(count :scs (any-reg)))
(:temporary (:sc descriptor-reg :offset ocfp-offset
- :from :eval :to (:result 0))
- values-start)
+ :from :eval :to (:result 0))
+ values-start)
(:temporary (:sc any-reg :offset nargs-offset
- :from :eval :to (:result 1))
- nvals)
+ :from :eval :to (:result 1))
+ nvals)
(:temporary (:scs (non-descriptor-reg)) temp))
\f
;;;; local call with unknown values convention return
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (values :more t))
(:save-p t)
(:move-args :local-call)
(:ignore arg-locs args ocfp)
(:generator 5
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst br zero-tn target)
(trace-table-entry trace-table-normal)
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (multiple-call-local unknown-values-receiver)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:save-p t)
(:move-args :local-call)
(:info save callee target)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 20
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst bsr zero-tn target)
(trace-table-entry trace-table-normal)
;;; MAYBE-LOAD-STACK-TN.
(define-vop (known-call-local)
(:args (fp)
- (nfp)
- (args :more t))
+ (nfp)
+ (args :more t))
(:results (res :more t))
(:move-args :local-call)
(:save-p t)
(:temporary (:scs (non-descriptor-reg)) temp)
(:generator 5
(let ((label (gen-label))
- (cur-nfp (current-nfp-tn vop)))
+ (cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (store-stack-tn nfp-save cur-nfp))
+ (store-stack-tn nfp-save cur-nfp))
(let ((callee-nfp (callee-nfp-tn callee)))
- (maybe-load-stack-nfp-tn callee-nfp nfp temp))
+ (maybe-load-stack-nfp-tn callee-nfp nfp temp))
(maybe-load-stack-tn cfp-tn fp)
(trace-table-entry trace-table-call-site)
(inst compute-lra-from-code
- (callee-return-pc-tn callee) code-tn label temp)
+ (callee-return-pc-tn callee) code-tn label temp)
(note-this-location vop :call-site)
(inst bsr zero-tn target)
(trace-table-entry trace-table-normal)
;;; we use MAYBE-LOAD-STACK-TN.
(define-vop (known-return)
(:args (ocfp :target ocfp-temp)
- (return-pc :target return-pc-temp)
- (vals :more t))
+ (return-pc :target return-pc-temp)
+ (vals :more t))
(:temporary (:sc any-reg :from (:argument 0)) ocfp-temp)
(:temporary (:sc any-reg :from (:argument 1))
- return-pc-temp)
+ return-pc-temp)
(:temporary (:scs (interior-reg)) lip)
(:move-args :known-return)
(:info val-locs)
(move cfp-tn csp-tn)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
(inst subq return-pc-temp (- other-pointer-lowtag n-word-bytes) lip)
(move ocfp-temp cfp-tn)
(inst ret zero-tn lip 1)
;;; code replication in defining the cross-product VOPs.
;;;
;;; Name is the name of the VOP to define.
-;;;
+;;;
;;; Named is true if the first argument is a symbol whose global
;;; function definition is to be called.
;;;
;;; Return is either :FIXED, :UNKNOWN or :TAIL:
;;; -- If :FIXED, then the call is for a fixed number of values, returned
;;; in the standard passing locations (passed as result operands).
-;;; -- If :UNKNOWN, then the result values are pushed on the stack, and
+;;; -- If :UNKNOWN, then the result values are pushed on the stack, and
;;; the result values are specified by the Start and Count as in the
;;; unknown-values continuation representation.
;;; -- If :TAIL, then do a tail-recursive call. No values are returned.
(defmacro define-full-call (name named return variable)
(aver (not (and variable (eq return :tail))))
`(define-vop (,name
- ,@(when (eq return :unknown)
- '(unknown-values-receiver)))
+ ,@(when (eq return :unknown)
+ '(unknown-values-receiver)))
(:args
,@(unless (eq return :tail)
- '((new-fp :scs (any-reg) :to :eval)))
+ '((new-fp :scs (any-reg) :to :eval)))
,(if named
- '(name :target name-pass)
- '(arg-fun :target lexenv))
-
+ '(name :target name-pass)
+ '(arg-fun :target lexenv))
+
,@(when (eq return :tail)
- '((ocfp :target ocfp-pass)
- (return-pc :target return-pc-pass)))
-
+ '((ocfp :target ocfp-pass)
+ (return-pc :target return-pc-pass)))
+
,@(unless variable '((args :more t :scs (descriptor-reg)))))
,@(when (eq return :fixed)
- '((:results (values :more t))))
-
+ '((:results (values :more t))))
+
(:save-p ,(if (eq return :tail) :compute-only t))
,@(unless (or (eq return :tail) variable)
- '((:move-args :full-call)))
+ '((:move-args :full-call)))
(:vop-var vop)
(:info ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(nargs))
- ,@(when (eq return :fixed) '(nvals)))
+ ,@(unless variable '(nargs))
+ ,@(when (eq return :fixed) '(nvals)))
(:ignore #!+gengc ,@(unless (eq return :tail) '(return-pc-pass))
- ,@(unless (or variable (eq return :tail)) '(arg-locs))
- ,@(unless variable '(args)))
+ ,@(unless (or variable (eq return :tail)) '(arg-locs))
+ ,@(unless variable '(args)))
(:temporary (:sc descriptor-reg
- :offset ocfp-offset
- :from (:argument 1)
- ,@(unless (eq return :fixed)
- '(:to :eval)))
- ocfp-pass)
+ :offset ocfp-offset
+ :from (:argument 1)
+ ,@(unless (eq return :fixed)
+ '(:to :eval)))
+ ocfp-pass)
(:temporary (:sc descriptor-reg
- :offset #!-gengc lra-offset #!+gengc ra-offset
- :from (:argument ,(if (eq return :tail) 2 1))
- :to :eval)
- return-pc-pass)
+ :offset #!-gengc lra-offset #!+gengc ra-offset
+ :from (:argument ,(if (eq return :tail) 2 1))
+ :to :eval)
+ return-pc-pass)
,@(if named
- `((:temporary (:sc descriptor-reg :offset fdefn-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- name-pass))
-
- `((:temporary (:sc descriptor-reg :offset lexenv-offset
- :from (:argument ,(if (eq return :tail) 0 1))
- :to :eval)
- lexenv)
- #!-gengc
- (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
- function)))
+ `((:temporary (:sc descriptor-reg :offset fdefn-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ name-pass))
+
+ `((:temporary (:sc descriptor-reg :offset lexenv-offset
+ :from (:argument ,(if (eq return :tail) 0 1))
+ :to :eval)
+ lexenv)
+ #!-gengc
+ (:temporary (:scs (descriptor-reg) :from (:argument 0) :to :eval)
+ function)))
(:temporary (:sc any-reg :offset nargs-offset :to :eval)
- nargs-pass)
+ nargs-pass)
,@(when variable
- (mapcar (lambda (name offset)
- `(:temporary (:sc descriptor-reg
- :offset ,offset
- :to :eval)
- ,name))
- register-arg-names *register-arg-offsets*))
+ (mapcar (lambda (name offset)
+ `(:temporary (:sc descriptor-reg
+ :offset ,offset
+ :to :eval)
+ ,name))
+ register-arg-names *register-arg-offsets*))
,@(when (eq return :fixed)
- '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
+ '((:temporary (:scs (descriptor-reg) :from :eval) move-temp)))
,@(unless (eq return :tail)
- '((:temporary (:scs (non-descriptor-reg)) temp)
- (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
+ '((:temporary (:scs (non-descriptor-reg)) temp)
+ (:temporary (:sc control-stack :offset nfp-save-offset) nfp-save)))
(:temporary (:sc interior-reg :offset lip-offset) entry-point)
(:generator ,(+ (if named 5 0)
- (if variable 19 1)
- (if (eq return :tail) 0 10)
- 15
- (if (eq return :unknown) 25 0))
+ (if variable 19 1)
+ (if (eq return :tail) 0 10)
+ 15
+ (if (eq return :unknown) 25 0))
(let* ((cur-nfp (current-nfp-tn vop))
- ,@(unless (eq return :tail)
- '((lra-label (gen-label))))
- (filler
- (remove nil
- (list :load-nargs
- ,@(if (eq return :tail)
- '((unless (location= ocfp ocfp-pass)
- :load-ocfp)
- (unless (location= return-pc
- return-pc-pass)
- :load-return-pc)
- (when cur-nfp
- :frob-nfp))
- '(#!-gengc
- :comp-lra
- (when cur-nfp
- :frob-nfp)
- :save-fp
- :load-fp))))))
- (flet ((do-next-filler ()
- (let* ((next (pop filler))
- (what (if (consp next) (car next) next)))
- (ecase what
- (:load-nargs
- ,@(if variable
- `((inst subq csp-tn new-fp nargs-pass)
- ,@(let ((index -1))
- (mapcar (lambda (name)
- `(inst ldl ,name
- ,(ash (incf index)
- word-shift)
- new-fp))
- register-arg-names)))
- '((inst li (fixnumize nargs) nargs-pass))))
- ,@(if (eq return :tail)
- '((:load-ocfp
- (sc-case ocfp
- (any-reg
- (inst move ocfp ocfp-pass))
- (control-stack
- (inst ldl ocfp-pass
- (ash (tn-offset ocfp)
- word-shift)
- cfp-tn))))
- (:load-return-pc
- (sc-case return-pc
- (#!-gengc descriptor-reg #!+gengc any-reg
- (inst move return-pc return-pc-pass))
- (control-stack
- (inst ldl return-pc-pass
- (ash (tn-offset return-pc)
- word-shift)
- cfp-tn))))
- (:frob-nfp
- (inst addq cur-nfp
- (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
- `(#!-gengc
- (:comp-lra
- (inst compute-lra-from-code
- return-pc-pass code-tn lra-label temp))
- (:frob-nfp
- (store-stack-tn nfp-save cur-nfp))
- (:save-fp
- (inst move cfp-tn ocfp-pass))
- (:load-fp
- ,(if variable
- '(move new-fp cfp-tn)
- '(if (> nargs register-arg-count)
- (move new-fp cfp-tn)
- (move csp-tn cfp-tn)))
- (trace-table-entry trace-table-call-site))))
- ((nil))))))
-
- ,@(if named
- `((sc-case name
- (descriptor-reg (move name name-pass))
- (control-stack
- (inst ldl name-pass
- (ash (tn-offset name) word-shift) cfp-tn)
- (do-next-filler))
- (constant
- (inst ldl name-pass
- (- (ash (tn-offset name) word-shift)
- other-pointer-lowtag) code-tn)
- (do-next-filler)))
- (inst ldl entry-point
- (- (ash fdefn-raw-addr-slot word-shift)
- other-pointer-lowtag) name-pass)
- (do-next-filler))
- `((sc-case arg-fun
- (descriptor-reg (move arg-fun lexenv))
- (control-stack
- (inst ldl lexenv
- (ash (tn-offset arg-fun) word-shift) cfp-tn)
- (do-next-filler))
- (constant
- (inst ldl lexenv
- (- (ash (tn-offset arg-fun) word-shift)
- other-pointer-lowtag) code-tn)
- (do-next-filler)))
- #!-gengc
- (inst ldl function
- (- (ash closure-fun-slot word-shift)
- fun-pointer-lowtag) lexenv)
- #!-gengc
- (do-next-filler)
- #!-gengc
- (inst addq function
- (- (ash simple-fun-code-offset word-shift)
- fun-pointer-lowtag) entry-point)
- #!+gengc
- (inst ldl entry-point
- (- (ash closure-entry-point-slot word-shift)
- fun-pointer-lowtag) lexenv)
- #!+gengc
- (do-next-filler)))
- (loop
- (if (cdr filler)
- (do-next-filler)
- (return)))
-
- (note-this-location vop :call-site)
- (do-next-filler)
- (inst jsr zero-tn entry-point))
-
- ,@(ecase return
- (:fixed
- '((trace-table-entry trace-table-normal)
- (emit-return-pc lra-label)
- (default-unknown-values vop values nvals
- move-temp temp lra-label)
- (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
- (:unknown
- '((trace-table-entry trace-table-normal)
- (emit-return-pc lra-label)
- (note-this-location vop :unknown-return)
- (receive-unknown-values values-start nvals start count
- lra-label temp)
- (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
- (:tail))))))
+ ,@(unless (eq return :tail)
+ '((lra-label (gen-label))))
+ (filler
+ (remove nil
+ (list :load-nargs
+ ,@(if (eq return :tail)
+ '((unless (location= ocfp ocfp-pass)
+ :load-ocfp)
+ (unless (location= return-pc
+ return-pc-pass)
+ :load-return-pc)
+ (when cur-nfp
+ :frob-nfp))
+ '(#!-gengc
+ :comp-lra
+ (when cur-nfp
+ :frob-nfp)
+ :save-fp
+ :load-fp))))))
+ (flet ((do-next-filler ()
+ (let* ((next (pop filler))
+ (what (if (consp next) (car next) next)))
+ (ecase what
+ (:load-nargs
+ ,@(if variable
+ `((inst subq csp-tn new-fp nargs-pass)
+ ,@(let ((index -1))
+ (mapcar (lambda (name)
+ `(inst ldl ,name
+ ,(ash (incf index)
+ word-shift)
+ new-fp))
+ register-arg-names)))
+ '((inst li (fixnumize nargs) nargs-pass))))
+ ,@(if (eq return :tail)
+ '((:load-ocfp
+ (sc-case ocfp
+ (any-reg
+ (inst move ocfp ocfp-pass))
+ (control-stack
+ (inst ldl ocfp-pass
+ (ash (tn-offset ocfp)
+ word-shift)
+ cfp-tn))))
+ (:load-return-pc
+ (sc-case return-pc
+ (#!-gengc descriptor-reg #!+gengc any-reg
+ (inst move return-pc return-pc-pass))
+ (control-stack
+ (inst ldl return-pc-pass
+ (ash (tn-offset return-pc)
+ word-shift)
+ cfp-tn))))
+ (:frob-nfp
+ (inst addq cur-nfp
+ (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
+ `(#!-gengc
+ (:comp-lra
+ (inst compute-lra-from-code
+ return-pc-pass code-tn lra-label temp))
+ (:frob-nfp
+ (store-stack-tn nfp-save cur-nfp))
+ (:save-fp
+ (inst move cfp-tn ocfp-pass))
+ (:load-fp
+ ,(if variable
+ '(move new-fp cfp-tn)
+ '(if (> nargs register-arg-count)
+ (move new-fp cfp-tn)
+ (move csp-tn cfp-tn)))
+ (trace-table-entry trace-table-call-site))))
+ ((nil))))))
+
+ ,@(if named
+ `((sc-case name
+ (descriptor-reg (move name name-pass))
+ (control-stack
+ (inst ldl name-pass
+ (ash (tn-offset name) word-shift) cfp-tn)
+ (do-next-filler))
+ (constant
+ (inst ldl name-pass
+ (- (ash (tn-offset name) word-shift)
+ other-pointer-lowtag) code-tn)
+ (do-next-filler)))
+ (inst ldl entry-point
+ (- (ash fdefn-raw-addr-slot word-shift)
+ other-pointer-lowtag) name-pass)
+ (do-next-filler))
+ `((sc-case arg-fun
+ (descriptor-reg (move arg-fun lexenv))
+ (control-stack
+ (inst ldl lexenv
+ (ash (tn-offset arg-fun) word-shift) cfp-tn)
+ (do-next-filler))
+ (constant
+ (inst ldl lexenv
+ (- (ash (tn-offset arg-fun) word-shift)
+ other-pointer-lowtag) code-tn)
+ (do-next-filler)))
+ #!-gengc
+ (inst ldl function
+ (- (ash closure-fun-slot word-shift)
+ fun-pointer-lowtag) lexenv)
+ #!-gengc
+ (do-next-filler)
+ #!-gengc
+ (inst addq function
+ (- (ash simple-fun-code-offset word-shift)
+ fun-pointer-lowtag) entry-point)
+ #!+gengc
+ (inst ldl entry-point
+ (- (ash closure-entry-point-slot word-shift)
+ fun-pointer-lowtag) lexenv)
+ #!+gengc
+ (do-next-filler)))
+ (loop
+ (if (cdr filler)
+ (do-next-filler)
+ (return)))
+
+ (note-this-location vop :call-site)
+ (do-next-filler)
+ (inst jsr zero-tn entry-point))
+
+ ,@(ecase return
+ (:fixed
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (default-unknown-values vop values nvals
+ move-temp temp lra-label)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+ (:unknown
+ '((trace-table-entry trace-table-normal)
+ (emit-return-pc lra-label)
+ (note-this-location vop :unknown-return)
+ (receive-unknown-values values-start nvals start count
+ lra-label temp)
+ (maybe-load-stack-nfp-tn cur-nfp nfp-save temp)))
+ (:tail))))))
(define-full-call call nil :fixed nil)
(define-full-call call-named t :fixed nil)
(:temporary (:sc any-reg :offset lexenv-offset :from (:argument 1)) lexenv)
(:temporary (:sc any-reg :offset ocfp-offset :from (:argument 2)) ocfp)
(:temporary (:sc any-reg :offset #!-gengc lra-offset #!+gengc ra-offset
- :from (:argument 3)) lra)
+ :from (:argument 3)) lra)
(:temporary (:scs (non-descriptor-reg)) temp)
(:vop-var vop)
;; Clear the number stack if anything is there.
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
;; And jump to the assembly-routine that does the bliting.
(inst li (make-fixup 'tail-call-variable :assembly-routine) temp)
;;; Return a single value using the unknown-values convention.
(define-vop (return-single)
(:args (ocfp :scs (any-reg))
- #!-gengc (return-pc :scs (descriptor-reg))
- #!+gengc (return-pc :scs (any-reg) :target ra)
- (value))
+ #!-gengc (return-pc :scs (descriptor-reg))
+ #!+gengc (return-pc :scs (any-reg) :target ra)
+ (value))
(:ignore value)
#!-gengc (:temporary (:scs (interior-reg)) lip)
#!+gengc (:temporary (:sc any-reg :offset ra-offset :from (:argument 1)) ra)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
;; Clear the control stack, and restore the frame pointer.
(move cfp-tn csp-tn)
(move ocfp cfp-tn)
(progn
(inst addq return-pc (* 2 n-word-bytes) temp)
(unless (location= ra return-pc)
- (inst move ra return-pc))
+ (inst move ra return-pc))
(inst ret zero-tn temp 1))
(trace-table-entry trace-table-normal)))
;;; values block (which is the beginning of the current frame.)
(define-vop (return)
(:args (ocfp :scs (any-reg))
- (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg)
- :to (:eval 1)
- #!+gengc :target #!+gengc ra)
- (values :more t))
+ (return-pc :scs (#!-gengc descriptor-reg #!+gengc any-reg)
+ :to (:eval 1)
+ #!+gengc :target #!+gengc ra)
+ (values :more t))
(:ignore values)
(:info nvals)
(:temporary (:sc descriptor-reg :offset a0-offset :from (:eval 0)) a0)
(trace-table-entry trace-table-fun-epilogue)
(let ((cur-nfp (current-nfp-tn vop)))
(when cur-nfp
- (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
;; Establish the values pointer and values count.
(move cfp-tn val-ptr)
(inst li (fixnumize nvals) nargs)
;; pre-default any argument register that need it.
(when (< nvals register-arg-count)
(dolist (reg (subseq (list a0 a1 a2 a3 a4 a5) nvals))
- (move null-tn reg)))
+ (move null-tn reg)))
;; And away we go.
(lisp-return return-pc lip)
(trace-table-entry trace-table-normal)))
;;; assembly-routine.
(define-vop (return-multiple)
(:args (ocfp-arg :scs (any-reg) :target ocfp)
- #!-gengc (lra-arg :scs (descriptor-reg) :target lra)
- #!+gengc (return-pc :scs (any-reg) :target ra)
- (vals-arg :scs (any-reg) :target vals)
- (nvals-arg :scs (any-reg) :target nvals))
+ #!-gengc (lra-arg :scs (descriptor-reg) :target lra)
+ #!+gengc (return-pc :scs (any-reg) :target ra)
+ (vals-arg :scs (any-reg) :target vals)
+ (nvals-arg :scs (any-reg) :target nvals))
(:temporary (:sc any-reg :offset nl1-offset :from (:argument 0)) ocfp)
#!-gengc
(let ((not-single (gen-label)))
;; Clear the number stack.
(let ((cur-nfp (current-nfp-tn vop)))
- (when cur-nfp
- (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
- nsp-tn)))
+ (when cur-nfp
+ (inst addq cur-nfp (bytes-needed-for-non-descriptor-stack-frame)
+ nsp-tn)))
;; Check for the single case.
(inst li (fixnumize 1) a0)
(move cfp-tn csp-tn)
(move ocfp-arg cfp-tn)
(lisp-return lra-arg lip :offset 2)
-
+
;; Nope, not the single case.
(emit-label not-single)
(move ocfp-arg ocfp)
;;; Get the lexical environment from its passing location.
(define-vop (setup-closure-environment)
(:temporary (:sc descriptor-reg :offset lexenv-offset :target closure
- :to (:result 0))
- lexenv)
+ :to (:result 0))
+ lexenv)
(:results (closure :scs (descriptor-reg)))
(:info label)
(:ignore label)
(:info fixed)
(:generator 20
(let ((loop (gen-label))
- (do-regs (gen-label))
- (done (gen-label)))
+ (do-regs (gen-label))
+ (done (gen-label)))
(when (< fixed register-arg-count)
- ;; Save a pointer to the results so we can fill in register
- ;; args. We don't need this if there are more fixed args than
- ;; reg args.
- (move csp-tn result))
+ ;; Save a pointer to the results so we can fill in register
+ ;; args. We don't need this if there are more fixed args than
+ ;; reg args.
+ (move csp-tn result))
;; Allocate the space on the stack.
(cond ((zerop fixed)
- (inst addq csp-tn nargs-tn csp-tn)
- (inst beq nargs-tn done))
- (t
- (inst subq nargs-tn (fixnumize fixed) count)
- (inst ble count done)
- (inst addq csp-tn count csp-tn)))
+ (inst addq csp-tn nargs-tn csp-tn)
+ (inst beq nargs-tn done))
+ (t
+ (inst subq nargs-tn (fixnumize fixed) count)
+ (inst ble count done)
+ (inst addq csp-tn count csp-tn)))
(when (< fixed register-arg-count)
- ;; We must stop when we run out of stack args, not when we run
- ;; out of &MORE args.
- (inst subq nargs-tn (fixnumize register-arg-count) count))
+ ;; We must stop when we run out of stack args, not when we run
+ ;; out of &MORE args.
+ (inst subq nargs-tn (fixnumize register-arg-count) count))
;; Initialize dst to be end of stack.
(move csp-tn dst)
;; Everything of interest in registers.
(emit-label do-regs)
(when (< fixed register-arg-count)
- ;; Now we have to deposit any more args that showed up in
- ;; registers. We know there is at least one &MORE arg,
- ;; otherwise we would have branched to DONE up at the top.
- (inst subq nargs-tn (fixnumize (1+ fixed)) count)
- (do ((i fixed (1+ i)))
- ((>= i register-arg-count))
- ;; Store it relative to the pointer saved at the start.
- (storew (nth i *register-arg-tns*) result (- i fixed))
- ;; Is this the last one?
- (inst beq count done)
- ;; Decrement count.
- (inst subq count (fixnumize 1) count)))
+ ;; Now we have to deposit any more args that showed up in
+ ;; registers. We know there is at least one &MORE arg,
+ ;; otherwise we would have branched to DONE up at the top.
+ (inst subq nargs-tn (fixnumize (1+ fixed)) count)
+ (do ((i fixed (1+ i)))
+ ((>= i register-arg-count))
+ ;; Store it relative to the pointer saved at the start.
+ (storew (nth i *register-arg-tns*) result (- i fixed))
+ ;; Is this the last one?
+ (inst beq count done)
+ ;; Decrement count.
+ (inst subq count (fixnumize 1) count)))
(emit-label done))))
;;; &MORE args are stored consecutively on the stack, starting
(define-vop (listify-rest-args)
(:args (context-arg :target context :scs (descriptor-reg))
- (count-arg :target count :scs (any-reg)))
+ (count-arg :target count :scs (any-reg)))
(:arg-types * tagged-num)
(:temporary (:scs (any-reg) :from (:argument 0)) context)
(:temporary (:scs (any-reg) :from (:argument 1)) count)
(pseudo-atomic ()
;; align CSP
(when dx-p (align-csp temp))
- ;; Allocate a cons (2 words) for each item.
- (inst bis alloc-area-tn list-pointer-lowtag result)
- (move result dst)
- (inst sll count 1 temp)
- (inst addq alloc-area-tn temp alloc-area-tn)
- (inst br zero-tn enter)
-
- ;; Store the current cons in the cdr of the previous cons.
- (emit-label loop)
- (inst addq dst (* 2 n-word-bytes) dst)
- (storew dst dst -1 list-pointer-lowtag)
-
- (emit-label enter)
- ;; Grab one value.
- (loadw temp context)
- (inst addq context n-word-bytes context)
-
- ;; Store the value in the car (in delay slot)
- (storew temp dst 0 list-pointer-lowtag)
-
- ;; Decrement count, and if != zero, go back for more.
- (inst subq count (fixnumize 1) count)
- (inst bne count loop)
-
- ;; NIL out the last cons.
- (storew null-tn dst 1 list-pointer-lowtag))
+ ;; Allocate a cons (2 words) for each item.
+ (inst bis alloc-area-tn list-pointer-lowtag result)
+ (move result dst)
+ (inst sll count 1 temp)
+ (inst addq alloc-area-tn temp alloc-area-tn)
+ (inst br zero-tn enter)
+
+ ;; Store the current cons in the cdr of the previous cons.
+ (emit-label loop)
+ (inst addq dst (* 2 n-word-bytes) dst)
+ (storew dst dst -1 list-pointer-lowtag)
+
+ (emit-label enter)
+ ;; Grab one value.
+ (loadw temp context)
+ (inst addq context n-word-bytes context)
+
+ ;; Store the value in the car (in delay slot)
+ (storew temp dst 0 list-pointer-lowtag)
+
+ ;; Decrement count, and if != zero, go back for more.
+ (inst subq count (fixnumize 1) count)
+ (inst bne count loop)
+
+ ;; NIL out the last cons.
+ (storew null-tn dst 1 list-pointer-lowtag))
(emit-label done))))
;;; Return the location and size of the &MORE arg glob created by
(:arg-types tagged-num (:constant fixnum))
(:info fixed)
(:results (context :scs (descriptor-reg))
- (count :scs (any-reg)))
+ (count :scs (any-reg)))
(:result-types t tagged-num)
(:note "more-arg-context")
(:generator 5
(:save-p :compute-only)
(:generator 3
(let ((err-lab
- (generate-error-code vop invalid-arg-count-error nargs)))
+ (generate-error-code vop invalid-arg-count-error nargs)))
(cond ((zerop count)
- (inst bne nargs err-lab))
- (t
- (inst subq nargs (fixnumize count) temp)
- (inst bne temp err-lab))))))
+ (inst bne nargs err-lab))
+ (t
+ (inst subq nargs (fixnumize count) temp)
+ (inst bne temp err-lab))))))
;;; various other error signalers
(macrolet ((frob (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)))))
+ `(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)))))
(frob arg-count-error invalid-arg-count-error
sb!c::%arg-count-error nargs)
(frob type-check-error object-not-type-error sb!c::%type-check-error
projects / sbcl.git / blobdiff