Index: /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp =================================================================== --- /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp (revision 15021) +++ /trunk/source/compiler/X86/X8632/x8632-vinsns.lisp (revision 15022) @@ -252,5 +252,6 @@ (define-x8632-vinsn set-nargs (() - ((n :u16const))) + ((n :u16const)) + ((casualty (:lisp #.x8632::nargs)))) ((:pred = n 0) (xorl (:%l x8632::nargs) (:%l x8632::nargs))) @@ -446,4 +447,21 @@ (cmpl (:$l (:apply target-nil-value)) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + +(define-x8632-vinsn compare-vframe-offset-to-fixnum (() + ((frame-offset :u16const) + (fixval :s32const))) + ((:and (:pred < fixval 128) (:pred >= fixval -128)) + (cmpl (:$b fixval) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + ((:not (:and (:pred < fixval 128) (:pred >= fixval -128))) + (cmpl (:$l fixval) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp))))) + +(define-x8632-vinsn add-constant-to-vframe-offset (() + ((frame-offset :u16const) + (constant :s32const))) + ((:and (:pred < constant 128) (:pred >= constant -128)) + (addl (:$b constant) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp)))) + ((:not (:and (:pred < constant 128) (:pred >= constant -128))) + (addl (:$l constant) (:@ (:apply - (:apply + frame-offset x8632::word-size-in-bytes)) (:%l x8632::ebp))))) + (define-x8632-vinsn compare-value-cell-to-nil (() ((vcell :lisp))) @@ -1013,5 +1031,10 @@ (define-x8632-vinsn zero-extend-u8 (((dest :s32)) ((src :u8))) - (movzbl (:%b src) (:%l dest))) + ((:pred < (:apply %hard-regspec-value src) 4) + (movzbl (:%b src) (:%l dest))) + ((:pred >= (:apply %hard-regspec-value src) 4) + (movl (:%l src) (:%l dest)) + (movzbl (:%b dest) (:%l dest)))) + (define-x8632-vinsn zero-extend-u16 (((dest :s32)) @@ -1942,5 +1965,10 @@ (define-x8632-vinsn u8->u32 (((dest :u32)) ((src :u8))) - (movzbl (:%b src) (:%l dest))) + ((:pred < (:apply %hard-regspec-value src) 4) + (movzbl (:%b src) (:%l dest))) + ((:pred >= (:apply %hard-regspec-value src) 4) + (movl (:%l src) (:%l dest)) + (movzbl (:%b dest) (:%l dest)))) + (define-x8632-vinsn s16->s32 (((dest :s32)) @@ -2711,5 +2739,11 @@ (define-x8632-vinsn mask-base-char (((dest :u8)) ((src :lisp))) - (movzbl (:%b src) (:%l dest))) + ((:pred < (:apply %hard-regspec-value src) 4) + (movzbl (:%b src) (:%l dest))) + ((:pred >= (:apply %hard-regspec-value src) 4) + (movl (:%l src) (:%l dest)) + (movzbl (:%b dest) (:%l dest)))) + + (define-x8632-vinsn event-poll (() @@ -2819,6 +2853,7 @@ (sarl (:$ub x8632::charcode-shift) (:%l dest))) -(define-x8632-vinsn adjust-vsp (() - ((amount :s32const))) +(define-x8632-vinsn (adjust-vsp :vsp :pop :discard) + (() + ((amount :s32const))) ((:and (:pred >= amount -128) (:pred <= amount 127)) (addl (:$b amount) (:%l x8632::esp))) @@ -4027,5 +4062,5 @@ (btrl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x8632::tcr.node-regs-mask))) -(define-x8632-vinsn mark-as-node (() +(define-x8632-vinsn mark-as-node (((reg :imm)) ((reg :imm))) (xorl (:%l reg) (:%l reg)) Index: /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp =================================================================== --- /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 15021) +++ /trunk/source/compiler/X86/X8664/x8664-vinsns.lisp (revision 15022) @@ -548,4 +548,21 @@ (cmpb (:$b x8664::fulltag-nil) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) +(define-x8664-vinsn compare-vframe-offset-to-fixnum (() + ((frame-offset :u16const) + (fixval :s32const))) + ((:and (:pred < fixval 128) (:pred >= fixval -128)) + (cmpq (:$b fixval) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + ((:not (:and (:pred < fixval 128) (:pred >= fixval -128))) + (cmpq (:$l fixval) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp))))) + + +(define-x8664-vinsn add-constant-to-vframe-offset (() + ((frame-offset :u16const) + (constant :s32const))) + ((:and (:pred < constant 128) (:pred >= constant -128)) + (addq (:$b constant) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp)))) + ((:not (:and (:pred < constant 128) (:pred >= constant -128))) + (addq (:$l constant) (:@ (:apply - (:apply + frame-offset x8664::word-size-in-bytes)) (:%q x8664::rbp))))) + (define-x8664-vinsn compare-value-cell-to-nil (() @@ -970,5 +987,6 @@ (movq (:%q car) (:@ x8664::cons.car (:%q allocptr))) (movq (:%q cdr) (:@ x8664::cons.cdr (:%q allocptr))) - (movq (:%q allocptr) (:%q dest))) + ((:pred /= (:apply %hard-regspec-value dest) (:apply %hard-regspec-value x8664::allocptr)) + (movq (:%q allocptr) (:%q dest)))) (define-x8664-vinsn unbox-u8 (((dest :u8)) @@ -3523,6 +3541,7 @@ (sarq (:$ub x8664::charcode-shift) (:%q dest))) -(define-x8664-vinsn adjust-vsp (() - ((amount :s32const))) +(define-x8664-vinsn (adjust-vsp :vsp :pop :discard) + (() + ((amount :s32const))) ((:and (:pred >= amount -128) (:pred <= amount 127)) (addq (:$b amount) (:%q x8664::rsp))) Index: /trunk/source/compiler/X86/x862.lisp =================================================================== --- /trunk/source/compiler/X86/x862.lisp (revision 15021) +++ /trunk/source/compiler/X86/x862.lisp (revision 15022) @@ -226,5 +226,5 @@ (defvar *x862-ra0* nil) (defvar *x862-codecoverage-reg* nil) - +(defvar *x862-variable-shift-count-mask* 0) (defvar *x862-allocptr* nil) @@ -356,4 +356,5 @@ ((addrspec-vcell-p ea) ; closed-over vcell (x862-copy-register seg *x862-arg-z* valreg) + (setq valreg *x862-arg-z*) (let* ((gvector (target-arch-case (:x8632 x8632::temp0) (:x8664 x8664::arg_x)))) @@ -551,4 +552,8 @@ (:x8632 $numx8632saveregs) (:x8664 $numx8664saveregs))) + (*x862-variable-shift-count-mask* (ash 1 (hard-regspec-value + (target-arch-case + (:x8632 x8632::ecx) + (:x8664 x8664::rcx))))) (*x862-target-lcell-size* (arch::target-lisp-node-size (backend-target-arch *target-backend*))) (*x862-target-fixnum-shift* (arch::target-fixnum-shift (backend-target-arch *target-backend*))) @@ -1471,4 +1476,39 @@ (memq offset (svref info reg))) (return reg)))))) + + +(defun x862-reg-for-form (form hint) + (let* ((var (nx2-lexical-reference-p form))) + (cond ((node-reg-p hint) + (if var + (let* ((ea (var-ea var))) + (if (and (memory-spec-p ea) + (not (addrspec-vcell-p ea))) + (let* ((offset (memspec-frame-address-offset ea)) + (mask *x862-gpr-locations-valid-mask*) + (info *x862-gpr-locations*)) + (declare (fixnum mask) (simple-vector info)) + (dotimes (reg 16) + (when (and (logbitp reg mask) + (memq offset (svref info reg))) + (return reg)))) + (if (register-spec-p ea) + ea))) + (if (acode-p (setq form (acode-unwrapped-form form))) + (let* ((op (acode-operator form))) + (if (eql op (%nx1-operator immediate)) + (x862-register-constant-p (cadr form))))))) + ((eql (hard-regspec-class hint) hard-reg-class-fpr) + (when var + (let* ((ea (var-ea var))) + (when (register-spec-p ea) + (and (eql (hard-regspec-class ea) hard-reg-class-fpr) + (eql (get-regspec-mode ea) (get-regspec-mode hint)) + ea)))))))) + +(defun same-x86-reg-p (x y) + (and (eql (%hard-regspec-value x) (%hard-regspec-value y)) + (eql (hard-regspec-class x) (hard-regspec-class y)))) + (defun x862-stack-to-register (seg memspec reg) @@ -3324,28 +3364,47 @@ (x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lreg reg)))) -(defun x862-one-untargeted-reg-form (seg form suggested) - (with-x86-local-vinsn-macros (seg) - (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr)) - (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node)))) - (if node-p - (let* ((ref (x862-lexical-reference-ea form)) - (reg (backend-ea-physical-reg ref hard-reg-class-gpr))) - (if reg - ref - (if (nx-null form) - (progn - (! load-nil suggested) - suggested) - (if (and (acode-p form) - (eq (acode-operator form) (%nx1-operator immediate)) - (setq reg (x862-register-constant-p (cadr form)))) - reg - (x862-one-untargeted-lreg-form seg form suggested))))) - (x862-one-untargeted-lreg-form seg form suggested))))) +;;; If REG is a node reg, add it to the bitmask. +(defun x862-restrict-node-target (reg mask) + (if (node-reg-p reg) + (logior mask (ash 1 (hard-regspec-value reg))) + mask)) + +;;; If suggested reg is a node reg that contains a stack location, +;;; try to use some other node temp. +(defun x862-try-non-conflicting-reg (suggested reserved) + (let* ((mask *x862-gpr-locations-valid-mask*)) + (or (when (and (node-reg-p suggested) + (logbitp (hard-regspec-value suggested) mask)) + (setq mask (logior mask reserved)) + (%available-node-temp (logand *available-backend-node-temps* + (lognot mask)))) + suggested))) + +(defun x862-one-untargeted-reg-form (seg form suggested &optional (reserved 0)) + (or (x862-reg-for-form form suggested) + (with-x86-local-vinsn-macros (seg) + (let* ((gpr-p (= (hard-regspec-class suggested) hard-reg-class-gpr)) + (node-p (if gpr-p (= (get-regspec-mode suggested) hard-reg-class-gpr-mode-node)))) + (if node-p + (let* ((ref (x862-lexical-reference-ea form)) + (reg (backend-ea-physical-reg ref hard-reg-class-gpr))) + (if reg + ref + (let* ((target (x862-try-non-conflicting-reg suggested reserved))) + (if (nx-null form) + (progn + (! load-nil target) + target) + (if (and (acode-p form) + (eq (acode-operator form) (%nx1-operator immediate)) + (setq reg (x862-register-constant-p (cadr form)))) + reg + (x862-one-untargeted-lreg-form seg form target)))))) + (x862-one-untargeted-lreg-form seg form suggested)))))) -(defun x862-push-register (seg areg) +(defun x862-push-register (seg areg &optional inhibit-note) (let* ((a-float (= (hard-regspec-class areg) hard-reg-class-fpr)) (a-single (if a-float (= (get-regspec-mode areg) hard-reg-class-fpr-mode-single))) @@ -3354,5 +3413,5 @@ (with-x86-local-vinsn-macros (seg) (if a-node - (setq vinsn (x862-vpush-register seg areg :node-temp)) + (setq vinsn (x862-vpush-register seg areg :node-temp nil nil inhibit-note)) (if a-single (target-arch-case @@ -3433,7 +3492,6 @@ (popped-reg (svref (vinsn-variable-parts pop-vinsn) 0)) (same-reg (eq (hard-regspec-value pushed-reg) - (hard-regspec-value popped-reg))) - (csp-p (vinsn-attribute-p push-vinsn :csp))) - (when csp-p ; vsp case is harder. + (hard-regspec-value popped-reg)))) + (when (vinsn-attribute-p push-vinsn :csp) (unless (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :csp :discard) (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p @@ -3485,5 +3543,33 @@ (insert-dll-node-before restore pop-vinsn) (elide-vinsn push-vinsn) - (elide-vinsn pop-vinsn))))))))))))) + (elide-vinsn pop-vinsn)))))))))) + (when (and (vinsn-attribute-p push-vinsn :vsp)) + (unless (or + (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :push) + (vinsn-sequence-has-attribute-p push-vinsn pop-vinsn :vsp :pop) + (let* ((pushed-reg-is-set (vinsn-sequence-sets-reg-p + push-vinsn pop-vinsn pushed-reg)) + (popped-reg-is-set (if same-reg + pushed-reg-is-set + (vinsn-sequence-sets-reg-p + push-vinsn pop-vinsn popped-reg))) + (popped-reg-is-reffed (unless same-reg + (vinsn-sequence-refs-reg-p + push-vinsn pop-vinsn popped-reg)))) + (cond ((and (not (and pushed-reg-is-set popped-reg-is-set)) + (or (null popped-reg-is-reffed) + (vinsn-in-sequence-p pushed-reg-is-set popped-reg-is-reffed pop-vinsn))) + (unless same-reg + (let* ((copy (! copy-gpr popped-reg pushed-reg))) + (remove-dll-node copy) + (if popped-reg-is-reffed + (insert-dll-node-after copy popped-reg-is-reffed) + (if pushed-reg-is-set + (insert-dll-node-after copy push-vinsn) + (insert-dll-node-before copy push-vinsn))))) + (elide-vinsn push-vinsn) + (elide-vinsn pop-vinsn)) + (t ; maybe allocate a node temp + ))))))))) @@ -3500,5 +3586,7 @@ (if atriv (x862-one-targeted-reg-form seg aform areg) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (setq apushed (x862-push-register + seg + (x862-one-untargeted-reg-form seg aform areg))))) (x862-one-targeted-reg-form seg bform breg) (if aconst @@ -3508,6 +3596,8 @@ (values areg breg))) - -(defun x862-two-untargeted-reg-forms (seg aform areg bform breg) + +(defun x862-two-untargeted-reg-forms (seg aform areg bform breg &optional (restricted 0)) + (unless (eql restricted 0) + (setq *x862-gpr-locations-valid-mask* (logandc2 *x862-gpr-locations-valid-mask* restricted))) (with-x86-local-vinsn-macros (seg) (let* ((avar (nx2-lexical-reference-p aform)) @@ -3521,10 +3611,22 @@ (unless aconst (if atriv - (setq adest (x862-one-untargeted-reg-form seg aform areg)) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) - (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (progn + (setq adest (x862-one-untargeted-reg-form seg aform areg restricted) + restricted (x862-restrict-node-target adest restricted)) + (when (same-x86-reg-p adest breg) + (setq breg areg))) + (setq apushed (x862-push-register + seg + (x862-one-untargeted-reg-form seg aform areg) + t)))) + (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) + restricted (x862-restrict-node-target bdest restricted)) + (when (same-x86-reg-p bdest areg) + (setq areg breg) + (when apushed + (setq adest areg))) (if aconst - (setq adest (x862-one-untargeted-reg-form seg aform areg)) - (if apushed + (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) + (when apushed (x862-elide-pushes seg apushed (x862-pop-register seg areg))))) (values adest bdest)))) @@ -3558,9 +3660,13 @@ (if atriv (x862-one-targeted-reg-form seg aform areg) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (setq apushed (x862-push-register + seg + (x862-one-targeted-reg-form seg aform areg))))) (if (and bform (not bconst)) (if btriv (x862-one-targeted-reg-form seg bform breg) - (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (setq bpushed (x862-push-register + seg + (x862-one-targeted-reg-form seg bform breg))))) (x862-one-targeted-reg-form seg cform creg) (unless btriv @@ -3618,13 +3724,13 @@ (if atriv (x862-one-targeted-reg-form seg aform areg) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (setq apushed (x862-push-register seg (x862-one-targeted-reg-form seg aform areg))))) (if (and bform (not bconst)) (if btriv (x862-one-targeted-reg-form seg bform breg) - (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (setq bpushed (x862-push-register seg (x862-one-targeted-reg-form seg bform breg))))) (if (and cform (not cconst)) (if ctriv (x862-one-targeted-reg-form seg cform creg) - (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) + (setq cpushed (x862-push-register seg (x862-one-targeted-reg-form seg cform creg))))) (x862-one-targeted-reg-form seg dform dreg) (unless ctriv @@ -3642,5 +3748,5 @@ (values areg breg creg dreg))) -(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg) +(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform creg &optional (restricted 0)) (with-x86-local-vinsn-macros (seg) (let* ((bnode (nx2-node-gpr-p breg)) @@ -3672,22 +3778,52 @@ (if (and aform (not aconst)) (if atriv - (setq adest (x862-one-untargeted-reg-form seg aform ($ areg))) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (progn + (setq adest (x862-one-untargeted-reg-form seg aform ($ areg) restricted) + restricted (x862-restrict-node-target adest restricted)) + (when (same-x86-reg-p adest breg) + (setq breg areg)) + (when (same-x86-reg-p adest creg) + (setq creg areg))) + (setq apushed (x862-push-register + seg + (x862-one-untargeted-reg-form seg aform areg))))) (if (and bform (not bconst)) (if btriv - (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg))) - (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) - (setq cdest (x862-one-untargeted-reg-form seg cform creg)) + (progn + (setq bdest (x862-one-untargeted-reg-form seg bform ($ breg) restricted) + restricted (x862-restrict-node-target bdest restricted)) + (when (same-x86-reg-p bdest creg) + (setq creg breg)) + (when (same-x86-reg-p bdest areg) + (setq areg breg))) + (setq bpushed (x862-push-register + seg (x862-one-untargeted-reg-form seg bform breg))))) + (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) + restricted (x862-restrict-node-target cdest restricted)) + (when (same-x86-reg-p cdest areg) + (setq areg creg) + (when apushed + (setq adest areg))) + (when (same-x86-reg-p cdest breg) + (setq breg creg) + (when bpushed + (setq bdest breg))) (unless btriv (if bconst - (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (progn + (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) + restricted (x862-restrict-node-target bdest restricted)) + (when (same-x86-reg-p bdest areg) + (setq areg breg) + (when apushed + (setq adest areg)))) (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) (unless atriv (if aconst - (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) (values adest bdest cdest)))) -(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg) +(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform creg dform dreg &optional (restricted 0)) (let* ((bnode (nx2-node-gpr-p breg)) (cnode (nx2-node-gpr-p creg)) @@ -3736,26 +3872,69 @@ (if (and aform (not aconst)) (if atriv - (setq adest (x862-one-targeted-reg-form seg aform areg)) - (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform (x862-acc-reg-for areg)))))) + (progn + (setq adest (x862-one-untargeted-reg-form seg aform areg restricted) + restricted (x862-restrict-node-target adest restricted)) + (when (same-x86-reg-p adest breg) + (setq breg areg)) + (when (same-x86-reg-p adest creg) + (setq creg areg)) + (when (same-x86-reg-p adest dreg) + (setq dreg areg))) + (setq apushed (x862-push-register seg (x862-one-untargeted-reg-form seg aform areg))))) (if (and bform (not bconst)) (if btriv - (setq bdest (x862-one-untargeted-reg-form seg bform breg)) - (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform (x862-acc-reg-for breg)))))) + (progn + (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) + restricted (x862-restrict-node-target bdest restricted)) + (when (same-x86-reg-p bdest creg) + (setq creg breg)) + (when (same-x86-reg-p bdest dreg) + (setq dreg breg))) + (setq bpushed (x862-push-register seg (x862-one-untargeted-reg-form seg bform breg))))) (if (and cform (not cconst)) (if ctriv - (setq cdest (x862-one-untargeted-reg-form seg cform creg)) - (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform (x862-acc-reg-for creg)))))) - (setq ddest (x862-one-untargeted-reg-form seg dform dreg)) + (progn + (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) + restricted (x862-restrict-node-target cdest restricted)) + (when (same-x86-reg-p cdest dreg) + (setq dreg creg))) + (setq cpushed (x862-push-register seg (x862-one-untargeted-reg-form seg cform creg))))) + (setq ddest (x862-one-untargeted-reg-form seg dform dreg restricted) + restricted (x862-restrict-node-target ddest restricted)) + (when (same-x86-reg-p ddest areg) + (setq areg dreg) + (when apushed + (setq adest areg))) + (when (same-x86-reg-p ddest breg) + (setq breg dreg) + (when bpushed + (setq bdest breg))) + (when (same-x86-reg-p ddest creg) + (setq creg dreg) + (when cpushed + (setq cdest creg))) (unless ctriv (if cconst - (setq cdest (x862-one-untargeted-reg-form seg cform creg)) + (progn + (setq cdest (x862-one-untargeted-reg-form seg cform creg restricted) + restricted (x862-restrict-node-target cdest restricted)) + (when (same-x86-reg-p cdest breg) + (setq breg creg) + (when bpushed + (setq bdest breg)))) (x862-elide-pushes seg cpushed (x862-pop-register seg creg)))) (unless btriv (if bconst - (setq bdest (x862-one-untargeted-reg-form seg bform breg)) + (progn + (setq bdest (x862-one-untargeted-reg-form seg bform breg restricted) + restricted (x862-restrict-node-target bdest restricted)) + (when (same-x86-reg-p bdest areg) + (setq areg bdest) + (when apushed + (setq adest areg)))) (x862-elide-pushes seg bpushed (x862-pop-register seg breg)))) (unless atriv (if aconst - (setq adest (x862-one-untargeted-reg-form seg aform areg)) + (setq adest (x862-one-untargeted-reg-form seg aform areg restricted)) (x862-elide-pushes seg apushed (x862-pop-register seg areg)))) (values adest bdest cdest ddest))) @@ -3870,9 +4049,13 @@ (x862-compare-u8 seg vreg xfer u8-operand u8 (if (and iu8 (not (eq cr-bit x86::x86-e-bits))) (logxor 1 cr-bit) cr-bit) true-p u8-operator) (if (and boolean (or js32 is32)) - (let* ((reg (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*)) + (let* ((ea (x862-lexical-reference-ea (if js32 i j))) + (offset (and ea (memory-spec-p ea) (memspec-frame-address-offset ea))) + (reg (unless offset (x862-one-untargeted-reg-form seg (if js32 i j) *x862-arg-z*))) (constant (or js32 is32))) - (if (zerop constant) - (! compare-reg-to-zero reg) - (! compare-s32-constant reg (or js32 is32))) + (if offset + (! compare-vframe-offset-to-fixnum offset constant) + (if (zerop constant) + (! compare-reg-to-zero reg) + (! compare-s32-constant reg (or js32 is32)))) (unless (or js32 (eq cr-bit x86::x86-e-bits)) (setq cr-bit (x862-reverse-cr-bit cr-bit))) @@ -4107,9 +4290,10 @@ -(defun x862-vpush-register (seg src &optional why info attr) +(defun x862-vpush-register (seg src &optional why info attr inhibit-note) (with-x86-local-vinsn-macros (seg) (prog1 (! vpush-register src) - (x862-regmap-note-store src *x862-vstack*) + (unless inhibit-note + (x862-regmap-note-store src *x862-vstack*)) (x862-new-vstack-lcell (or why :node) *x862-target-lcell-size* (or attr 0) info) (x862-adjust-vstack *x862-target-node-size*)))) @@ -6589,5 +6773,5 @@ (unless *x862-reckless* (! check-misc-bound i v)) - (with-node-temps (v) (temp) + (with-node-temps (v i) (temp) (! %slot-ref temp v i) (x862-copy-register seg target temp)))) @@ -6647,5 +6831,7 @@ (x862-form seg nil nil y) (x862-form seg nil xfer z)) - (multiple-value-bind (yreg zreg) (x862-two-untargeted-reg-forms seg y *x862-arg-y* z *x862-arg-z*) + (multiple-value-bind (yreg zreg) + (x862-two-untargeted-reg-forms seg y *x862-arg-y* z *x862-arg-z* + (ash 1 (hard-regspec-value *x862-allocptr*))) (ensuring-node-target (target vreg) (! cons target yreg zreg)) @@ -6925,6 +7111,11 @@ (! %ilsl-c target const src) (! lri target 0))) - (multiple-value-bind (count src) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z*) - (! %ilsl target count src)))) + (multiple-value-bind (count src) (x862-two-untargeted-reg-forms seg form1 *x862-arg-y* form2 *x862-arg-z* *x862-variable-shift-count-mask*) + (if (= (ash 1 (hard-regspec-value target)) + *x862-variable-shift-count-mask*) + (progn + (! %ilsl src count src) + (! copy-gpr target src)) + (! %ilsl target count src))))) (^)))) @@ -7152,12 +7343,39 @@ (^))))) +;;; try to use a CISCy instruction for (SETQ stack-var (op stack-var other)). +;;; Don't do this if some register (incidentally) contains the value of EA. +(defun x862-two-address-op (seg vreg xfer ea form) + (when (and (memory-spec-p ea) + (null vreg) + (not (addrspec-vcell-p ea)) + (acode-p (setq form (acode-unwrapped-form form)))) + (let* ((offset (memspec-frame-address-offset ea))) + (unless (x862-register-for-frame-offset ea) + (let* ((op (acode-operator form)) + (constant nil)) + (with-x86-local-vinsn-macros (seg vreg xfer) + (cond ((eql op (%nx1-operator %i+)) + (destructuring-bind (arg1 arg2 &optional check-overflow) + (cdr form) + (unless check-overflow + (when (or + (and (setq constant (acode-s32-constant-p arg1)) + (eql ea (x862-lexical-reference-ea arg2 t))) + (and (setq constant (acode-s32-constant-p arg2)) + (eql ea (x862-lexical-reference-ea arg2 t)))) + (! add-constant-to-vframe-offset offset constant) + (^) + t))))))))))) + + (defx862 x862-setq-lexical setq-lexical (seg vreg xfer varspec form) (let* ((ea (var-ea varspec))) - ;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) - (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) - (or (null vreg) (eq ea vreg))) - ea - *x862-arg-z*)))) - (x862-do-lexical-setq seg vreg ea valreg)) + ;;(unless (fixnump ea) compiler-bug "setq lexical is losing BIG")) + (or (and ea (x862-two-address-op seg vreg xfer ea form)) + (let* ((valreg (x862-one-untargeted-reg-form seg form (if (and (register-spec-p ea) + (or (null vreg) (eq ea vreg))) + ea + *x862-arg-z*)))) + (x862-do-lexical-setq seg vreg ea valreg))) (^))) @@ -8099,5 +8317,10 @@ (x862-one-untargeted-reg-form seg form2 *x862-arg-z*)) (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) - (! %iasr target cnt src)))) + (if (= (ash 1 (hard-regspec-value target)) + *x862-variable-shift-count-mask*) + (progn + (! %iasr src cnt src) + (! copy-gpr target src)) + (! %iasr target cnt src))))) (^)))) @@ -8115,5 +8338,10 @@ (! lri target 0))) (multiple-value-bind (cnt src) (x862-two-targeted-reg-forms seg form1 ($ *x862-arg-y*) form2 ($ *x862-arg-z*)) - (! %ilsr target cnt src)))) + (if (= (ash 1 (hard-regspec-value target)) + *x862-variable-shift-count-mask*) + (progn + (! %ilsr src cnt src) + (! copy-gpr target src)) + (! %ilsr target cnt src))))) (^)))) Index: /trunk/source/compiler/backend.lisp =================================================================== --- /trunk/source/compiler/backend.lisp (revision 15021) +++ /trunk/source/compiler/backend.lisp (revision 15022) @@ -171,13 +171,19 @@ (backend-ea-physical-reg vreg hard-reg-class-crf)) +(defun %available-node-temp (mask) + (unless (eql 0 mask) + (if *backend-allocate-high-node-temps* + (do* ((bit 31 (1- bit))) + ((< bit 0)) + (when (logbitp bit mask) + (return bit))) + (dotimes (bit 32) + (when (logbitp bit mask) + (return bit)))))) + (defun available-node-temp (mask) - (if *backend-allocate-high-node-temps* - (do* ((bit 31 (1- bit))) - ((< bit 0) (error "Bug: ran out of node temp registers.")) - (when (logbitp bit mask) - (return bit))) - (dotimes (bit 32 (error "Bug: ran out of node temp registers.")) - (when (logbitp bit mask) - (return bit))))) + (or (%available-node-temp mask) + (error "Bug: ran out of node temp registers."))) + (defun ensure-node-target (reg) Index: /trunk/source/compiler/vinsn.lisp =================================================================== --- /trunk/source/compiler/vinsn.lisp (revision 15021) +++ /trunk/source/compiler/vinsn.lisp (revision 15022) @@ -77,4 +77,6 @@ (gprs-set 0) (fprs-set 0) + (gprs-read 0) + (fprs-read 0) ) @@ -84,6 +86,10 @@ (let* ((vinsn (alloc-dll-node *vinsn-freelist*))) (loop - ; Sometimes, the compiler seems to return its node list - ; to the freelist without first removing the vinsn-labels in it. + ;; Sometimes, the compiler seems to return its node list + ;; to the freelist without first removing the vinsn-labels in it. + #-bootstrapped (when (and (typep vinsn 'vinsn) + (not (> (uvsize vinsn) 8))) + (setf (pool.data *vinsn-freelist*) nil) + (setq vinsn nil)) (if (or (null vinsn) (typep vinsn 'vinsn)) (return)) (setq vinsn (alloc-dll-node *vinsn-freelist*))) @@ -94,5 +100,7 @@ (vinsn-annotation vinsn) nil (vinsn-gprs-set vinsn) 0 - (vinsn-fprs-set vinsn) 0) + (vinsn-fprs-set vinsn) 0 + (vinsn-gprs-read vinsn) 0 + (vinsn-fprs-read vinsn) 0) vinsn) (%make-vinsn template)))) @@ -359,5 +367,8 @@ (fixup-vinsn-template template opcode-hash-table)) templates)) - + + + + ;;; Could probably split this up and do some arg checking at macroexpand time. (defun match-template-vregs (template vinsn supplied-vregs) @@ -482,4 +493,17 @@ (eq (hard-regspec-value varpart-value) regval))) +(defun vinsn-refs-reg-p (element reg) + (if (typep element 'vinsn) + (if (vinsn-attribute-p element :call) + t + (let* ((class (hard-regspec-class reg)) + (value (hard-regspec-value reg))) + (if (eq class hard-reg-class-gpr) + (logbitp value (vinsn-gprs-read element)) + (if (eq class hard-reg-class-fpr) + ;; The FPR is logically read in the vinsn if it or any + ;; conflicting FPR is physically read in the vinsn. + (logtest (fpr-mask-for-vreg reg) (vinsn-fprs-read element)))))))) + (defun vinsn-sets-reg-p (element reg) (if (typep element 'vinsn) @@ -508,12 +532,23 @@ (setq gprs-set (logior gprs-set (vinsn-gprs-set element)) fprs-set (logior fprs-set (vinsn-fprs-set element)))))))) + + -;;; Return T if any vinsn between START and END (exclusive) sets REG. +;;; If any vinsn between START and END (exclusive) sets REG, return +;;; that vinsn; otherwise, return NIL. (defun vinsn-sequence-sets-reg-p (start end reg) (do* ((element (dll-node-succ start) (dll-node-succ element))) ((eq element end)) (if (vinsn-sets-reg-p element reg) - (return t)))) + (return element)))) +;;; If any vinsn between START and END (exclusive) refs REG, return +;;; the last such vinsn; otherwise, return NIL. +(defun vinsn-sequence-refs-reg-p (start end reg) + (do* ((element (dll-node-pred end) (dll-node-pred element))) + ((eq element start)) + (if (vinsn-refs-reg-p element reg) + (return element)))) + ;;; Return T if any vinsn between START and END (exclusive) has all @@ -523,5 +558,5 @@ ((eq element end)) (when (typep element 'vinsn) - (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)))) + (when (eql attr (logand (vinsn-template-attributes (vinsn-template element)) attr)) (return t))))) @@ -529,5 +564,19 @@ `(%vinsn-sequence-has-attribute-p ,start ,end ,(encode-vinsn-attributes attrs))) - +;;; Return T iff vinsn is between START and END (exclusive). +(defun vinsn-in-sequence-p (vinsn start end) + (do* ((element (dll-node-succ start) (dll-node-succ element))) + ((eq element end)) + (when (eq vinsn element) + (return t)))) + +(defun last-vinsn (seg) + ;; Try to find something that isn't a SOURCE-NOTE. Go ahead. I dare you. + (do* ((element (dll-header-last seg) (dll-node-pred element))) + ((eq element seg)) ;told ya! + (when (typep element 'vinsn) + (return element)))) + + ;;; Flow-graph nodes (FGNs) Index: /trunk/source/compiler/vreg.lisp =================================================================== --- /trunk/source/compiler/vreg.lisp (revision 15021) +++ /trunk/source/compiler/vreg.lisp (revision 15022) @@ -26,4 +26,5 @@ (def-standard-initial-binding *lreg-freelist* (%cons-pool)) + (defstruct (lreg (:print-function print-lreg) @@ -253,7 +254,4 @@ (setf (vinsn-gprs-set vinsn) (logior (vinsn-gprs-set vinsn) (ash 1 gpr)))) -(defun note-vinsn-sets-fpr (vinsn fpr) - (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) (ash 1 fpr)))) - (defun note-vinsn-sets-fpr-lreg (vinsn fpr) (setf (vinsn-fprs-set vinsn) (logior (vinsn-fprs-set vinsn) @@ -263,4 +261,19 @@ :single-float :double-float))))) + +(defun note-vinsn-refs-gpr (vinsn gpr) + (when (and (fboundp 'vinsn-gprs-read) + (> (uvsize vinsn) 8)) + (setf (vinsn-gprs-read vinsn) (logior (vinsn-gprs-read vinsn) (ash 1 gpr))))) + +(defun note-vinsn-refs-fpr-lreg (vinsn fpr) + (when (and (fboundp 'vinsn-gprs-read) + (> (uvsize vinsn) 8)) + (setf (vinsn-fprs-read vinsn) (logior (vinsn-fprs-read vinsn) + (target-fpr-mask (hard-regspec-value fpr) + (if (eql (get-regspec-mode fpr) + hard-reg-class-fpr-mode-single) + :single-float + :double-float)))))) @@ -285,11 +298,17 @@ (:crf (use-crf-temp vreg-value)) ((:u8 :s8 :u16 :s16 :u32 :s32 :u64 :s64 :address) - (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) + (if result-p + (note-vinsn-sets-gpr vinsn vreg-value) + (note-vinsn-refs-gpr vinsn vreg-value)) (use-imm-temp vreg-value)) ((:single-float :double-float) (use-fp-reg vreg) - (when result-p (note-vinsn-sets-fpr-lreg vinsn vreg))) + (if result-p + (note-vinsn-sets-fpr-lreg vinsn vreg) + (note-vinsn-refs-fpr-lreg vinsn vreg))) ((:imm t) - (when result-p (note-vinsn-sets-gpr vinsn vreg-value)) + (if result-p + (note-vinsn-sets-gpr vinsn vreg-value) + (note-vinsn-refs-gpr vinsn vreg-value)) (if (logbitp vreg-value *backend-imm-temps*) (use-imm-temp vreg-value) @@ -297,5 +316,7 @@ (:lisp (use-node-temp vreg-value) - (when result-p (note-vinsn-sets-gpr vinsn vreg-value))) + (if result-p + (note-vinsn-sets-gpr vinsn vreg-value) + (note-vinsn-refs-gpr vinsn vreg-value))) (:extended))) (unless (or (eq class 't) (vreg-ok-for-storage-class vreg class))