X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;ds=sidebyside;f=src%2Fcompiler%2Fx86-64%2Ftype-vops.lisp;h=58e88548cd9ce0005c38555acc4905c636b2f785;hb=97dd06859cae90c8ef9021dafe1beebb78b1547f;hp=a68121fa154745f3956e7b61712bb60e9406a53f;hpb=7516363f36f26eaf64b7e4eb23b5980e915d7259;p=sbcl.git diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index a68121f..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,18 +13,6 @@ ;;;; 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 make-dword-tn (tn) - (aver (sc-is tn any-reg descriptor-reg unsigned-reg signed-reg)) - (make-random-tn :kind :normal - :sc (sc-or-lose 'dword-reg) - :offset (tn-offset tn))) - (defun generate-fixnum-test (value) "zero flag set if VALUE is fixnum" (inst test @@ -32,7 +20,7 @@ (make-byte-tn value)) ((sc-is value control-stack) (make-ea :byte :base rbp-tn - :disp (- (* (1+ (tn-offset value)) n-word-bytes)))) + :disp (frame-byte-offset (tn-offset value)))) (t value)) sb!vm::fixnum-tag-mask)) @@ -95,13 +83,14 @@ (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))) @@ -117,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)))) @@ -183,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 @@ -196,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 n-positive-fixnum-bits) - (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. @@ -217,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) @@ -233,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))) @@ -290,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))) @@ -347,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))) @@ -365,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))