X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86-64%2Ftype-vops.lisp;h=43b838c0125303e349ddfe84369ccf90af34c76d;hb=0e7a9105ae992fc4befa37846c42f298e12918c0;hp=dfd41cab99112bc954b5374c17bd07ac0ffa3423;hpb=4ebdc81b1a9c6dbed6e98b112afc8dd32b17a2dd;p=sbcl.git diff --git a/src/compiler/x86-64/type-vops.lisp b/src/compiler/x86-64/type-vops.lisp index dfd41ca..43b838c 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,26 +13,17 @@ ;;;; 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 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) - (inst test (make-ea :byte :base rbp-tn - :disp (- (* (1+ offset) n-word-bytes))) - 7)) - (t - (inst test value 7))))) + (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 (- (* (1+ (tn-offset value)) n-word-bytes)))) + (t + value)) + sb!vm::fixnum-tag-mask)) (defun %test-fixnum (value target not-p) (generate-fixnum-test value) @@ -44,60 +35,83 @@ (inst jmp :z (if not-p drop-through target)) (%test-headers value target not-p nil headers drop-through))) -(defun %test-immediate (value target not-p immediate) +(defun %test-fixnum-and-immediate (value target not-p immediate) + (let ((drop-through (gen-label))) + (generate-fixnum-test value) + (inst jmp :z (if not-p drop-through target)) + (%test-immediate value target not-p immediate drop-through))) + +(defun %test-fixnum-immediate-and-headers (value target not-p immediate + headers) + (let ((drop-through (gen-label))) + (generate-fixnum-test value) + (inst jmp :z (if not-p drop-through target)) + (%test-immediate-and-headers value target not-p immediate headers + drop-through))) + +(defun %test-immediate (value target not-p immediate + &optional (drop-through (gen-label))) ;; 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)))) - (inst jmp (if not-p :ne :e) target)) + (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) + (emit-label drop-through)) + +(defun %test-immediate-and-headers (value target not-p immediate headers + &optional (drop-through (gen-label))) + ;; Code a single instruction byte test if possible. + (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 :e (if not-p drop-through target)) + (%test-headers value target not-p nil headers drop-through)) -(defun %test-lowtag (value target not-p lowtag &optional al-loaded) - (unless al-loaded - (move rax-tn value) - (inst and al-tn lowtag-mask)) +(defun %test-lowtag (value target not-p 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)) 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. - ;; 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)) - (%test-lowtag value when-false t lowtag al-loaded) + ;; 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. + (if not-p + (values :ne :a drop-through target) + (values :e :na 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))) - ((null remaining)) - (let ((header (car remaining)) - (last (null (cdr remaining)))) - (cond - ((atom header) - (inst cmp al-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 + ((null remaining)) + (let ((header (car remaining)) + (last (null (cdr remaining)))) + (cond + ((atom header) + (inst cmp al-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 (emit-label drop-through)))) @@ -123,8 +137,8 @@ (define-vop (simple-check-type) (:args (value :target result :scs (any-reg descriptor-reg))) (:results (result :scs (any-reg descriptor-reg) - :load-if (not (and (sc-is value any-reg descriptor-reg) - (sc-is result control-stack))))) + :load-if (not (and (sc-is value any-reg descriptor-reg) + (sc-is result control-stack))))) (:vop-var vop) (:save-p :compute-only)) @@ -139,29 +153,29 @@ (if (> (apply #'max type-codes) lowtag-limit) 7 2))) (defmacro !define-type-vops (pred-name check-name ptype error-code - (&rest type-codes) - &key (variant nil variant-p) &allow-other-keys) + (&rest type-codes) + &key (variant nil variant-p) &allow-other-keys) ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the ;; expansion? (let* ((cost (cost-to-test-types (mapcar #'eval type-codes))) - (prefix (if variant-p - (concatenate 'string (string variant) "-") - ""))) + (prefix (if variant-p + (concatenate 'string (string variant) "-") + ""))) `(progn ,@(when pred-name - `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) - (:translate ,pred-name) - (:generator ,cost - (test-type value target not-p (,@type-codes)))))) + `((define-vop (,pred-name ,(intern (concatenate 'string prefix "TYPE-PREDICATE"))) + (:translate ,pred-name) + (:generator ,cost + (test-type value target not-p (,@type-codes)))))) ,@(when check-name - `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) - (:generator ,cost - (let ((err-lab - (generate-error-code vop ,error-code value))) - (test-type value err-lab t (,@type-codes)) - (move result value)))))) + `((define-vop (,check-name ,(intern (concatenate 'string prefix "CHECK-TYPE"))) + (:generator ,cost + (let ((err-lab + (generate-error-code vop ,error-code value))) + (test-type value err-lab t (,@type-codes)) + (move result value)))))) ,@(when ptype - `((primitive-type-vop ,check-name (:check) ,ptype)))))) + `((primitive-type-vop ,check-name (:check) ,ptype)))))) ;;;; other integer ranges @@ -172,53 +186,137 @@ (:temporary (:sc unsigned-reg) tmp) (:generator 5 (inst mov tmp value) - (inst shr tmp 61) + (inst shr tmp n-positive-fixnum-bits) (inst jmp (if not-p :nz :z) target))) -(define-vop (signed-byte-32-p type-predicate) - (:translate signed-byte-32-p) +;;; A (SIGNED-BYTE 64) can be represented with either fixnum or a bignum with +;;; exactly one digit. + +(define-vop (signed-byte-64-p type-predicate) + (:translate signed-byte-64-p) (:generator 45 - ;; (and (fixnum) (no bits set >32)) - (move rax-tn value) - (inst test rax-tn 7) - (inst jmp :ne (if not-p target not-target)) - (inst sar rax-tn (+ 32 3)) - (inst jmp (if not-p :nz :z) target) + (multiple-value-bind (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + (generate-fixnum-test value) + (inst jmp :e yep) + (move rax-tn 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 jmp (if not-p :ne :e) target)) NOT-TARGET)) -(define-vop (check-signed-byte-32 check-type) +(define-vop (check-signed-byte-64 check-type) (:generator 45 (let ((nope (generate-error-code vop - object-not-signed-byte-32-error - value))) + object-not-signed-byte-64-error + value))) + (generate-fixnum-test value) + (inst jmp :e yep) (move rax-tn value) - (inst test rax-tn 7) + (inst and al-tn lowtag-mask) + (inst cmp al-tn other-pointer-lowtag) (inst jmp :ne nope) - (inst sar rax-tn (+ 32 3)) - (inst jmp :nz nope) - (move result value)))) - + (loadw rax-tn value 0 other-pointer-lowtag) + (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp :ne nope)) + YEP + (move result value))) -(define-vop (unsigned-byte-32-p type-predicate) - (:translate unsigned-byte-32-p) +;;; An (unsigned-byte 64) can be represented with either a positive +;;; fixnum, a bignum with exactly one positive digit, or a bignum with +;;; exactly two digits and the second digit all zeros. +(define-vop (unsigned-byte-64-p type-predicate) + (:translate unsigned-byte-64-p) (:generator 45 - ;; (and (fixnum) (no bits set >31)) - (move rax-tn value) - (inst test rax-tn 7) - (inst jmp :ne (if not-p target not-target)) - (inst sar rax-tn (+ 32 3 -1)) - (inst jmp (if not-p :nz :z) target) - NOT-TARGET)) + (let ((not-target (gen-label)) + (single-word (gen-label)) + (fixnum (gen-label))) + (multiple-value-bind (yep nope) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (generate-fixnum-test value) + (move rax-tn value) + (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 jmp :ne nope) + ;; Get the header. + (loadw rax-tn value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 64) + (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst jmp :ne nope) + ;; 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 jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw rax-tn value bignum-digits-offset other-pointer-lowtag) + + ;; positive implies (unsigned-byte 64). + (emit-label fixnum) + (inst or rax-tn rax-tn) + (inst jmp (if not-p :s :ns) target) -(define-vop (check-unsigned-byte-32 check-type) + (emit-label not-target))))) + +(define-vop (check-unsigned-byte-64 check-type) (:generator 45 (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value))) + (generate-error-code vop object-not-unsigned-byte-64-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) + + ;; Is it a fixnum? + (generate-fixnum-test value) (move rax-tn value) - (inst test rax-tn 7) + (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 jmp :ne nope) + ;; Get the header. + (loadw rax-tn value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp rax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) + (inst jmp :e single-word) + ;; If it's other than two, we can't be an (unsigned-byte 64) + (inst cmp rax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) (inst jmp :ne nope) - (inst sar rax-tn (+ 32 3 -1)) - (inst jmp :nz nope) + ;; 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 jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw rax-tn value bignum-digits-offset other-pointer-lowtag) + + ;; positive implies (unsigned-byte 64). + (emit-label fixnum) + (inst or rax-tn rax-tn) + (inst jmp :s nope) + + (emit-label yep) (move result value)))) ;;;; list/symbol types @@ -229,7 +327,7 @@ (define-vop (symbolp type-predicate) (:translate symbolp) (:generator 12 - (let ((is-symbol-label (if not-p drop-thru target))) + (let ((is-symbol-label (if not-p DROP-THRU target))) (inst cmp value nil-value) (inst jmp :e is-symbol-label) (test-type value target not-p (symbol-header-widetag))) @@ -239,7 +337,7 @@ (:generator 12 (let ((error (generate-error-code vop object-not-symbol-error value))) (inst cmp value nil-value) - (inst jmp :e drop-thru) + (inst jmp :e DROP-THRU) (test-type value error t (symbol-header-widetag))) DROP-THRU (move result value))) @@ -247,7 +345,7 @@ (define-vop (consp type-predicate) (:translate consp) (:generator 8 - (let ((is-not-cons-label (if not-p target drop-thru))) + (let ((is-not-cons-label (if not-p target DROP-THRU))) (inst cmp value nil-value) (inst jmp :e is-not-cons-label) (test-type value target not-p (list-pointer-lowtag)))