From: Juho S. <js...@us...> - 2004-12-16 22:49:37
|
Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv28805/src/compiler/x86-64 Modified Files: Tag: x86-64-again-branch cell.lisp memory.lisp move.lisp pred.lisp sap.lisp Log Message: 0.8.15.14.x86-64-again-branch.36: * Fix large immediate handling in IF-EQ (patch by Cheuksan Edward Wang) and SAP+. * Rewrite MOVE-IMMEDIATE to use a temporary register for too large immediates instead of shifts and ors. * Use MOVE-IMMEDIATE in more VOPs for some OAOO goodness. Index: cell.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/cell.lisp,v retrieving revision 1.1.8.1 retrieving revision 1.1.8.2 diff -u -d -r1.1.8.1 -r1.1.8.2 --- cell.lisp 8 Dec 2004 23:25:26 -0000 1.1.8.1 +++ cell.lisp 16 Dec 2004 22:49:18 -0000 1.1.8.2 @@ -29,36 +29,23 @@ (:ignore name) (:results) (:generator 1 - (if (sc-is value immediate) + (if (sc-is value immediate) (let ((val (tn-value value))) - (etypecase val - (integer - (let ((fixnumized (fixnumize val))) - (if (typep fixnumized - '(or (signed-byte 32) (unsigned-byte 31))) - ;; MOV here can only deal with 32 bit immediates - (inst mov - (make-ea :qword :base object - :disp (- (* offset n-word-bytes) lowtag)) - fixnumized) - (progn - (inst mov temp fixnumized) - (inst mov (make-ea :qword :base object - :disp (- (* offset n-word-bytes) lowtag)) - temp))))) - (symbol - (inst mov - (make-ea :qword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (+ nil-value (static-symbol-offset val)))) - (character - (inst mov - (make-ea :qword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (logior (ash (char-code val) n-widetag-bits) - base-char-widetag))))) - ;; Else, value not immediate. - (storew value object offset lowtag)))) + (move-immediate (make-ea :qword + :base object + :disp (- (* offset n-word-bytes) + lowtag)) + (etypecase val + (integer + (fixnumize val)) + (symbol + (+ nil-value (static-symbol-offset val))) + (character + (logior (ash (char-code val) n-widetag-bits) + base-char-widetag))) + temp)) + ;; Else, value not immediate. + (storew value object offset lowtag)))) Index: memory.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/memory.lisp,v retrieving revision 1.1 retrieving revision 1.1.8.1 diff -u -d -r1.1 -r1.1.8.1 --- memory.lisp 26 Jun 2004 17:48:22 -0000 1.1 +++ memory.lisp 16 Dec 2004 22:49:18 -0000 1.1.8.1 @@ -95,28 +95,24 @@ (define-vop (slot-set) (:args (object :scs (descriptor-reg)) (value :scs (descriptor-reg any-reg immediate))) + (:temporary (:sc unsigned-reg) temp) (:variant-vars base lowtag) (:info offset) (:generator 4 (if (sc-is value immediate) (let ((val (tn-value value))) - (etypecase val - (integer - (inst mov - (make-ea :dword :base object - :disp (- (* (+ base offset) n-word-bytes) lowtag)) - (fixnumize val))) - (symbol - (inst mov - (make-ea :dword :base object - :disp (- (* (+ base offset) n-word-bytes) lowtag)) - (+ nil-value (static-symbol-offset val)))) - (character - (inst mov - (make-ea :dword :base object - :disp (- (* (+ base offset) n-word-bytes) lowtag)) - (logior (ash (char-code val) n-widetag-bits) - base-char-widetag))))) + (move-immediate (make-ea :qword :base object + :disp (- (* (+ base offset) n-word-bytes) + lowtag)) + (etypecase val + (integer + (fixnumize val)) + (symbol + (+ nil-value (static-symbol-offset val))) + (character + (logior (ash (char-code val) n-widetag-bits) + base-char-widetag))) + temp)) ;; Else, value not immediate. (storew value object (+ base offset) lowtag)))) Index: move.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/move.lisp,v retrieving revision 1.1.8.5 retrieving revision 1.1.8.6 diff -u -d -r1.1.8.5 -r1.1.8.6 --- move.lisp 12 Dec 2004 06:37:22 -0000 1.1.8.5 +++ move.lisp 16 Dec 2004 22:49:18 -0000 1.1.8.6 @@ -67,6 +67,7 @@ (not (or (location= x y) (and (sc-is x any-reg descriptor-reg immediate) (sc-is y control-stack)))))) + (:temporary (:sc unsigned-reg) temp) (:effects) (:affected) (:generator 0 @@ -77,13 +78,13 @@ (integer (if (and (zerop val) (sc-is y any-reg descriptor-reg)) (inst xor y y) - (move-immediate y (fixnumize val)))) + (move-immediate y (fixnumize val) temp))) (symbol (inst mov y (+ nil-value (static-symbol-offset val)))) (character (inst mov y (logior (ash (char-code val) n-widetag-bits) base-char-widetag))))) - (move y x)))) + (move y x)))) (define-move-vop move :move (any-reg descriptor-reg immediate) @@ -94,32 +95,21 @@ ;;; few of the values in a continuation to fall out. (primitive-type-vop move (:check) t) -(defun move-immediate (target val) - (multiple-value-bind (lo hi) - (dwords-for-quad val) - (cond ((and (zerop hi) (typep lo '(signed-byte 31))) - (inst mov target lo)) - ((typep lo '(signed-byte 31)) - (inst mov target hi) - (inst shl target 32) - (inst or target lo)) - ;; High bit set in lower dword, need to set the high and low - ;; words of the low dword separately due to sign extension - ;; of immediate arguments. - ((zerop hi) - (multiple-value-bind (lo-lo lo-hi) - (words-for-dword lo) - (inst mov target lo-hi) - (inst shl target 16) - (inst or target lo-lo))) - (t - (multiple-value-bind (lo-lo lo-hi) - (words-for-dword lo) - (inst mov target hi) - (inst shl target 16) - (inst or target lo-hi) - (inst shl target 16) - (inst or target lo-lo)))))) +(defun move-immediate (target val &optional tmp-tn) + (cond + ;; If target is a register, we can just mov it there directly + ((and (tn-p target) + (sc-is target signed-reg unsigned-reg descriptor-reg any-reg)) + (inst mov target val)) + ;; Likewise if the value is small enough. + ((typep val '(signed-byte 31)) + (inst mov target val)) + ;; Otherwise go through the temporary register + (tmp-tn + (inst mov tmp-tn val) + (inst mov target tmp-tn)) + (t + (error "~A is not a register, no temporary given, and immediate ~A too large" target val)))) ;;; The MOVE-ARG VOP is used for moving descriptor values into ;;; another frame for argument or known value passing. Index: pred.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/pred.lisp,v retrieving revision 1.1 retrieving revision 1.1.8.1 diff -u -d -r1.1 -r1.1.8.1 --- pred.lisp 26 Jun 2004 17:48:22 -0000 1.1 +++ pred.lisp 16 Dec 2004 22:49:18 -0000 1.1.8.1 @@ -33,6 +33,7 @@ (y :scs (any-reg descriptor-reg immediate) :load-if (not (and (sc-is x any-reg descriptor-reg immediate) (sc-is y control-stack constant))))) + (:temporary (:sc descriptor-reg) temp) (:conditional) (:info target not-p) (:policy :fast-safe) @@ -45,7 +46,13 @@ (integer (if (and (zerop val) (sc-is x any-reg descriptor-reg)) (inst test x x) ; smaller - (inst cmp x (fixnumize val)))) + (let ((fixnumized (fixnumize val))) + (if (typep fixnumized + '(or (signed-byte 32) (unsigned-byte 31))) + (inst cmp x fixnumized) + (progn + (inst mov temp fixnumized) + (inst cmp x temp)))))) (symbol (inst cmp x (+ nil-value (static-symbol-offset val)))) (character @@ -58,7 +65,13 @@ (integer (if (and (zerop val) (sc-is y any-reg descriptor-reg)) (inst test y y) ; smaller - (inst cmp y (fixnumize val)))) + (let ((fixnumized (fixnumize val))) + (if (typep fixnumized + '(or (signed-byte 32) (unsigned-byte 31))) + (inst cmp y fixnumized) + (progn + (inst mov temp fixnumized) + (inst cmp y temp)))))) (symbol (inst cmp y (+ nil-value (static-symbol-offset val)))) (character Index: sap.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/sap.lisp,v retrieving revision 1.1 retrieving revision 1.1.8.1 diff -u -d -r1.1 -r1.1.8.1 --- sap.lisp 26 Jun 2004 17:48:22 -0000 1.1 +++ sap.lisp 16 Dec 2004 22:49:18 -0000 1.1.8.1 @@ -112,6 +112,7 @@ (:results (res :scs (sap-reg) :from (:argument 0) :load-if (not (location= ptr res)))) (:result-types system-area-pointer) + (:temporary (:sc signed-reg) temp) (:policy :fast-safe) (:generator 1 (cond ((and (sc-is ptr sap-reg) (sc-is res sap-reg) @@ -120,15 +121,26 @@ (signed-reg (inst lea res (make-ea :qword :base ptr :index offset :scale 1))) (immediate - (inst lea res (make-ea :qword :base ptr - :disp (tn-value offset)))))) + (let ((value (tn-value offset))) + (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31))) + (inst lea res (make-ea :qword :base ptr :disp value))) + (t + (inst mov temp value) + (inst lea res (make-ea :qword :base ptr + :index temp + :scale 1)))))))) (t (move res ptr) (sc-case offset (signed-reg (inst add res offset)) (immediate - (inst add res (tn-value offset)))))))) + (let ((value (tn-value offset))) + (cond ((typep value '(or (signed-byte 32) (unsigned-byte 31))) + (inst add res (tn-value offset))) + (t + (inst mov temp value) + (inst add res temp)))))))))) (define-vop (pointer-) (:translate sap-) |