X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ftype-vops.lisp;h=8e99ec1e23c0798931afe81fca59b1e1efb813f0;hb=bcd323c39d6f5f80020ba4a5d9eb8d348c6cc499;hp=f3b540fdbcf015dc1cfb962ce9646bd439f8bf5c;hpb=a4cffc065c83d046fce193919bf6d4e53f181455;p=sbcl.git diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index f3b540f..8e99ec1 100644 --- a/src/compiler/x86-64/type-vops.lisp +++ b/src/compiler/x86-64/type-vops.lisp @@ -1,4 +1,4 @@ -;;;; type testing and checking VOPs for the x86 VM +;;;; type testing and checking VOPs for the x86-64 VM ;;;; This software is part of the SBCL system. See the README file for ;;;; more information. @@ -13,24 +13,25 @@ ;;;; test generation utilities -(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))) +;;; Optimize the case of moving a 64-bit value into RAX when not caring +;;; about the upper 32 bits: often the REX prefix can be spared. +(defun move-qword-to-eax (value) + (if (and (sc-is value any-reg descriptor-reg) + (< (tn-offset value) r8-offset)) + (move eax-tn (make-dword-tn value)) + (move rax-tn value))) (defun generate-fixnum-test (value) "zero flag set if VALUE is fixnum" - (let ((offset (tn-offset value))) - ;; 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))) - sb!vm::fixnum-tag-mask)) - (t - (inst test value sb!vm::fixnum-tag-mask))))) + (inst test + (cond ((sc-is value any-reg descriptor-reg) + (make-byte-tn value)) + ((sc-is value control-stack) + (make-ea :byte :base rbp-tn + :disp (frame-byte-offset (tn-offset value)))) + (t + value)) + sb!vm::fixnum-tag-mask)) (defun %test-fixnum (value target not-p) (generate-fixnum-test value) @@ -79,43 +80,74 @@ (%test-headers value target not-p nil headers drop-through)) (defun %test-lowtag (value target not-p lowtag) - (move rax-tn value) - (inst and rax-tn lowtag-mask) - (inst cmp rax-tn lowtag) + (move-qword-to-eax value) + (inst and al-tn lowtag-mask) + (inst cmp al-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))) (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. - ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know - ;; it's true and when we know it's false respectively. + (multiple-value-bind (equal less-or-equal greater-or-equal when-true + when-false) + ;; EQUAL, LESS-OR-EQUAL, and GREATER-OR-EQUAL are the conditions + ;; for branching to TARGET. WHEN-TRUE and WHEN-FALSE are the + ;; labels to branch to when we know it's true and when we know + ;; it's false respectively. (if not-p - (values :ne :a drop-through target) - (values :e :na target drop-through)) + (values :ne :a :b drop-through target) + (values :e :na :nb target drop-through)) (%test-lowtag value when-false t lowtag) - (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) - (do ((remaining headers (cdr remaining))) + (do ((remaining headers (cdr remaining)) + ;; It is preferable (smaller and faster code) to directly + ;; compare the value in memory instead of loading it into + ;; a register first. Find out if this is possible and set + ;; WIDETAG-TN accordingly. If impossible, generate the + ;; register load. + ;; Compared to x86 we additionally optimize the cases of a + ;; range starting with BIGNUM-WIDETAG or ending with + ;; COMPLEX-ARRAY-WIDETAG. + (widetag-tn (if (and (null (cdr headers)) + (or (atom (car headers)) + (= (caar headers) bignum-widetag) + (= (cdar headers) complex-array-widetag))) + (make-ea :byte :base value :disp (- lowtag)) + (progn + (inst mov eax-tn (make-ea :dword :base value + :disp (- lowtag))) + al-tn)))) ((null remaining)) (let ((header (car remaining)) (last (null (cdr remaining)))) (cond ((atom header) - (inst cmp al-tn header) + (inst cmp widetag-tn header) (if last (inst jmp equal target) (inst jmp :e when-true))) (t (let ((start (car header)) (end (cdr header))) - (unless (= start bignum-widetag) - (inst cmp al-tn start) - (inst jmp :b when-false)) ; was :l - (inst cmp al-tn end) - (if last - (inst jmp less-or-equal target) - (inst jmp :be when-true))))))) ; was :le + (cond + ((= start bignum-widetag) + (inst cmp widetag-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))) + ((= end complex-array-widetag) + (inst cmp widetag-tn start) + (if last + (inst jmp greater-or-equal target) + (inst jmp :b when-false))) + ((not last) + (inst cmp al-tn start) + (inst jmp :b when-false) + (inst cmp al-tn end) + (inst jmp :be when-true)) + (t + (inst sub al-tn start) + (inst cmp al-tn (- end start)) + (inst jmp less-or-equal target)))))))) (emit-label drop-through)))) @@ -175,7 +207,7 @@ `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) (:generator ,cost (let ((err-lab - (generate-error-code vop ,error-code value))) + (generate-error-code vop ',error-code value))) (test-type value err-lab t (,@type-codes)) (move result value)))))) ,@(when ptype @@ -188,10 +220,27 @@ (:arg-types unsigned-num) (:translate fixnump) (:temporary (:sc unsigned-reg) tmp) + (:info) + (:conditional :z) (:generator 5 (inst mov tmp value) - (inst shr tmp 61) - (inst jmp (if not-p :nz :z) target))) + (inst shr tmp n-positive-fixnum-bits))) + +(define-vop (fixnump/signed-byte-64 type-predicate) + (:args (value :scs (signed-reg))) + (:info) + (:conditional #.(if (= sb!vm:n-fixnum-tag-bits 1) :ns :z)) + (:arg-types signed-num) + (:translate fixnump) + (:generator 5 + ;; Hackers Delight, p. 53: signed + ;; a <= x <= a + 2^n - 1 + ;; is equivalent to unsigned + ;; ((x-a) >> n) = 0 + (inst mov rax-tn #.(- sb!xc:most-negative-fixnum)) + (inst add rax-tn value) + (unless (= n-fixnum-tag-bits 1) + (inst shr rax-tn n-fixnum-bits)))) ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with ;;; exactly one digit. @@ -205,28 +254,28 @@ (values target not-target)) (generate-fixnum-test value) (inst jmp :e yep) - (move rax-tn value) + (move-qword-to-eax value) (inst and al-tn lowtag-mask) (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) - (loadw rax-tn value 0 other-pointer-lowtag) - (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag) + (+ (ash 1 n-widetag-bits) bignum-widetag)) (inst jmp (if not-p :ne :e) target)) NOT-TARGET)) (define-vop (check-signed-byte-64 check-type) (:generator 45 (let ((nope (generate-error-code vop - object-not-signed-byte-64-error + 'object-not-signed-byte-64-error value))) (generate-fixnum-test value) (inst jmp :e yep) - (move rax-tn value) + (move-qword-to-eax value) (inst and al-tn lowtag-mask) (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) - (loadw rax-tn value 0 other-pointer-lowtag) - (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag) + (+ (ash 1 n-widetag-bits) bignum-widetag)) (inst jmp :ne nope)) YEP (move result value))) @@ -250,8 +299,8 @@ (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and rax-tn lowtag-mask) - (inst cmp rax-tn other-pointer-lowtag) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) ;; Get the header. (loadw rax-tn value 0 other-pointer-lowtag) @@ -264,7 +313,7 @@ ;; Get the second digit. (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) ;; All zeros, its an (unsigned-byte 64). - (inst or rax-tn rax-tn) + (inst test rax-tn rax-tn) (inst jmp :z yep) (inst jmp nope) @@ -274,7 +323,7 @@ ;; positive implies (unsigned-byte 64). (emit-label fixnum) - (inst or rax-tn rax-tn) + (inst test rax-tn rax-tn) (inst jmp (if not-p :s :ns) target) (emit-label not-target))))) @@ -282,7 +331,7 @@ (define-vop (check-unsigned-byte-64 check-type) (:generator 45 (let ((nope - (generate-error-code vop object-not-unsigned-byte-64-error value)) + (generate-error-code vop 'object-not-unsigned-byte-64-error value)) (yep (gen-label)) (fixnum (gen-label)) (single-word (gen-label))) @@ -293,8 +342,8 @@ (inst jmp :e fixnum) ;; If not, is it an other pointer? - (inst and rax-tn lowtag-mask) - (inst cmp rax-tn other-pointer-lowtag) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) ;; Get the header. (loadw rax-tn value 0 other-pointer-lowtag) @@ -307,7 +356,7 @@ ;; Get the second digit. (loadw rax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) ;; All zeros, its an (unsigned-byte 64). - (inst or rax-tn rax-tn) + (inst test rax-tn rax-tn) (inst jmp :z yep) (inst jmp nope) @@ -317,7 +366,7 @@ ;; positive implies (unsigned-byte 64). (emit-label fixnum) - (inst or rax-tn rax-tn) + (inst test rax-tn rax-tn) (inst jmp :s nope) (emit-label yep) @@ -339,7 +388,7 @@ (define-vop (check-symbol check-type) (:generator 12 - (let ((error (generate-error-code vop object-not-symbol-error value))) + (let ((error (generate-error-code vop 'object-not-symbol-error value))) (inst cmp value nil-value) (inst jmp :e DROP-THRU) (test-type value error t (symbol-header-widetag))) @@ -357,7 +406,7 @@ (define-vop (check-cons check-type) (:generator 8 - (let ((error (generate-error-code vop object-not-cons-error value))) + (let ((error (generate-error-code vop 'object-not-cons-error value))) (inst cmp value nil-value) (inst jmp :e error) (test-type value error t (list-pointer-lowtag))