Index: /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp =================================================================== --- /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp (revision 14968) +++ /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp (revision 14969) @@ -1626,4 +1626,9 @@ ) +(define-x8632-vinsn (pass-multiple-values-known-function :jumplr) (((fnreg :lisp)) + ()) + (pushl (:@ (:apply + (:apply target-nil-value) (x8632::%kernel-global 'x86::ret1valaddr)))) + (jmp (:%l fnreg))) + (define-x8632-vinsn reserve-outgoing-frame (() @@ -4179,4 +4184,31 @@ (movsd (:%xmm val) (:@ (:%l base) (:%l idx) 2))) +(define-x8632-vinsn pop-outgoing-arg (((n :u16const)) + ()) + (popl (:@ (:apply * n (- x8632::node-size)) (:%l x8632::ebp)))) + +(define-x8632-vinsn slide-nth-arg (() + ((n :u16const) + (nstackargs :u16const) + (temp :lisp))) + (movl (:@ (:apply * (:apply - nstackargs (:apply + 1 n)) x8632::node-size) (:%l x8632::esp)) (:%l temp)) + (movl (:%l temp) (:@ (:apply * (:apply + n 1) (- x8632::node-size)) (:%l x8632::ebp)))) + +(define-x8632-vinsn set-tail-vsp (((n :u16const)) + ()) + ((:pred = 0 n) + (movl (:%l x8632::ebp) (:%l x8632::esp))) + ((:not (:pred = 0 n)) + (leal (:@ (:apply * n (- x8632::node-size)) (:%l x8632::ebp)) (:%l x8632::esp)))) + +;;; If we've have outgoing arguments in a tail call and are calling +;;; some function (rather than jumping to an internal entry point), we +;;; need to push the caller's return address and unlink its frame +;;; pointer. +(define-x8632-vinsn prepare-tail-call (() + ()) + (pushl (:@ x8632::node-size (:%l x8632::ebp))) + (movl (:@ (:% x8632::ebp)) (:% x8632::ebp))) + (queue-fixup (fixup-x86-vinsn-templates Index: /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 14968) +++ /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 14969) @@ -1781,6 +1781,6 @@ ;;; as well as this. (define-x8664-vinsn (pass-multiple-values :jumplr) (() - () - ((tag :u8))) + () + ((tag :u8))) :resume (movl (:%l x8664::temp0) (:%l tag)) @@ -1797,4 +1797,8 @@ (:anchored-uuo (uuo-error-not-callable))) +(define-x8664-vinsn (pass-multiple-values-known-function :jumplr) (((fnreg :lisp)) + ()) + (pushq (:@ (:apply + (:apply target-nil-value) (x8664::%kernel-global 'x86::ret1valaddr)))) + (jmp (:%q fnreg))) @@ -4598,4 +4602,34 @@ (movsd (:%xmm val) (:@ (:%q base) (:%q idx)))) + +(define-x8664-vinsn pop-outgoing-arg (((n :u16const)) + ()) + (popq (:@ (:apply * n (- x8664::node-size)) (:%q x8664::rbp)))) + +(define-x8664-vinsn slide-nth-arg (() + ((n :u16const) + (nstackargs :u16const) + (temp :lisp))) + (movq (:@ (:apply * (:apply - nstackargs (:apply + 1 n)) x8664::node-size) (:%q x8664::rsp)) (:%q temp)) + (movq (:%q temp) (:@ (:apply * (:apply + n 1) (- x8664::node-size)) (:%q x8664::rbp)))) + + +(define-x8664-vinsn set-tail-vsp (((nargs :u16const)) + ()) + ((:pred = 0 nargs) + (movq (:%q x8664::rbp) (:%q x8664::rsp))) + ((:not (:pred = 0 nargs)) + (leaq (:@ (:apply * nargs (- x8664::node-size)) (:%q x8664::rbp)) (:%q x8664::rsp)))) + + +;;; If we've used one of the fixed-stack-args !slideN vinsns above +;;; and are calling some function (rather than jumping to an internal +;;; entry point), we need to push the caller's return address and unlink +;;; its frame pointer. +(define-x8664-vinsn prepare-tail-call (() + ()) + (pushq (:@ x8664::node-size (:%q x8664::rbp))) + (movq (:@ (:%q x8664::rbp)) (:%q x8664::rbp))) + (queue-fixup (fixup-x86-vinsn-templates Index: /trunk/source/compiler/X86/x862.lisp =================================================================== --- /trunk/source/compiler/X86/x862.lisp (revision 14968) +++ /trunk/source/compiler/X86/x862.lisp (revision 14969) @@ -194,4 +194,6 @@ (defvar *x862-entry-vstack* nil) (defvar *x862-fixed-nargs* nil) +(defvar *x862-fixed-self-call-label* nil) +(defvar *x862-fixed-self-tail-call-label* nil) (defvar *x862-need-nargs* t) @@ -611,4 +613,6 @@ (*x862-entry-vstack* nil) (*x862-fixed-nargs* nil) + (*x862-fixed-self-call-label* nil) + (*x862-fixed-self-tail-call-label* nil) (*x862-need-nargs* t) (fname (afunc-name afunc)) @@ -1176,9 +1180,12 @@ (declare (type (unsigned-byte 16) nargs)) (unless variable-args-entry + (setq *x862-fixed-nargs* nargs) + (@ (setq *x862-fixed-self-call-label* (backend-get-next-label))) (if (<= nargs *x862-target-num-arg-regs*) ; caller didn't vpush anything (! save-lisp-context-no-stack-args) (let* ((offset (* (the fixnum (- nargs *x862-target-num-arg-regs*)) *x862-target-node-size*))) (declare (fixnum offset)) - (! save-lisp-context-offset offset)))) + (! save-lisp-context-offset offset))) + (@ (setq *x862-fixed-self-tail-call-label* (backend-get-next-label)))) (target-arch-case (:x8632 @@ -2811,5 +2818,5 @@ (x862-vpush-register seg (x862-one-untargeted-reg-form seg fn *x862-arg-z*)) (setq fn (x862-vloc-ea vstack))) - (x862-invoke-fn seg fn (x862-arglist seg arglist mv-return-label) spread-p xfer mv-return-label) + (x862-invoke-fn seg fn (x862-arglist seg arglist mv-return-label (x862-tailcallok xfer)) spread-p xfer mv-return-label) (if (and (logbitp $backend-mvpass-bit xfer) (not simple-case)) @@ -2849,4 +2856,29 @@ (! jump-known-symbol) (! call-known-symbol *x862-arg-z*)))) + +(defun x862-self-call (seg nargs tail-p) + (with-x86-local-vinsn-macros (seg) + (cond ((and tail-p + (eql nargs *x862-fixed-nargs*) + (or *x862-open-code-inline* + (<= nargs (+ 3 *x862-target-num-arg-regs*))) + *x862-fixed-self-tail-call-label*) + ;; We can probably do better than popping the nvrs + ;; and then jumping to a point where we push them again ... + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (<= nargs *x862-target-num-arg-regs*)) + (let* ((nstack (- nargs *x862-target-num-arg-regs*))) + (declare (fixnum nstack)) + (if (< nstack 0) (setq nstack 0)) + (do* ((n nstack (1- n))) + ((= n 0) (! set-tail-vsp nstack)) + (declare (fixnum n)) + (! pop-outgoing-arg n)) + (-> *x862-fixed-self-tail-call-label*)) + t) + ((and (not tail-p) + (eql nargs *x862-fixed-nargs*) + *x862-fixed-self-call-label*) + (! call-label (aref *backend-labels* *x862-fixed-self-call-label*)) + t)))) ;;; Nargs = nil -> multiple-value case. @@ -2869,121 +2901,162 @@ (destreg (if symp ($ *x862-fname*) (unless label-p ($ *x862-temp0*)))) (alternate-tail-call - (and tail-p label-p *x862-tail-label* (eql nargs *x862-tail-nargs*) (not spread-p)))) - (when expression-p - ;;Have to do this before spread args, since might be vsp-relative. - (if nargs - (x862-do-lexical-reference seg destreg fn) - (x862-copy-register seg destreg fn))) - (if (or symp lfunp) - (setq func (if symp - (x862-symbol-entry-locative func) - (x862-afunc-lfun-ref func)) - a-reg (x862-register-constant-p func))) - (when tail-p - #-no-compiler-bugs - (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well. How could this have happened ?")) - (when a-reg - (x862-copy-register seg destreg a-reg)) - (unless spread-p - (unless alternate-tail-call - (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (and nargs (<= nargs *x862-target-num-arg-regs*)))))) - (if spread-p - (progn - (x862-set-nargs seg (%i- nargs 1)) - ; .SPspread-lexpr-z & .SPspreadargz preserve temp1 - (target-arch-case - (:x8632 - (! save-node-register-to-spill-area *x862-temp0*))) - (if (eq spread-p 0) - (! spread-lexpr) - (! spread-list)) - (target-arch-case - (:x8632 - (! load-node-register-from-spill-area *x862-temp0*))) - - (when (and tail-p *x862-register-restore-count*) - (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* nil))) - (if nargs - (unless alternate-tail-call (x862-set-nargs seg nargs)) - (! pop-argument-registers))) - (if callable - (if (not tail-p) - (if (x862-mvpass-p xfer) - (let* ((call-reg (if symp ($ *x862-fname*) ($ *x862-temp0*)))) - (unless mvpass-label (compiler-bug "no label for mvpass")) - (if label-p - (x862-copy-register seg call-reg ($ *x862-fn*)) - (if a-reg - (x862-copy-register seg call-reg a-reg) - (x862-store-immediate seg func call-reg))) - (if symp - (! pass-multiple-values-symbol) - (! pass-multiple-values)) - (when mvpass-label - (@= mvpass-label))) - (progn - (if label-p - (progn - (! call-label (aref *backend-labels* 2))) - (progn - (if a-reg - (x862-copy-register seg destreg a-reg) - (x862-store-immediate seg func destreg)) - (if symp - (x862-call-symbol seg nil) - (! call-known-function)))))) - (if alternate-tail-call - (progn - (x862-unwind-stack seg xfer 0 0 *x862-tail-vsp*) - (! jump (aref *backend-labels* *x862-tail-label*))) - (progn - (x862-unwind-stack seg xfer 0 0 #x7fffff) - (if (and (not spread-p) nargs (%i<= nargs *x862-target-num-arg-regs*)) - (progn - (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) - (x862-restore-full-lisp-context seg) - (if label-p - (! jump (aref *backend-labels* 1)) - (progn + (and tail-p label-p *x862-tail-label* (eql nargs *x862-tail-nargs*) (not spread-p))) + (set-nargs-vinsn nil)) + (or (and label-p nargs (not spread-p) (not (x862-mvpass-p xfer)) + (not alternate-tail-call) + (x862-self-call seg nargs tail-p)) + (progn + (when expression-p + ;;Have to do this before spread args, since might be vsp-relative. + (if nargs + (x862-do-lexical-reference seg destreg fn) + (x862-copy-register seg destreg fn))) + (if (or symp lfunp) + (setq func (if symp + (x862-symbol-entry-locative func) + (x862-afunc-lfun-ref func)) + a-reg (x862-register-constant-p func))) + (when tail-p + #-no-compiler-bugs + (unless (or immp symp lfunp (typep fn 'lreg) (fixnump fn)) (compiler-bug "Well, well, well. How could this have happened ?")) + (when a-reg + (x862-copy-register seg destreg a-reg)) + (unless spread-p + (unless alternate-tail-call + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* (and nargs (<= nargs *x862-target-num-arg-regs*)))))) + (if spread-p + (progn + (x862-set-nargs seg (%i- nargs 1)) + ;; .SPspread-lexpr-z & .SPspreadargz preserve temp1 + (target-arch-case + (:x8632 + (! save-node-register-to-spill-area *x862-temp0*))) + (if (eq spread-p 0) + (! spread-lexpr) + (! spread-list)) + (target-arch-case + (:x8632 + (! load-node-register-from-spill-area *x862-temp0*))) + + (when (and tail-p *x862-register-restore-count*) + (x862-restore-nvrs seg *x862-register-restore-ea* *x862-register-restore-count* nil))) + (if nargs + (unless alternate-tail-call + (setq set-nargs-vinsn (x862-set-nargs seg nargs))) + (! pop-argument-registers))) + (if callable + (if (not tail-p) + (if (x862-mvpass-p xfer) + (let* ((call-reg (if label-p ($ *x862-fn*) (if symp ($ *x862-fname*) ($ *x862-temp0*))))) + (unless mvpass-label (compiler-bug "no label for mvpass")) + (unless label-p + (if a-reg + (x862-copy-register seg call-reg a-reg) + (x862-store-immediate seg func call-reg))) + (if label-p + (! pass-multiple-values-known-function call-reg) (if symp - (x862-call-symbol seg t) - (! jump-known-function))))) - (progn - (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) - (when label-p - (x862-copy-register seg *x862-temp0* *x862-fn*)) - - (cond ((or spread-p (null nargs)) - (if symp - (! tail-call-sym-gen) - (! tail-call-fn-gen))) + (! pass-multiple-values-symbol) + (! pass-multiple-values))) + (when mvpass-label + (@= mvpass-label))) + (progn + (if label-p + (progn + (! call-label (aref *backend-labels* 2))) + (progn + (if a-reg + (x862-copy-register seg destreg a-reg) + (x862-store-immediate seg func destreg)) + (if symp + (x862-call-symbol seg nil) + (! call-known-function)))))) + (if alternate-tail-call + (progn + (x862-unwind-stack seg xfer 0 0 *x862-tail-vsp*) + (! jump (aref *backend-labels* *x862-tail-label*))) + (progn + (x862-unwind-stack seg xfer 0 0 #x7fffff) + (if (and (not spread-p) nargs (%i<= nargs *x862-target-num-arg-regs*)) + (progn + (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) + (x862-restore-full-lisp-context seg) + (if label-p + (! jump (aref *backend-labels* 1)) + (progn + (if symp + (x862-call-symbol seg t) + (! jump-known-function))))) + (progn + (unless (or label-p a-reg) (x862-store-immediate seg func destreg)) + (when label-p + (x862-copy-register seg *x862-temp0* *x862-fn*)) + + (cond ((or spread-p (null nargs)) + (if symp + (! tail-call-sym-gen) + (! tail-call-fn-gen))) + ((%i> nargs *x862-target-num-arg-regs*) + (let* ((nstackargs (- nargs *x862-target-num-arg-regs*))) + (if (and (or *x862-open-code-inline* + (<= nstackargs 3))) + (let* ((nstackbytes (ash nstackargs *x862-target-node-shift*))) + (unless (= nstackbytes *x862-vstack*) + (if (>= *x862-vstack* (ash nstackbytes 1)) + ;; If there's room in the caller's + ;; frame beneath the outgoing args, + ;; pop them. This avoids the use + ;; of a temp reg, but can't deal + ;; with the overlap situation if + ;; that constraint isn't met. + (do* ((n nstackargs (1- n))) + ((= n 0)) + (declare (fixnum n)) + (! pop-outgoing-arg n)) + (let* ((temp + (target-arch-case + (:x8664 ($ x8664::temp2)) + (:x8632 ($ x8632::temp1))))) + + (dotimes (i nstackargs) + (! slide-nth-arg i nstackargs temp)) + (target-arch-case + (:x8632 + ;; x8632::temp1 = x8632::nargs + (remove-dll-node set-nargs-vinsn) + (! set-nargs nargs))))) + (! set-tail-vsp nstackargs)) + (! prepare-tail-call) + (if symp + (! jump-known-symbol) + (! jump-known-function))) + (if symp + (! tail-call-sym-slide) + (! tail-call-fn-slide))))) + (t + (! restore-full-lisp-context) + (if symp + (! jump-known-symbol) + (! jump-known-function))))))))) + ;; The general (funcall) case: we don't know (at compile-time) + ;; for sure whether we've got a symbol or a (local, constant) + ;; function. + (progn + (unless (or (fixnump fn) (typep fn 'lreg)) + (x862-one-targeted-reg-form seg fn destreg)) + (if (not tail-p) + (if (x862-mvpass-p xfer) + (progn (! pass-multiple-values) + (when mvpass-label + (@= mvpass-label))) + (! funcall)) + (cond ((or (null nargs) spread-p) + (! tail-funcall-gen)) ((%i> nargs *x862-target-num-arg-regs*) - (if symp - (! tail-call-sym-slide) - (! tail-call-fn-slide))) + (! tail-funcall-slide)) (t - (if symp - (! tail-call-sym-vsp) - (! tail-call-fn-vsp))))))))) - ;; The general (funcall) case: we don't know (at compile-time) - ;; for sure whether we've got a symbol or a (local, constant) - ;; function. - (progn - (unless (or (fixnump fn) (typep fn 'lreg)) - (x862-one-targeted-reg-form seg fn destreg)) - (if (not tail-p) - (if (x862-mvpass-p xfer) - (progn (! pass-multiple-values) - (when mvpass-label - (@= mvpass-label))) - (! funcall)) - (cond ((or (null nargs) spread-p) - (! tail-funcall-gen)) - ((%i> nargs *x862-target-num-arg-regs*) - (! tail-funcall-slide)) - (t - (! restore-full-lisp-context) - (! tail-funcall))))))) - nil)) + (! restore-full-lisp-context) + (! tail-funcall)))))))) + nil))) (defun x862-seq-fbind (seg vreg xfer vars afuncs body p2decls) @@ -3194,9 +3267,9 @@ n))) -(defun x862-arglist (seg args &optional mv-label) +(defun x862-arglist (seg args &optional mv-label suppress-frame-reservation) (with-x86-local-vinsn-macros (seg) (when mv-label (x862-vpush-label seg (aref *backend-labels* mv-label))) - (when (car args) + (when (and (car args) (not suppress-frame-reservation)) (! reserve-outgoing-frame) (x862-new-vstack-lcell :reserved *x862-target-lcell-size* 0 nil)