X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ftype-vops.lisp;h=a0223ffb65548230bc0a97a26d5ddc4bbaf42056;hb=d5c8232ed5dc81aea41d3b9e865189660bf45614;hp=36f49a60123126233e9e0536bd3c9ee70a6b6e3d;hpb=faa0ea92986f4c2b361c9378c69a540e42a70c62;p=sbcl.git diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 36f49a6..a0223ff 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -13,25 +13,8 @@ ;;;; 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) - (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) - 3)) - ((sc-is value control-stack) - (inst test (make-ea :byte :base ebp-tn - :disp (- (* (1+ offset) n-word-bytes))) - 3)) - (t - (inst test value 3))))) + (emit-optimized-test-inst value 3)) (defun %test-fixnum (value target not-p) (generate-fixnum-test value) @@ -47,64 +30,124 @@ ;; Code a single instruction byte test if possible. (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 cmp (make-random-tn :kind :normal - :sc (sc-or-lose 'byte-reg) - :offset offset) - immediate)) - (t - (move eax-tn value) - (inst cmp al-tn immediate)))) + (or (= offset eax-offset) (= offset ebx-offset) + (= offset ecx-offset) (= offset edx-offset))) + (inst cmp (make-random-tn :kind :normal + :sc (sc-or-lose 'byte-reg) + :offset offset) + immediate)) + (t + (move eax-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 eax-tn value) - (inst and al-tn lowtag-mask)) - (inst cmp al-tn lowtag) +(defun %test-lowtag (value target not-p lowtag) + (inst lea eax-tn (make-ea :dword :base value :disp (- lowtag))) + (inst test al-tn lowtag-mask) + ;; FIXME: another 'optimization' which doesn't appear to work: + ;; prefetching the hypothetically pointed-to version should help, + ;; but this is in fact non-ideal in plenty of ways: we emit way too + ;; many of these prefetch instructions; pointed-to objects are very + ;; often in the cache anyway; etc. etc. Still, as proof-of-concept, + ;; not too bad. -- CSR, 2004-07-27 + (when (member :prefetch *backend-subfeatures*) + (inst prefetchnta (make-ea :byte :base value :disp (- lowtag)))) (inst jmp (if not-p :ne :e) target)) -(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers) - (let ((drop-through (gen-label))) - (%test-lowtag value (if not-p drop-through target) nil lowtag) - (%test-headers value target not-p function-p headers drop-through t))) - - (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) - (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 + (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 :b drop-through target) + (values :e :na :nb target drop-through)) + (%test-lowtag value when-false t lowtag) + (cond + ((and (null (cdr headers)) + (numberp (car headers))) + ;; Optimize the common case: referencing the value from memory + ;; is slightly smaller than loading it and then doing the + ;; comparison. Doing this for other cases (e.g. range of + ;; [BIGNUM-WIDETAG..FOO-WIDETAG]) is also possible, but such + ;; opportunities don't come up very often and the code would + ;; get pretty hairy... + (inst cmp (make-ea :byte :base value :disp (- lowtag)) (car headers)) + (inst jmp equal target)) + (t + (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) + (cond + ((and (not last) (null (cddr remaining)) + (atom (cadr remaining)) + (= (logcount (logxor header (cadr remaining))) 1)) + ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T) + (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining)))) + (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining)))) + (inst jmp equal target) + (return)) + (t + (inst cmp al-tn header) + (if last + (inst jmp equal target) + (inst jmp :e when-true))))) + (t + (let ((start (car header)) + (end (cdr header))) + (cond + ;; LAST = don't need al-tn later + ((and last (not (= start bignum-widetag)) + (= (+ start 4) end) (= (logcount (logxor start end)) 1)) + ;; SIMPLE-STRING + (inst and al-tn (ldb (byte 8 0) (logeqv start end))) + (inst cmp al-tn (ldb (byte 8 0) (logand start end))) + (inst jmp equal target)) + ((and (not last) (null (cddr remaining)) + (= (+ start 4) end) (= (logcount (logxor start end)) 1) + (listp (cadr remaining)) + (= (+ (caadr remaining) 4) (cdadr remaining)) + (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1) + (= (logcount (logxor (caadr remaining) start)) 1)) + ;; STRING + (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining)))) + (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining)))) + (inst jmp equal target) + ;; we've shortcircuited the DO, so we must return. + ;; It's OK to do so, because (NULL (CDDR REMAINING)) + ;; was true. + (return)) + (t + (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)))) - ;;;; type checking and testing @@ -128,8 +171,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)) @@ -144,32 +187,60 @@ (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)) + (&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 +(define-vop (fixnump/unsigned-byte-32 simple-type-predicate) + (:args (value :scs (unsigned-reg))) + (:info) + (:conditional :be) + (:arg-types unsigned-num) + (:translate fixnump) + (:generator 5 + ;; We could encode this with :Z and SHR, analogously to the signed-byte-32 + ;; case below -- as we do on x86-64 -- but that costs us an extra + ;; register. Compromises... + (inst cmp value #.sb!xc:most-positive-fixnum))) + +(define-vop (fixnump/signed-byte-32 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 eax-tn value) + (inst sub eax-tn #.sb!xc:most-negative-fixnum) + (inst shr eax-tn #.(integer-length (- sb!xc:most-positive-fixnum + sb!xc:most-negative-fixnum))))) + ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with ;;; exactly one digit. @@ -177,33 +248,33 @@ (:translate signed-byte-32-p) (:generator 45 (multiple-value-bind (yep nope) - (if not-p - (values not-target target) - (values target not-target)) + (if not-p + (values not-target target) + (values target not-target)) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-lowtag) + (inst lea eax-tn (make-ea :dword :base value + :disp (- other-pointer-lowtag))) + (inst test al-tn lowtag-mask) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-lowtag) - (inst cmp eax-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-32 check-type) (:generator 45 (let ((nope (generate-error-code vop - object-not-signed-byte-32-error - value))) + 'object-not-signed-byte-32-error + value))) (generate-fixnum-test value) (inst jmp :e yep) - (move eax-tn value) - (inst and al-tn lowtag-mask) - (inst cmp al-tn other-pointer-lowtag) + (inst lea eax-tn (make-ea :dword :base value + :disp (- other-pointer-lowtag))) + (inst test al-tn lowtag-mask) (inst jmp :ne nope) - (loadw eax-tn value 0 other-pointer-lowtag) - (inst cmp eax-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))) @@ -215,54 +286,54 @@ (:translate unsigned-byte-32-p) (:generator 45 (let ((not-target (gen-label)) - (single-word (gen-label)) - (fixnum (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 eax-tn value) - (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 jmp :ne nope) - ;; Get the header. - (loadw eax-tn value 0 other-pointer-lowtag) - ;; Is it one? - (inst cmp eax-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 32) - (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) - (inst jmp :ne nope) - ;; Get the second digit. - (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) - ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) - (inst jmp :z yep) - (inst jmp nope) - - (emit-label single-word) - ;; Get the single digit. - (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) - - ;; positive implies (unsigned-byte 32). - (emit-label fixnum) - (inst or eax-tn eax-tn) - (inst jmp (if not-p :s :ns) target) - - (emit-label not-target))))) + (if not-p + (values not-target target) + (values target not-target)) + ;; Is it a fixnum? + (generate-fixnum-test value) + (move eax-tn value) + (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 jmp :ne nope) + ;; Get the header. + (loadw eax-tn value 0 other-pointer-lowtag) + ;; Is it one? + (inst cmp eax-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 32) + (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) + (inst jmp :ne nope) + ;; Get the second digit. + (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) + ;; All zeros, its an (unsigned-byte 32). + (inst test eax-tn eax-tn) + (inst jmp :z yep) + (inst jmp nope) + + (emit-label single-word) + ;; Get the single digit. + (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) + + ;; positive implies (unsigned-byte 32). + (emit-label fixnum) + (inst test eax-tn eax-tn) + (inst jmp (if not-p :s :ns) target) + + (emit-label not-target))))) (define-vop (check-unsigned-byte-32 check-type) (:generator 45 (let ((nope - (generate-error-code vop object-not-unsigned-byte-32-error value)) - (yep (gen-label)) - (fixnum (gen-label)) - (single-word (gen-label))) + (generate-error-code vop 'object-not-unsigned-byte-32-error value)) + (yep (gen-label)) + (fixnum (gen-label)) + (single-word (gen-label))) ;; Is it a fixnum? (generate-fixnum-test value) @@ -284,21 +355,51 @@ ;; Get the second digit. (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag) ;; All zeros, its an (unsigned-byte 32). - (inst or eax-tn eax-tn) + (inst test eax-tn eax-tn) (inst jmp :z yep) (inst jmp nope) - + (emit-label single-word) ;; Get the single digit. (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst test eax-tn eax-tn) (inst jmp :s nope) (emit-label yep) (move result value)))) + +(define-vop (check-mod-fixnum check-type) + (:info type) + (:temporary (:sc any-reg) temp) + (:generator 30 + (let* ((low (numeric-type-low type)) + (hi (numeric-type-high type)) + (fixnum-hi (fixnumize hi)) + (error (gen-label))) + ;; FIXME: abstract + (assemble (*elsewhere*) + (emit-label error) + (inst mov temp fixnum-hi) + (emit-error-break vop error-trap + (error-number-or-lose 'object-not-mod-error) + (list value temp))) + (aver (zerop low)) + (cond + ;; Handle powers of two specially + ;; The higher bits and the fixnum tag can be tested in one go + ((= (logcount (1+ hi)) 1) + (inst test value (lognot fixnum-hi)) + (inst jmp :ne error)) + (t + (generate-fixnum-test value) + (inst jmp :ne error) + (inst cmp value fixnum-hi) + (inst jmp :a error))) + (move result value)))) + ;;;; list/symbol types ;;; @@ -316,7 +417,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))) @@ -334,7 +435,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))