Menu
▾
▴
[Sbcl-commits] CVS: sbcl/src/compiler/x86-64 cell.lisp,1.1,1.1.8.1 char.lisp,1.1.8.1,1.1.8.2 type-vops.lisp,1.1.8.7,1.1.8.8
|
From: Juho S. <js...@us...> - 2004-12-08 23:25:39
|
Update of /cvsroot/sbcl/sbcl/src/compiler/x86-64 In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv19446/src/compiler/x86-64 Modified Files: Tag: x86-64-again-branch cell.lisp char.lisp type-vops.lisp Log Message: 0.8.15.14.x86-64-again-branch.30: * Add size data for all specialized array types in *META-ROOM-INFO*, to fix ROOM and SB-SPROF. * SET-SLOT tried to mov 64-bit immediates into an EA. Patch provided by Cheuksan Edward Wang. * Remove R[ABCD]X/[ABCD]L punning where possible. Extend punning to cover all qword/byte register pairs where it can't be removed. Index: cell.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/cell.lisp,v retrieving revision 1.1 retrieving revision 1.1.8.1 diff -u -d -r1.1 -r1.1.8.1 --- cell.lisp 26 Jun 2004 17:48:22 -0000 1.1 +++ cell.lisp 8 Dec 2004 23:25:26 -0000 1.1.8.1 @@ -24,6 +24,7 @@ (define-vop (set-slot) (:args (object :scs (descriptor-reg)) (value :scs (descriptor-reg any-reg immediate))) + (:temporary (:sc descriptor-reg) temp) (:info name offset lowtag) (:ignore name) (:results) @@ -32,18 +33,27 @@ (let ((val (tn-value value))) (etypecase val (integer - (inst mov - (make-ea :dword :base object - :disp (- (* offset n-word-bytes) lowtag)) - (fixnumize val))) + (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 :dword :base object + (make-ea :qword :base object :disp (- (* offset n-word-bytes) lowtag)) (+ nil-value (static-symbol-offset val)))) (character (inst mov - (make-ea :dword :base object + (make-ea :qword :base object :disp (- (* offset n-word-bytes) lowtag)) (logior (ash (char-code val) n-widetag-bits) base-char-widetag))))) Index: char.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/char.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 --- char.lisp 24 Nov 2004 20:02:00 -0000 1.1.8.1 +++ char.lisp 8 Dec 2004 23:25:26 -0000 1.1.8.2 @@ -21,8 +21,7 @@ (:generator 1 (let ((y-wide-tn (make-random-tn :kind :normal - :sc (gethash 'any-reg - sb!c::*backend-meta-sc-names*) + :sc (sc-or-lose 'any-reg) :offset (tn-offset y)))) (move y-wide-tn x) (inst shr y-wide-tn 8) @@ -36,8 +35,7 @@ (:results (y :scs (any-reg descriptor-reg #+nil control-stack))) (:note "character tagging") (:generator 1 - (move (make-random-tn :kind :normal :sc (gethash 'base-char-reg - sb!c::*backend-meta-sc-names*) + (move (make-random-tn :kind :normal :sc (sc-or-lose 'base-char-reg) :offset (tn-offset y)) x) (inst shl y n-widetag-bits) Index: type-vops.lisp =================================================================== RCS file: /cvsroot/sbcl/sbcl/src/compiler/x86-64/type-vops.lisp,v retrieving revision 1.1.8.7 retrieving revision 1.1.8.8 diff -u -d -r1.1.8.7 -r1.1.8.8 --- type-vops.lisp 4 Dec 2004 15:16:47 -0000 1.1.8.7 +++ type-vops.lisp 8 Dec 2004 23:25:26 -0000 1.1.8.8 @@ -13,26 +13,24 @@ ;;;; test generation utilities -;;; Emit the most compact form of the test immediate instruction, -;;; using an 8 bit test when the immediate is only 8 bits and the -;;; value is one of the four low registers (eax, ebx, ecx, edx) or the -;;; control stack. +(defun make-byte-tn (tn) + (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg)) + (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg) + :offset (tn-offset tn))) + (defun generate-fixnum-test (value) "zero flag set if VALUE is fixnum" (let ((offset (tn-offset value))) - (cond ((and (sc-is value any-reg descriptor-reg) - (or (= offset eax-offset) (= offset ebx-offset) - (= offset ecx-offset) (= offset edx-offset))) - (inst test (make-random-tn :kind :normal - :sc (sc-or-lose 'byte-reg) - :offset offset) - 7)) - ((sc-is value control-stack) + ;; The x86 backend uses a pun from E[A-D]X -> [A-D]L for these + ;; tests. The Athlon 64 optimization guide says that this is a + ;; bad idea, so it's been removed. + (cond ((sc-is value control-stack) (inst test (make-ea :byte :base rbp-tn :disp (- (* (1+ offset) n-word-bytes))) - 7)) + sb!vm::fixnum-tag-mask)) (t - (inst test value 7))))) + (inst test value sb!vm::fixnum-tag-mask))))) (defun %test-fixnum (value target not-p) (generate-fixnum-test value) @@ -46,28 +44,21 @@ (defun %test-immediate (value target not-p immediate) ;; Code a single instruction byte test if possible. - (let ((offset (tn-offset value))) - (cond ((and (sc-is value any-reg descriptor-reg) - (or (= offset rax-offset) (= offset rbx-offset) - (= offset rcx-offset) (= offset rdx-offset))) - (inst cmp (make-random-tn :kind :normal - :sc (sc-or-lose 'byte-reg) - :offset offset) - immediate)) - (t - (move rax-tn value) - (inst cmp al-tn immediate)))) + (cond ((sc-is value any-reg descriptor-reg) + (inst cmp (make-byte-tn value) immediate)) + (t + (move rax-tn value) + (inst cmp al-tn immediate))) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag (value target not-p lowtag &optional al-loaded) - (unless al-loaded - (move rax-tn value) - (inst and al-tn lowtag-mask)) - (inst cmp al-tn lowtag) +(defun %test-lowtag (value target not-p lowtag) + (move rax-tn value) + (inst and rax-tn lowtag-mask) + (inst cmp rax-tn lowtag) (inst jmp (if not-p :ne :e) target)) (defun %test-headers (value target not-p function-p headers - &optional (drop-through (gen-label)) al-loaded) + &optional (drop-through (gen-label))) (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) (multiple-value-bind (equal less-or-equal when-true when-false) ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET. @@ -76,7 +67,7 @@ (if not-p (values :ne :a drop-through target) (values :e :na target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) + (%test-lowtag value when-false t lowtag) (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) (do ((remaining headers (cdr remaining))) ((null remaining)) @@ -250,8 +241,8 @@ (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-lowtag) + (inst and eax-tn lowtag-mask) + (inst cmp eax-tn other-pointer-lowtag) (inst jmp :ne nope) ;; Get the header. (loadw eax-tn value 0 other-pointer-lowtag) @@ -293,8 +284,8 @@ (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-lowtag) + (inst and eax-tn lowtag-mask) + (inst cmp eax-tn other-pointer-lowtag) (inst jmp :ne nope) ;; Get the header. (loadw eax-tn value 0 other-pointer-lowtag) |