[Openmcl-cvs-notifications] r15022 - in /trunk/source/compiler: X86/X8632/x8632-vinsns.lisp X86/X8664/x8664-vinsns.lisp X86/x862.lisp backend.lisp vinsn.lisp vreg.lisp
gb at clozure.com
gb at clozure.com
Thu Oct 13 17:27:43 CDT 2011
Author: gb
Date: Thu Oct 13 17:27:43 2011
New Revision: 15022
Log:
vinsn.lisp: add two new slots to the VINSN struct, to track GPRs and
FPRs read by the VINSN. Deal (crudely) with bootstrapping issues that
this change raises (vreg.lisp loads earlier and there are circular
dependencies there.) Add code to access these new slots, similar to
that which had existed to track register assignments. When looking
to see if a vinsn sequence references a register, return the last
vinsn which does so (not the first.) When testing attributes in
a vinsn sequence in %VINSN-SEQUENCE-HAS-ATTRIBUTE-P, logand the vinsn's
attributes with the supplied "attr" arg, not with nothing: we want to
see if a vinsn has all of the supplied attributes, not test for an exact
match.
vreg.lisp: MATCH-VREG updates the new -refs slots in the vinsn. More
circularity and bootstrapping workarounds.
backend.lisp: %AVAILABLE-NODE-TEMP returns register number or NIL;
AVAILABLE-NODE-TEMP calls it and errs on null return.
x8632-vinsns.lisp: catch a few more cases where we can't access the low
byte of high-numbered GPRs. (Who designed this cpu ?) Add a few
vinsns for comparing fixnums to stack locations and doing fixnum
addition on stack locations. Make sure that MARK-AS-NODE notes that
the argument register is modified.
x8664-vinsns.lisp: comparisons/additions on stack locations.
x862.lisp: a bunch of changes to try to reduce stack traffic a little
more. Do some cases of fixnum comparison/addition directly on stack
locations if the location's value isn't known to be in a GPR. (This
may be faster than a load or load+store and may reduce register
pressure a bit. We do this if the stack location isn't in a register;
the real question is whether we want it to be, possibly more than we
want something that's currently in a register to stay there.) When
loading a set of values into an arbitrary set of registers
(x862-*-untargeted-reg-forms), try to use an unused temporary if the
suggested register contains a stack location value. (Again, the real
question is whether or not it contains a value that we'd prefer keeping
there.) This change means that vinsns generally operate on a wider set
of registers than they had previously and exposed some issues (extracting
the low byte of high-numbered registers on x8632, avoiding conflicts when
some registers have dedicated roles due to hardware (shifts by variable
amounts) or software (consing uses allocptr/temp0).
X862-ELIDE-PUSHES tries to remove speculative pushes/pops on the vstack.
In order for this to work, we have to know whether or not the vinsn sequence
between PUSH Rx and POP Ry references Ry and whether the last such reference
precedes the first assignment (if any) to Rx. (This is why we needed to
track register references in vinsns. A reference to Ry can occur in that
sequence becuause Ry just happens to contain a cached stack location or
other interesting value.)
When these functions (and their cousins, the -targeted-reg-forms
functions) think that they need to push a register, the heuristics
that they use to try to decide between pushing a specific register or
an arbitrary one have changed (and aren't always consistent.) We want
to avoid copies before the push, but also want to elide the push if
possible and want to avoid introducing another copy if we do so.
It's more important to be able to eliminate push/pop pairs than it
is to eliminate a register copy or two, so we should probably think
in those terms.
This stuff is a work in progress; it builds and passes its test suite
on Linuxx8632/64, but it wouldn't be a total shock if bugs were intoduced.
I think that we see fewer load, pushes, and pops (which was the goal)
and more register copies (some of which are probably necessary and some
of which are just kind of silly-looking ...)
Modified:
trunk/source/compiler/X86/X8632/x8632-vinsns.lisp
trunk/source/compiler/X86/X8664/x8664-vinsns.lisp
trunk/source/compiler/X86/x862.lisp
trunk/source/compiler/backend.lisp
trunk/source/compiler/vinsn.lisp
trunk/source/compiler/vreg.lisp
Modified: trunk/source/compiler/X86/X8632/x8632-vinsns.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/X8632/x8632-vinsns.lisp (original)
+++ trunk/source/compiler/X86/X8632/x8632-vinsns.lisp Thu Oct 13 17:27:43 2=
011
@@ -251,7 +251,8 @@
(jmp (:@ x8632::symbol.fcell (:% x8632::fname))))
=
(define-x8632-vinsn set-nargs (()
- ((n :u16const)))
+ ((n :u16const))
+ ((casualty (:lisp #.x8632::nargs))))
((:pred =3D n 0)
(xorl (:%l x8632::nargs) (:%l x8632::nargs)))
((:not (:pred =3D n 0))
@@ -445,6 +446,23 @@
(cur-vsp :u16const)))
(cmpl (:$l (:apply target-nil-value)) (:@ (:apply - (:apply + frame-offs=
et x8632::word-size-in-bytes)) (:%l x8632::ebp))))
=
+
+(define-x8632-vinsn compare-vframe-offset-to-fixnum (()
+ ((frame-offset :u16co=
nst)
+ (fixval :s32const)))
+ ((:and (:pred < fixval 128) (:pred >=3D fixval -128))
+ (cmpl (:$b fixval) (:@ (:apply - (:apply + frame-offset x8632::word-siz=
e-in-bytes)) (:%l x8632::ebp))))
+ ((:not (:and (:pred < fixval 128) (:pred >=3D fixval -128)))
+ (cmpl (:$l fixval) (:@ (:apply - (:apply + frame-offset x8632::word-siz=
e-in-bytes)) (:%l x8632::ebp)))))
+
+(define-x8632-vinsn add-constant-to-vframe-offset (()
+ ((frame-offset :u16cons=
t)
+ (constant :s32const)))
+ ((:and (:pred < constant 128) (:pred >=3D constant -128))
+ (addl (:$b constant) (:@ (:apply - (:apply + frame-offset x8632::word-s=
ize-in-bytes)) (:%l x8632::ebp))))
+ ((:not (:and (:pred < constant 128) (:pred >=3D constant -128)))
+ (addl (:$l constant) (:@ (:apply - (:apply + frame-offset x8632::word-s=
ize-in-bytes)) (:%l x8632::ebp)))))
+
(define-x8632-vinsn compare-value-cell-to-nil (()
((vcell :lisp)))
(cmpl (:$l (:apply target-nil-value)) (:@ x8632::value-cell.value (:%l v=
cell))))
@@ -1012,7 +1030,12 @@
=
(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 >=3D (:apply %hard-regspec-value src) 4)
+ (movl (:%l src) (:%l dest))
+ (movzbl (:%b dest) (:%l dest))))
+ =
=
(define-x8632-vinsn zero-extend-u16 (((dest :s32))
((src :u16)))
@@ -1941,7 +1964,12 @@
=
(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 >=3D (:apply %hard-regspec-value src) 4)
+ (movl (:%l src) (:%l dest))
+ (movzbl (:%b dest) (:%l dest))))
+ =
=
(define-x8632-vinsn s16->s32 (((dest :s32))
((src :s16)))
@@ -2710,7 +2738,13 @@
=
(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 >=3D (:apply %hard-regspec-value src) 4)
+ (movl (:%l src) (:%l dest))
+ (movzbl (:%b dest) (:%l dest))))
+ =
+ =
=
(define-x8632-vinsn event-poll (()
())
@@ -2818,8 +2852,9 @@
(movl (:%l src) (:%l dest))
(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 >=3D amount -128) (:pred <=3D amount 127))
(addl (:$b amount) (:%l x8632::esp)))
((:not (:and (:pred >=3D amount -128) (:pred <=3D amount 127)))
@@ -4026,7 +4061,7 @@
((reg :imm)))
(btrl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x863=
2::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))
(btsl (:$ub (:apply %hard-regspec-value reg)) (:@ (:%seg :rcontext) x863=
2::tcr.node-regs-mask)))
Modified: trunk/source/compiler/X86/X8664/x8664-vinsns.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/X8664/x8664-vinsns.lisp (original)
+++ trunk/source/compiler/X86/X8664/x8664-vinsns.lisp Thu Oct 13 17:27:43 2=
011
@@ -547,6 +547,23 @@
(cur-vsp :u16const)))
(cmpb (:$b x8664::fulltag-nil) (:@ (:apply - (:apply + frame-offset x866=
4::word-size-in-bytes)) (:%q x8664::rbp))))
=
+(define-x8664-vinsn compare-vframe-offset-to-fixnum (()
+ ((frame-offset :u16co=
nst)
+ (fixval :s32const)))
+ ((:and (:pred < fixval 128) (:pred >=3D fixval -128))
+ (cmpq (:$b fixval) (:@ (:apply - (:apply + frame-offset x8664::word-siz=
e-in-bytes)) (:%q x8664::rbp))))
+ ((:not (:and (:pred < fixval 128) (:pred >=3D fixval -128)))
+ (cmpq (:$l fixval) (:@ (:apply - (:apply + frame-offset x8664::word-siz=
e-in-bytes)) (:%q x8664::rbp)))))
+
+
+(define-x8664-vinsn add-constant-to-vframe-offset (()
+ ((frame-offset :u16cons=
t)
+ (constant :s32const)))
+ ((:and (:pred < constant 128) (:pred >=3D constant -128))
+ (addq (:$b constant) (:@ (:apply - (:apply + frame-offset x8664::word-s=
ize-in-bytes)) (:%q x8664::rbp))))
+ ((:not (:and (:pred < constant 128) (:pred >=3D constant -128)))
+ (addq (:$l constant) (:@ (:apply - (:apply + frame-offset x8664::word-s=
ize-in-bytes)) (:%q x8664::rbp)))))
+ =
=
(define-x8664-vinsn compare-value-cell-to-nil (()
((vcell :lisp)))
@@ -969,7 +986,8 @@
(andb (:$b (lognot x8664::fulltagmask)) (:rcontext x8664::tcr.save-alloc=
ptr))
(movq (:%q car) (:@ x8664::cons.car (:%q allocptr)))
(movq (:%q cdr) (:@ x8664::cons.cdr (:%q allocptr)))
- (movq (:%q allocptr) (:%q dest)))
+ ((:pred /=3D (:apply %hard-regspec-value dest) (:apply %hard-regspec-val=
ue x8664::allocptr)) =
+ (movq (:%q allocptr) (:%q dest))))
=
(define-x8664-vinsn unbox-u8 (((dest :u8))
((src :lisp)))
@@ -3522,8 +3540,9 @@
(movq (:%q src) (:%q dest))
(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 >=3D amount -128) (:pred <=3D amount 127))
(addq (:$b amount) (:%q x8664::rsp)))
((:not (:and (:pred >=3D amount -128) (:pred <=3D amount 127)))
Modified: trunk/source/compiler/X86/x862.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/X86/x862.lisp (original)
+++ trunk/source/compiler/X86/x862.lisp Thu Oct 13 17:27:43 2011
@@ -225,7 +225,7 @@
(defvar *x862-fname* nil)
(defvar *x862-ra0* nil)
(defvar *x862-codecoverage-reg* nil)
-
+(defvar *x862-variable-shift-count-mask* 0)
(defvar *x862-allocptr* nil)
=
(defvar *x862-fp0* nil)
@@ -355,6 +355,7 @@
(x862-copy-register seg ea valreg))
((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))))
(x862-stack-to-register seg ea gvector)
@@ -550,6 +551,10 @@
(*x862-target-num-save-regs* (target-arch-case
(: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*)))
(*x862-target-node-shift* (arch::target-word-shift (backend-ta=
rget-arch *target-backend*)))
@@ -1470,6 +1475,41 @@
(when (and (logbitp reg mask)
(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)
(with-x86-local-vinsn-macros (seg)
@@ -3323,37 +3363,56 @@
(defun x862-one-untargeted-lreg-form (seg form reg)
(x862-one-lreg-form seg form (if (typep reg 'lreg) reg (make-unwired-lre=
g reg))))
=
-(defun x862-one-untargeted-reg-form (seg form suggested)
- (with-x86-local-vinsn-macros (seg)
- (let* ((gpr-p (=3D (hard-regspec-class suggested) hard-reg-class-gpr))
- (node-p (if gpr-p (=3D (get-regspec-mode suggested) hard-reg-cl=
ass-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 (reserve=
d 0))
+ (or (x862-reg-for-form form suggested)
+ (with-x86-local-vinsn-macros (seg)
+ (let* ((gpr-p (=3D (hard-regspec-class suggested) hard-reg-class-g=
pr))
+ (node-p (if gpr-p (=3D (get-regspec-mode suggested) hard-re=
g-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 res=
erved)))
+ (if (nx-null form)
+ (progn
+ (! load-nil target)
+ target)
+ (if (and (acode-p form) =
+ (eq (acode-operator form) (%nx1-operator imme=
diate)) =
+ (setq reg (x862-register-constant-p (cadr for=
m))))
+ 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 (=3D (hard-regspec-class areg) hard-reg-class-fpr))
(a-single (if a-float (=3D (get-regspec-mode areg) hard-reg-class=
-fpr-mode-single)))
(a-node (unless a-float (=3D (get-regspec-mode areg) hard-reg-cla=
ss-gpr-mode-node)))
vinsn)
(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 inhib=
it-note))
(if a-single
(target-arch-case
(:x8632
@@ -3432,9 +3491,8 @@
(let* ((pushed-reg (svref (vinsn-variable-parts push-vinsn) 0))
(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
push-vinsn pop-vinsn pushed-reg))
@@ -3484,7 +3542,35 @@
(remove-dll-node restore)
(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-re=
g))
+ (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 popp=
ed-reg))))
+ (cond ((and (not (and pushed-reg-is-set popped-reg-is-s=
et))
+ (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
+ )))))))))
=
=
;;; we never leave the first form pushed (the 68K compiler had some subpri=
ms that
@@ -3499,7 +3585,9 @@
(unless aconst
(if atriv
(x862-one-targeted-reg-form seg aform areg)
- (setq apushed (x862-push-register seg (x862-one-untargeted-reg-f=
orm 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
(x862-one-targeted-reg-form seg aform areg)
@@ -3507,8 +3595,10 @@
(x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
(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-va=
lid-mask* restricted)))
(with-x86-local-vinsn-macros (seg)
(let* ((avar (nx2-lexical-reference-p aform))
(adest areg)
@@ -3520,12 +3610,24 @@
(progn
(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 res=
tricted)
+ 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 restricte=
d)
+ 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 restric=
ted))
+ (when apushed
(x862-elide-pushes seg apushed (x862-pop-register seg areg)))))
(values adest bdest))))
=
@@ -3557,11 +3659,15 @@
(if (and aform (not aconst))
(if atriv
(x862-one-targeted-reg-form seg aform areg)
- (setq apushed (x862-push-register seg (x862-one-untargeted-reg-for=
m 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-for=
m 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 =
(if bconst
@@ -3617,15 +3723,15 @@
(if (and aform (not aconst))
(if atriv
(x862-one-targeted-reg-form seg aform areg)
- (setq apushed (x862-push-register seg (x862-one-untargeted-reg-for=
m 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-for=
m 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-for=
m 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
(if cconst
@@ -3641,7 +3747,7 @@
(x862-elide-pushes seg apushed (x862-pop-register seg areg))))
(values areg breg creg dreg)))
=
-(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform cr=
eg)
+(defun x862-three-untargeted-reg-forms (seg aform areg bform breg cform cr=
eg &optional (restricted 0))
(with-x86-local-vinsn-macros (seg)
(let* ((bnode (nx2-node-gpr-p breg))
(cnode (nx2-node-gpr-p creg))
@@ -3671,24 +3777,54 @@
(bpushed nil))
(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-f=
orm seg aform (x862-acc-reg-for areg))))))
+ (progn
+ (setq adest (x862-one-untargeted-reg-form seg aform ($ areg) r=
estricted)
+ 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-f=
orm 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) r=
estricted)
+ 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 restr=
icted)
+ 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 restric=
ted))
(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 cre=
g dform dreg)
+(defun x862-four-untargeted-reg-forms (seg aform areg bform breg cform cre=
g dform dreg &optional (restricted 0))
(let* ((bnode (nx2-node-gpr-p breg))
(cnode (nx2-node-gpr-p creg))
(dnode (nx2-node-gpr-p dreg))
@@ -3735,28 +3871,71 @@
(cpushed nil))
(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-for=
m seg aform (x862-acc-reg-for areg))))))
+ (progn
+ (setq adest (x862-one-untargeted-reg-form seg aform areg restric=
ted)
+ 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-for=
m 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-for=
m seg bform (x862-acc-reg-for breg))))))
+ (progn
+ (setq bdest (x862-one-untargeted-reg-form seg bform breg restric=
ted)
+ 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-for=
m 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-for=
m 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 restric=
ted)
+ 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-for=
m 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 restric=
ted)
+ 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 restric=
ted)
+ 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 restricte=
d))
(x862-elide-pushes seg apushed (x862-pop-register seg areg))))
(values adest bdest cdest ddest)))
=
@@ -3869,11 +4048,15 @@
(if u8-operator
(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) *x=
862-arg-z*))
+ (let* ((ea (x862-lexical-reference-ea (if js32 i j)))
+ (offset (and ea (memory-spec-p ea) (memspec-frame-addre=
ss-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)))
(^ cr-bit true-p))
@@ -4106,11 +4289,12 @@
addr))))))
=
=
-(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 a=
ttr 0) info)
(x862-adjust-vstack *x862-target-node-size*))))
=
@@ -6588,7 +6772,7 @@
(x862-two-untargeted-reg-forms seg instance *x862-arg-y* idx *x862=
-arg-z*)
(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))))
(^))
@@ -6646,7 +6830,9 @@
(progn
(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-al=
locptr*)))
(ensuring-node-target (target vreg)
(! cons target yreg zreg))
(^))))
@@ -6924,8 +7110,13 @@
(if (<=3D const max)
(! %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 (=3D (ash 1 (hard-regspec-value target))
+ *x862-variable-shift-count-mask*)
+ (progn
+ (! %ilsl src count src)
+ (! copy-gpr target src))
+ (! %ilsl target count src)))))
(^))))
=
(defx862 x862-endp endp (seg vreg xfer cc form)
@@ -7151,14 +7342,41 @@
(x862-do-lexical-reference seg vreg ea-or-form)
(^)))))
=
+;;; 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 ar=
g1))
+ (eql ea (x862-lexical-reference-ea arg2=
t)))
+ (and (setq constant (acode-s32-constant-p ar=
g2))
+ (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 (regist=
er-spec-p ea) =
- (or (nu=
ll 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 (re=
gister-spec-p ea) =
+ (or=
(null vreg) (eq ea vreg)))
+ ea
+ *x862-arg-=
z*))))
+ (x862-do-lexical-setq seg vreg ea valreg)))
(^)))
=
=
@@ -8098,7 +8316,12 @@
(! %iasr-c target (if (> count max) max count)
(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 (=3D (ash 1 (hard-regspec-value target))
+ *x862-variable-shift-count-mask*)
+ (progn
+ (! %iasr src cnt src)
+ (! copy-gpr target src))
+ (! %iasr target cnt src)))))
(^))))
=
(defx862 x862-%ilsr %ilsr (seg vreg xfer form1 form2)
@@ -8114,7 +8337,12 @@
(! %ilsr-c target count src)
(! 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 (=3D (ash 1 (hard-regspec-value target))
+ *x862-variable-shift-count-mask*)
+ (progn
+ (! %ilsr src cnt src)
+ (! copy-gpr target src))
+ (! %ilsr target cnt src)))))
(^))))
=
=
Modified: trunk/source/compiler/backend.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/backend.lisp (original)
+++ trunk/source/compiler/backend.lisp Thu Oct 13 17:27:43 2011
@@ -170,15 +170,21 @@
(defun backend-crf-p (vreg)
(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)
(if (node-reg-p reg)
Modified: trunk/source/compiler/vinsn.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/vinsn.lisp (original)
+++ trunk/source/compiler/vinsn.lisp Thu Oct 13 17:27:43 2011
@@ -76,6 +76,8 @@
annotation
(gprs-set 0)
(fprs-set 0)
+ (gprs-read 0)
+ (fprs-read 0)
)
=
(def-standard-initial-binding *vinsn-freelist* (make-dll-node-freelist))
@@ -83,8 +85,12 @@
(defun make-vinsn (template)
(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*)))
(if vinsn
@@ -93,7 +99,9 @@
(vinsn-variable-parts vinsn) nil
(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))))
=
@@ -358,7 +366,10 @@
(declare (ignore name))
(fixup-vinsn-template template opcode-hash-table))
templates))
- =
+
+
+
+
;;; Could probably split this up and do some arg checking at macroexpand t=
ime.
(defun match-template-vregs (template vinsn supplied-vregs)
(declare (list supplied-vregs))
@@ -481,6 +492,19 @@
(memq spec '(:u32 :s32 :u16 :s16 :u8 :s8 :lisp :address :imm))))
(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)
(if (vinsn-attribute-p element :call)
@@ -507,14 +531,25 @@
(return (values #xffffffff #xffffffff))
(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
;;; attributes set in MASK set.
@@ -522,13 +557,27 @@
(do* ((element (dll-node-succ start) (dll-node-succ element)))
((eq element end))
(when (typep element 'vinsn)
- (when (eql attr (logand (vinsn-template-attributes (vinsn-template e=
lement))))
+ (when (eql attr (logand (vinsn-template-attributes (vinsn-template e=
lement)) attr))
(return t)))))
=
(defmacro vinsn-sequence-has-attribute-p (start end &rest attrs)
`(%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 yo=
u.
+ (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)
=
(defstruct (fgn (:include dll-header))
Modified: trunk/source/compiler/vreg.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/compiler/vreg.lisp (original)
+++ trunk/source/compiler/vreg.lisp Thu Oct 13 17:27:43 2011
@@ -25,6 +25,7 @@
=
(def-standard-initial-binding *lreg-freelist* (%cons-pool))
=
+ =
(defstruct (lreg
(:print-function print-lreg)
(:constructor %make-lreg))
@@ -252,9 +253,6 @@
(defun note-vinsn-sets-gpr (vinsn gpr)
(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)
(target-fpr-mask (hard-regspec-valu=
e fpr)
@@ -262,6 +260,21 @@
hard-reg-=
class-fpr-mode-single)
: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 g=
pr)))))
+
+(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-valu=
e fpr)
+ (if (eql (get-regs=
pec-mode fpr)
+ hard-reg-=
class-fpr-mode-single)
+ :single-float
+ :double-float)))=
)))
=
=
(defun match-vreg (vreg spec vinsn vp n)
@@ -284,19 +297,27 @@
(case class
(: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)
(use-node-temp vreg-value)))
(: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))
(warn "~s was expected to have storage class matching specifie=
r ~s" vreg class))
More information about the Openmcl-cvs-notifications
mailing list