1;;;; type testing and checking VOPs for the x86 VM 2 3;;;; This software is part of the SBCL system. See the README file for 4;;;; more information. 5;;;; 6;;;; This software is derived from the CMU CL system, which was 7;;;; written at Carnegie Mellon University and released into the 8;;;; public domain. The software is in the public domain and is 9;;;; provided with absolutely no warranty. See the COPYING and CREDITS 10;;;; files for more information. 11 12(in-package "SB!VM") 13 14;;;; test generation utilities 15 16(defun generate-fixnum-test (value) 17 (emit-optimized-test-inst value fixnum-tag-mask)) 18 19(defun %test-fixnum (value target not-p) 20 (generate-fixnum-test value) 21 (inst jmp (if not-p :nz :z) target)) 22 23(defun %test-fixnum-and-headers (value target not-p headers) 24 (let ((drop-through (gen-label))) 25 (generate-fixnum-test value) 26 (inst jmp :z (if not-p drop-through target)) 27 (%test-headers value target not-p nil headers :drop-through drop-through))) 28 29(defun %test-immediate (value target not-p immediate) 30 ;; Code a single instruction byte test if possible. 31 (let ((offset (tn-offset value))) 32 (cond ((and (sc-is value any-reg descriptor-reg) 33 (or (= offset eax-offset) (= offset ebx-offset) 34 (= offset ecx-offset) (= offset edx-offset))) 35 (inst cmp (make-random-tn :kind :normal 36 :sc (sc-or-lose 'byte-reg) 37 :offset offset) 38 immediate)) 39 (t 40 (move eax-tn value) 41 (inst cmp al-tn immediate)))) 42 (inst jmp (if not-p :ne :e) target)) 43 44(defun %test-lowtag (value target not-p lowtag) 45 (inst lea eax-tn (make-ea :dword :base value :disp (- lowtag))) 46 (inst test al-tn lowtag-mask) 47 ;; FIXME: another 'optimization' which doesn't appear to work: 48 ;; prefetching the hypothetically pointed-to version should help, 49 ;; but this is in fact non-ideal in plenty of ways: we emit way too 50 ;; many of these prefetch instructions; pointed-to objects are very 51 ;; often in the cache anyway; etc. etc. Still, as proof-of-concept, 52 ;; not too bad. -- CSR, 2004-07-27 53 (when (member :prefetch *backend-subfeatures*) 54 (inst prefetchnta (make-ea :byte :base value :disp (- lowtag)))) 55 (inst jmp (if not-p :ne :e) target)) 56 57(defun %test-headers (value target not-p function-p headers 58 &key except (drop-through (gen-label))) 59 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag))) 60 (multiple-value-bind (equal less-or-equal greater-or-equal when-true when-false) 61 ;; EQUAL, LESS-OR-EQUAL and GREATER-OR-EQUAL are the conditions for 62 ;; branching to TARGET. WHEN-TRUE and WHEN-FALSE are the 63 ;; labels to branch to when we know it's true and when we know 64 ;; it's false respectively. 65 (if not-p 66 (values :ne :a :b drop-through target) 67 (values :e :na :nb target drop-through)) 68 (%test-lowtag value when-false t lowtag) 69 (cond 70 ((and (null (cdr headers)) 71 (not except) 72 (numberp (car headers))) 73 ;; Optimize the common case: referencing the value from memory 74 ;; is slightly smaller than loading it and then doing the 75 ;; comparison. Doing this for other cases (e.g. range of 76 ;; [BIGNUM-WIDETAG..FOO-WIDETAG]) is also possible, but such 77 ;; opportunities don't come up very often and the code would 78 ;; get pretty hairy... 79 (inst cmp (make-ea :byte :base value :disp (- lowtag)) (car headers)) 80 (inst jmp equal target)) 81 (t 82 (inst mov al-tn (make-ea :byte :base value :disp (- lowtag))) 83 (dolist (widetag except) 84 (inst cmp al-tn widetag) 85 (inst jmp :e when-false)) 86 (do ((remaining headers (cdr remaining))) 87 ((null remaining)) 88 (let ((header (car remaining)) 89 (last (null (cdr remaining)))) 90 (cond 91 ((atom header) 92 (cond 93 ((and (not last) (null (cddr remaining)) 94 (atom (cadr remaining)) 95 (= (logcount (logxor header (cadr remaining))) 1)) 96 ;; FIXME: (VECTOR T) does not and could not admit this hack. 97 ;; The others could but are broken except for BIT-VECTOR. 98 ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T) 99 (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining)))) 100 (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining)))) 101 (inst jmp equal target) 102 (return)) 103 (t 104 (inst cmp al-tn header) 105 (if last 106 (inst jmp equal target) 107 (inst jmp :e when-true))))) 108 (t 109 (let ((start (car header)) 110 (end (cdr header))) 111 (cond 112 ;; LAST = don't need al-tn later 113 ((and last (not (= start bignum-widetag)) 114 (= (+ start 4) end) (= (logcount (logxor start end)) 1)) 115 ;; SIMPLE-STRING 116 (inst and al-tn (ldb (byte 8 0) (logeqv start end))) 117 (inst cmp al-tn (ldb (byte 8 0) (logand start end))) 118 (inst jmp equal target)) 119 ((and (not last) (null (cddr remaining)) 120 (= (+ start 4) end) (= (logcount (logxor start end)) 1) 121 (listp (cadr remaining)) 122 (= (+ (caadr remaining) 4) (cdadr remaining)) 123 (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1) 124 (= (logcount (logxor (caadr remaining) start)) 1)) 125 ;; STRING 126 (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining)))) 127 (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining)))) 128 (inst jmp equal target) 129 ;; we've shortcircuited the DO, so we must return. 130 ;; It's OK to do so, because (NULL (CDDR REMAINING)) 131 ;; was true. 132 (return)) 133 (t 134 (cond 135 ((= start bignum-widetag) 136 (inst cmp al-tn end) 137 (if last 138 (inst jmp less-or-equal target) 139 (inst jmp :be when-true))) 140 ((= end complex-array-widetag) 141 (inst cmp al-tn start) 142 (if last 143 (inst jmp greater-or-equal target) 144 (inst jmp :b when-false))) 145 ((not last) 146 (inst cmp al-tn start) 147 (inst jmp :b when-false) 148 (inst cmp al-tn end) 149 (if last 150 (inst jmp less-or-equal target) 151 (inst jmp :be when-true))) 152 (t 153 (inst sub al-tn start) 154 (inst cmp al-tn (- end start)) 155 (inst jmp less-or-equal target)))))))))))) 156 (emit-label drop-through)))) 157 158;;; simpler VOP that don't need a temporary register 159(define-vop (simple-type-predicate) 160 (:args (value :scs (any-reg descriptor-reg control-stack))) 161 (:conditional) 162 (:info target not-p) 163 (:policy :fast-safe)) 164 165;;;; other integer ranges 166 167(define-vop (fixnump/unsigned-byte-32 simple-type-predicate) 168 (:args (value :scs (unsigned-reg))) 169 (:info) 170 (:conditional :be) 171 (:arg-types unsigned-num) 172 (:translate fixnump) 173 (:generator 5 174 ;; We could encode this with :Z and SHR, analogously to the signed-byte-32 175 ;; case below -- as we do on x86-64 -- but that costs us an extra 176 ;; register. Compromises... 177 (inst cmp value #.sb!xc:most-positive-fixnum))) 178 179(define-vop (fixnump/signed-byte-32 type-predicate) 180 (:args (value :scs (signed-reg))) 181 (:info) 182 (:conditional :z) 183 (:arg-types signed-num) 184 (:translate fixnump) 185 (:generator 5 186 ;; Hackers Delight, p. 53: signed 187 ;; a <= x <= a + 2^n - 1 188 ;; is equivalent to unsigned 189 ;; ((x-a) >> n) = 0 190 (inst mov eax-tn value) 191 (inst sub eax-tn #.sb!xc:most-negative-fixnum) 192 (inst shr eax-tn #.(integer-length (- sb!xc:most-positive-fixnum 193 sb!xc:most-negative-fixnum))))) 194 195;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with 196;;; exactly one digit. 197 198(define-vop (signed-byte-32-p type-predicate) 199 (:translate signed-byte-32-p) 200 (:generator 45 201 (multiple-value-bind (yep nope) 202 (if not-p 203 (values not-target target) 204 (values target not-target)) 205 (generate-fixnum-test value) 206 (inst jmp :e yep) 207 (inst lea eax-tn (make-ea :dword :base value 208 :disp (- other-pointer-lowtag))) 209 (inst test al-tn lowtag-mask) 210 (inst jmp :ne nope) 211 (inst cmp (make-ea-for-object-slot value 0 other-pointer-lowtag) 212 (+ (ash 1 n-widetag-bits) bignum-widetag)) 213 (inst jmp (if not-p :ne :e) target)) 214 NOT-TARGET)) 215 216;;; An (unsigned-byte 32) can be represented with either a positive 217;;; fixnum, a bignum with exactly one positive digit, or a bignum with 218;;; exactly two digits and the second digit all zeros. 219(define-vop (unsigned-byte-32-p type-predicate) 220 (:translate unsigned-byte-32-p) 221 (:generator 45 222 (let ((not-target (gen-label)) 223 (single-word (gen-label)) 224 (fixnum (gen-label))) 225 (multiple-value-bind (yep nope) 226 (if not-p 227 (values not-target target) 228 (values target not-target)) 229 ;; Is it a fixnum? 230 (move eax-tn value) 231 (inst test al-tn fixnum-tag-mask) 232 (inst jmp :e fixnum) 233 234 ;; If not, is it an other pointer? 235 (inst and al-tn lowtag-mask) 236 (inst cmp al-tn other-pointer-lowtag) 237 (inst jmp :ne nope) 238 ;; Get the header. 239 (loadw eax-tn value 0 other-pointer-lowtag) 240 ;; Is it one? 241 (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag)) 242 (inst jmp :e single-word) 243 ;; If it's other than two, we can't be an (unsigned-byte 32) 244 ;: Leave EAX holding 0 in the affirmative case. 245 (inst sub eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag)) 246 (inst jmp :ne nope) 247 ;; Compare the second digit to zero (in EAX). 248 (inst cmp (make-ea-for-object-slot value (1+ bignum-digits-offset) 249 other-pointer-lowtag) eax-tn) 250 (inst jmp :z yep) ; All zeros, its an (unsigned-byte 32). 251 (inst jmp nope) 252 253 (emit-label single-word) 254 ;; Get the single digit. 255 (loadw eax-tn value bignum-digits-offset other-pointer-lowtag) 256 257 ;; positive implies (unsigned-byte 32). 258 (emit-label fixnum) 259 (inst test eax-tn eax-tn) 260 (inst jmp (if not-p :s :ns) target) 261 262 (emit-label not-target))))) 263 264(defun power-of-two-limit-p (x) 265 (and (fixnump x) 266 (= (logcount (1+ x)) 1))) 267 268(define-vop (test-fixnum-mod-power-of-two) 269 (:args (value :scs (any-reg descriptor-reg 270 unsigned-reg signed-reg 271 immediate))) 272 (:arg-types * 273 (:constant (satisfies power-of-two-limit-p))) 274 (:translate sb!c::fixnum-mod-p) 275 (:conditional :e) 276 (:info hi) 277 (:save-p :compute-only) 278 (:policy :fast-safe) 279 (:generator 4 280 (aver (not (sc-is value immediate))) 281 (let* ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) 282 hi 283 (fixnumize hi)))) 284 (inst test value (lognot fixnum-hi))))) 285 286(define-vop (test-fixnum-mod-tagged-unsigned) 287 (:args (value :scs (any-reg descriptor-reg 288 unsigned-reg signed-reg 289 immediate))) 290 (:arg-types (:or tagged-num unsigned-num signed-num) 291 (:constant fixnum)) 292 (:translate sb!c::fixnum-mod-p) 293 (:conditional :be) 294 (:info hi) 295 (:save-p :compute-only) 296 (:policy :fast-safe) 297 (:generator 5 298 (aver (not (sc-is value immediate))) 299 (let ((fixnum-hi (if (sc-is value unsigned-reg signed-reg) 300 hi 301 (fixnumize hi)))) 302 (inst cmp value fixnum-hi)))) 303 304(define-vop (test-fixnum-mod-*) 305 (:args (value :scs (any-reg descriptor-reg))) 306 (:arg-types * (:constant fixnum)) 307 (:translate sb!c::fixnum-mod-p) 308 (:conditional) 309 (:info target not-p hi) 310 (:save-p :compute-only) 311 (:policy :fast-safe) 312 (:generator 6 313 (let* ((fixnum-hi (fixnumize hi)) 314 (skip (gen-label))) 315 (generate-fixnum-test value) 316 (inst jmp :ne (if not-p target skip)) 317 (inst cmp value fixnum-hi) 318 (inst jmp (if not-p :a :be) target) 319 (emit-label skip)))) 320 321 322;;;; list/symbol types 323;;; 324;;; symbolp (or symbol (eq nil)) 325;;; consp (and list (not (eq nil))) 326 327(define-vop (symbolp type-predicate) 328 (:translate symbolp) 329 (:generator 12 330 (let ((is-symbol-label (if not-p DROP-THRU target)) 331 (widetag-tn (make-ea :byte :base value :disp (- other-pointer-lowtag)))) 332 ;; It could have been done with just TEST-TYPE, but using CMP on 333 ;; EAX saves one byte, this basically unrolls TEST-TYPE and 334 ;; inserts a comparison to NIL in the middle. 335 (inst lea eax-tn widetag-tn) 336 (inst cmp eax-tn (- nil-value other-pointer-lowtag)) 337 (inst jmp :e is-symbol-label) 338 (inst test al-tn other-pointer-lowtag) 339 (inst jmp :nz (if not-p target drop-thru)) 340 (inst cmp widetag-tn symbol-header-widetag) 341 (inst jmp (if not-p :ne :e) target)) 342 DROP-THRU)) 343 344(define-vop (consp type-predicate) 345 (:translate consp) 346 (:generator 8 347 (let ((is-not-cons-label (if not-p target drop-thru))) 348 ;; It could have been done with just TEST-TYPE, but using CMP on 349 ;; EAX saves one byte, this basically unrolls TEST-TYPE and 350 ;; inserts a comparison to NIL in the middle. 351 (inst lea eax-tn (make-ea :dword :base value :disp (- list-pointer-lowtag))) 352 (inst cmp eax-tn (- nil-value list-pointer-lowtag)) 353 (inst jmp :e is-not-cons-label) 354 (inst test al-tn other-pointer-lowtag) 355 (inst jmp (if not-p :nz :z) target)) 356 DROP-THRU)) 357 358;; A vop that accepts a computed set of widetags. 359(define-vop (%other-pointer-subtype-p type-predicate) 360 (:translate %other-pointer-subtype-p) 361 (:info target not-p widetags) 362 (:arg-types * (:constant t)) ; voodoo - 'target' and 'not-p' are absent 363 (:generator 15 ; arbitrary 364 (multiple-value-bind (headers exceptions) 365 (canonicalize-widetags+exceptions widetags) 366 (%test-headers value target not-p nil headers 367 :except exceptions)))) 368