X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ftype-vops.lisp;h=58e88548cd9ce0005c38555acc4905c636b2f785;hb=a7a9b1029e8b9e45a5b66d62e161cc476cb7b60c;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..58e8854 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,17 @@ ;;;; 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))) - (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,21 +72,25 @@ (%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) + (if (and (sc-is value any-reg descriptor-reg) + (< (tn-offset value) r8-offset)) + (move eax-tn (make-dword-tn value)) ; shorter encoding (no REX prefix) + (move rax-tn 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))) @@ -109,13 +106,28 @@ (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 al-tn end) + (if last + (inst jmp less-or-equal target) + (inst jmp :be when-true))) + ((= end complex-array-widetag) + (inst cmp al-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) + (if last + (inst jmp less-or-equal target) + (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 +187,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 +200,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 :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) + (inst shr rax-tn #.(integer-length (- sb!xc:most-positive-fixnum + sb!xc:most-negative-fixnum))))) ;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with ;;; exactly one digit. @@ -209,15 +238,15 @@ (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) @@ -225,8 +254,8 @@ (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))) @@ -282,7 +311,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))) @@ -339,7 +368,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 +386,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))