X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ftype-vops.lisp;h=4ad6d5d8d30f0a80f880cac04302603375f454b8;hb=cd5a858174d892f876699373dc3ea389cf2c4d40;hp=4b8cd454b9f01ee66040239bbac11dca20cfc0de;hpb=fd63d6aad4a5a3b171eafb56b1b6bd502e501281;p=sbcl.git diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp index 4b8cd45..4ad6d5d 100644 --- a/src/compiler/x86/type-vops.lisp +++ b/src/compiler/x86/type-vops.lisp @@ -41,10 +41,9 @@ (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)) +(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 @@ -53,11 +52,10 @@ ;; not too bad. -- CSR, 2004-07-27 (when (member :prefetch *backend-subfeatures*) (inst prefetchnta (make-ea :byte :base value :disp (- lowtag)))) - (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 greater-or-equal when-true when-false) ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for @@ -67,7 +65,7 @@ (if not-p (values :ne :a :b drop-through target) (values :e :na :nb target drop-through)) - (%test-lowtag value when-false t lowtag al-loaded) + (%test-lowtag value when-false t lowtag) (cond ((and (null (cdr headers)) (numberp (car headers))) @@ -127,18 +125,28 @@ ;; was true. (return)) (t - (unless (= start bignum-widetag) - (inst cmp al-tn start) - (if (= end complex-array-widetag) - (progn - (aver last) - (inst jmp greater-or-equal target)) - (inst jmp :b when-false))) ; was :l - (unless (= end complex-array-widetag) - (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)))) ;;;; type checking and testing @@ -197,7 +205,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 @@ -207,11 +215,31 @@ (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 - (inst cmp value #.sb!xc:most-positive-fixnum) - (inst jmp (if not-p :a :be) target))) + ;; 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. @@ -225,28 +253,28 @@ (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 + '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))) @@ -284,7 +312,7 @@ ;; 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) @@ -294,7 +322,7 @@ ;; positive implies (unsigned-byte 32). (emit-label fixnum) - (inst or eax-tn eax-tn) + (inst test eax-tn eax-tn) (inst jmp (if not-p :s :ns) target) (emit-label not-target))))) @@ -302,7 +330,7 @@ (define-vop (check-unsigned-byte-32 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-32-error value)) (yep (gen-label)) (fixnum (gen-label)) (single-word (gen-label))) @@ -327,7 +355,7 @@ ;; 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) @@ -337,11 +365,40 @@ ;; 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 (fixnumize (numeric-type-high type))) + (error (gen-label))) + ;; FIXME: abstract + (assemble (*elsewhere*) + (emit-label error) + (inst mov temp 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 hi)) + (inst jmp :ne error)) + (t + (generate-fixnum-test value) + (inst jmp :ne error) + (inst cmp value hi) + (inst jmp :a error))) + (move result value)))) + ;;;; list/symbol types ;;; @@ -359,7 +416,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))) @@ -377,7 +434,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))