1 ;;;; type testing and checking VOPs for the x86 VM
3 ;;;; This software is part of the SBCL system. See the README file for
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.
14 ;;;; test generation utilities
16 (eval-when (:compile-toplevel :execute)
18 (defparameter *immediate-types*
19 (list unbound-marker-type base-char-type))
21 (defparameter *fun-header-types*
22 (list funcallable-instance-header-type
23 simple-fun-header-type
24 closure-fun-header-type
27 (defun canonicalize-headers (headers)
31 (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
33 (results (if (= start prev)
36 (dolist (header (sort headers #'<))
40 ((= header (+ prev delta))
51 (macrolet ((test-type (value target not-p &rest type-codes)
52 ;; Determine what interesting combinations we need to test for.
53 (let* ((type-codes (mapcar #'eval type-codes))
54 (fixnump (and (member even-fixnum-lowtag type-codes)
55 (member odd-fixnum-lowtag type-codes)
57 (lowtags (remove lowtag-limit type-codes :test #'<))
58 (extended (remove lowtag-limit type-codes :test #'>))
59 (immediates (intersection extended *immediate-types* :test #'eql))
60 (headers (set-difference extended *immediate-types* :test #'eql))
61 (function-p (if (intersection headers *fun-header-types*)
62 (if (subsetp headers *fun-header-types*)
64 (error "can't test for mix of function subtypes ~
65 and normal header types"))
68 (error "At least one type must be supplied for TEST-TYPE."))
71 (when (remove-if #'(lambda (x)
72 (or (= x even-fixnum-lowtag)
73 (= x odd-fixnum-lowtag)))
75 (error "can't mix fixnum testing with other lowtags"))
77 (error "can't mix fixnum testing with function subtype testing"))
79 (error "can't mix fixnum testing with other immediates"))
81 `(%test-fixnum-and-headers ,value ,target ,not-p
82 ',(canonicalize-headers headers))
83 `(%test-fixnum ,value ,target ,not-p)))
86 (error "can't mix testing of immediates with testing of headers"))
88 (error "can't mix testing of immediates with testing of lowtags"))
89 (when (cdr immediates)
90 (error "can't test multiple immediates at the same time"))
91 `(%test-immediate ,value ,target ,not-p ,(car immediates)))
94 (error "can't test multiple lowtags at the same time"))
96 `(%test-lowtag-and-headers
97 ,value ,target ,not-p ,(car lowtags)
98 ,function-p ',(canonicalize-headers headers))
99 `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
101 `(%test-headers ,value ,target ,not-p ,function-p
102 ',(canonicalize-headers headers)))
104 (error "nothing to test?"))))))
106 ;;; Emit the most compact form of the test immediate instruction,
107 ;;; using an 8 bit test when the immediate is only 8 bits and the
108 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
110 (defun generate-fixnum-test (value)
111 (let ((offset (tn-offset value)))
112 (cond ((and (sc-is value any-reg descriptor-reg)
113 (or (= offset eax-offset) (= offset ebx-offset)
114 (= offset ecx-offset) (= offset edx-offset)))
115 (inst test (make-random-tn :kind :normal
116 :sc (sc-or-lose 'byte-reg)
119 ((sc-is value control-stack)
120 (inst test (make-ea :byte :base ebp-tn
121 :disp (- (* (1+ offset) sb!vm:word-bytes)))
124 (inst test value 3)))))
126 (defun %test-fixnum (value target not-p)
127 (generate-fixnum-test value)
128 (inst jmp (if not-p :nz :z) target))
130 (defun %test-fixnum-and-headers (value target not-p headers)
131 (let ((drop-through (gen-label)))
132 (generate-fixnum-test value)
133 (inst jmp :z (if not-p drop-through target))
134 (%test-headers value target not-p nil headers drop-through)))
136 (defun %test-immediate (value target not-p immediate)
137 ;; Code a single instruction byte test if possible.
138 (let ((offset (tn-offset value)))
139 (cond ((and (sc-is value any-reg descriptor-reg)
140 (or (= offset eax-offset) (= offset ebx-offset)
141 (= offset ecx-offset) (= offset edx-offset)))
142 (inst cmp (make-random-tn :kind :normal
143 :sc (sc-or-lose 'byte-reg)
148 (inst cmp al-tn immediate))))
149 (inst jmp (if not-p :ne :e) target))
151 (defun %test-lowtag (value target not-p lowtag &optional al-loaded)
154 (inst and al-tn lowtag-mask))
155 (inst cmp al-tn lowtag)
156 (inst jmp (if not-p :ne :e) target))
158 (defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
159 (let ((drop-through (gen-label)))
160 (%test-lowtag value (if not-p drop-through target) nil lowtag)
161 (%test-headers value target not-p function-p headers drop-through t)))
164 (defun %test-headers (value target not-p function-p headers
165 &optional (drop-through (gen-label)) al-loaded)
166 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
167 (multiple-value-bind (equal less-or-equal when-true when-false)
168 ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
169 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
170 ;; it's true and when we know it's false respectively.
172 (values :ne :a drop-through target)
173 (values :e :na target drop-through))
174 (%test-lowtag value when-false t lowtag al-loaded)
175 (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
176 (do ((remaining headers (cdr remaining)))
178 (let ((header (car remaining))
179 (last (null (cdr remaining))))
182 (inst cmp al-tn header)
184 (inst jmp equal target)
185 (inst jmp :e when-true)))
187 (let ((start (car header))
189 (unless (= start bignum-type)
190 (inst cmp al-tn start)
191 (inst jmp :b when-false)) ; was :l
194 (inst jmp less-or-equal target)
195 (inst jmp :be when-true))))))) ; was :le
196 (emit-label drop-through))))
198 ;; pw -- based on RISC version. Not sure extra hair is needed yet.
199 ;; difference is that this one uses SUB which overwrites operand
200 ;; both cmp and sub take 2 cycles so maybe its a wash
202 (defun %test-headers (value target not-p function-p headers
203 &optional (drop-through (gen-label)) al-loaded)
204 (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
205 (multiple-value-bind (equal less-or-equal when-true when-false)
206 ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
207 ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
208 ;; it's true and when we know it's false respectively.
210 (values :ne :a drop-through target)
211 (values :e :na target drop-through))
212 (%test-lowtag value when-false t lowtag al-loaded)
213 (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
215 (do ((remaining headers (cdr remaining)))
217 (let ((header (car remaining))
218 (last (null (cdr remaining))))
221 (inst sub al-tn (- header delta))
224 (inst jmp equal target)
225 (inst jmp :e when-true)))
227 (let ((start (car header))
229 (unless (= start bignum-type)
230 (inst sub al-tn (- start delta))
232 (inst jmp :l when-false))
233 (inst sub al-tn (- end delta))
236 (inst jmp less-or-equal target)
237 (inst jmp :le when-true))))))))
238 (emit-label drop-through))))
240 ;;;; type checking and testing
242 (define-vop (check-type)
243 (:args (value :target result :scs (any-reg descriptor-reg)))
244 (:results (result :scs (any-reg descriptor-reg)))
245 (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
248 (:save-p :compute-only))
250 (define-vop (type-predicate)
251 (:args (value :scs (any-reg descriptor-reg)))
252 (:temporary (:sc unsigned-reg :offset eax-offset) eax)
256 (:policy :fast-safe))
258 ;;; simpler VOP that don't need a temporary register
259 (define-vop (simple-check-type)
260 (:args (value :target result :scs (any-reg descriptor-reg)))
261 (:results (result :scs (any-reg descriptor-reg)
262 :load-if (not (and (sc-is value any-reg descriptor-reg)
263 (sc-is result control-stack)))))
265 (:save-p :compute-only))
267 (define-vop (simple-type-predicate)
268 (:args (value :scs (any-reg descriptor-reg control-stack)))
271 (:policy :fast-safe))
273 (eval-when (:compile-toplevel :execute)
275 (defun cost-to-test-types (type-codes)
276 (+ (* 2 (length type-codes))
277 (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
281 ;;; FIXME: DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS are only used in
282 ;;; this file, so they should be in the EVAL-WHEN above, or otherwise
283 ;;; tweaked so that they don't appear in the target system.
285 (defmacro def-type-vops (pred-name check-name ptype error-code
287 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
290 `((define-vop (,pred-name type-predicate)
291 (:translate ,pred-name)
293 (test-type value target not-p ,@type-codes)))))
295 `((define-vop (,check-name check-type)
298 (generate-error-code vop ,error-code value)))
299 (test-type value err-lab t ,@type-codes)
300 (move result value))))))
302 `((primitive-type-vop ,check-name (:check) ,ptype))))))
304 (defmacro def-simple-type-vops (pred-name check-name ptype error-code
306 (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
309 `((define-vop (,pred-name simple-type-predicate)
310 (:translate ,pred-name)
312 (test-type value target not-p ,@type-codes)))))
314 `((define-vop (,check-name simple-check-type)
317 (generate-error-code vop ,error-code value)))
318 (test-type value err-lab t ,@type-codes)
319 (move result value))))))
321 `((primitive-type-vop ,check-name (:check) ,ptype))))))
323 (def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
324 even-fixnum-lowtag odd-fixnum-lowtag)
326 (def-type-vops functionp check-function function
327 object-not-function-error fun-pointer-lowtag)
329 (def-type-vops listp check-list list object-not-list-error
332 (def-type-vops %instancep check-instance instance object-not-instance-error
333 instance-pointer-lowtag)
335 (def-type-vops bignump check-bignum bignum
336 object-not-bignum-error bignum-type)
338 (def-type-vops ratiop check-ratio ratio
339 object-not-ratio-error ratio-type)
341 (def-type-vops complexp check-complex complex object-not-complex-error
342 complex-type complex-single-float-type complex-double-float-type
343 #!+long-float complex-long-float-type)
345 (def-type-vops complex-rational-p check-complex-rational nil
346 object-not-complex-rational-error complex-type)
348 (def-type-vops complex-float-p check-complex-float nil
349 object-not-complex-float-error
350 complex-single-float-type complex-double-float-type
351 #!+long-float complex-long-float-type)
353 (def-type-vops complex-single-float-p check-complex-single-float
354 complex-single-float object-not-complex-single-float-error
355 complex-single-float-type)
357 (def-type-vops complex-double-float-p check-complex-double-float
358 complex-double-float object-not-complex-double-float-error
359 complex-double-float-type)
362 (def-type-vops complex-long-float-p check-complex-long-float
363 complex-long-float object-not-complex-long-float-error
364 complex-long-float-type)
366 (def-type-vops single-float-p check-single-float single-float
367 object-not-single-float-error single-float-type)
369 (def-type-vops double-float-p check-double-float double-float
370 object-not-double-float-error double-float-type)
373 (def-type-vops long-float-p check-long-float long-float
374 object-not-long-float-error long-float-type)
376 (def-type-vops simple-string-p check-simple-string simple-string
377 object-not-simple-string-error simple-string-type)
379 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
380 object-not-simple-bit-vector-error simple-bit-vector-type)
382 (def-type-vops simple-vector-p check-simple-vector simple-vector
383 object-not-simple-vector-error simple-vector-type)
385 (def-type-vops simple-array-unsigned-byte-2-p
386 check-simple-array-unsigned-byte-2
387 simple-array-unsigned-byte-2
388 object-not-simple-array-unsigned-byte-2-error
389 simple-array-unsigned-byte-2-type)
391 (def-type-vops simple-array-unsigned-byte-4-p
392 check-simple-array-unsigned-byte-4
393 simple-array-unsigned-byte-4
394 object-not-simple-array-unsigned-byte-4-error
395 simple-array-unsigned-byte-4-type)
397 (def-type-vops simple-array-unsigned-byte-8-p
398 check-simple-array-unsigned-byte-8
399 simple-array-unsigned-byte-8
400 object-not-simple-array-unsigned-byte-8-error
401 simple-array-unsigned-byte-8-type)
403 (def-type-vops simple-array-unsigned-byte-16-p
404 check-simple-array-unsigned-byte-16
405 simple-array-unsigned-byte-16
406 object-not-simple-array-unsigned-byte-16-error
407 simple-array-unsigned-byte-16-type)
409 (def-type-vops simple-array-unsigned-byte-32-p
410 check-simple-array-unsigned-byte-32
411 simple-array-unsigned-byte-32
412 object-not-simple-array-unsigned-byte-32-error
413 simple-array-unsigned-byte-32-type)
415 (def-type-vops simple-array-signed-byte-8-p
416 check-simple-array-signed-byte-8
417 simple-array-signed-byte-8
418 object-not-simple-array-signed-byte-8-error
419 simple-array-signed-byte-8-type)
421 (def-type-vops simple-array-signed-byte-16-p
422 check-simple-array-signed-byte-16
423 simple-array-signed-byte-16
424 object-not-simple-array-signed-byte-16-error
425 simple-array-signed-byte-16-type)
427 (def-type-vops simple-array-signed-byte-30-p
428 check-simple-array-signed-byte-30
429 simple-array-signed-byte-30
430 object-not-simple-array-signed-byte-30-error
431 simple-array-signed-byte-30-type)
433 (def-type-vops simple-array-signed-byte-32-p
434 check-simple-array-signed-byte-32
435 simple-array-signed-byte-32
436 object-not-simple-array-signed-byte-32-error
437 simple-array-signed-byte-32-type)
439 (def-type-vops simple-array-single-float-p check-simple-array-single-float
440 simple-array-single-float object-not-simple-array-single-float-error
441 simple-array-single-float-type)
443 (def-type-vops simple-array-double-float-p check-simple-array-double-float
444 simple-array-double-float object-not-simple-array-double-float-error
445 simple-array-double-float-type)
448 (def-type-vops simple-array-long-float-p check-simple-array-long-float
449 simple-array-long-float object-not-simple-array-long-float-error
450 simple-array-long-float-type)
452 (def-type-vops simple-array-complex-single-float-p
453 check-simple-array-complex-single-float
454 simple-array-complex-single-float
455 object-not-simple-array-complex-single-float-error
456 simple-array-complex-single-float-type)
458 (def-type-vops simple-array-complex-double-float-p
459 check-simple-array-complex-double-float
460 simple-array-complex-double-float
461 object-not-simple-array-complex-double-float-error
462 simple-array-complex-double-float-type)
465 (def-type-vops simple-array-complex-long-float-p
466 check-simple-array-complex-long-float
467 simple-array-complex-long-float
468 object-not-simple-array-complex-long-float-error
469 simple-array-complex-long-float-type)
471 (def-type-vops base-char-p check-base-char base-char
472 object-not-base-char-error base-char-type)
474 (def-type-vops system-area-pointer-p check-system-area-pointer
475 system-area-pointer object-not-sap-error sap-type)
477 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
478 object-not-weak-pointer-error weak-pointer-type)
480 (def-type-vops code-component-p nil nil nil
483 (def-type-vops lra-p nil nil nil
484 return-pc-header-type)
486 (def-type-vops fdefn-p nil nil nil
489 (def-type-vops funcallable-instance-p nil nil nil
490 funcallable-instance-header-type)
492 (def-type-vops array-header-p nil nil nil
493 simple-array-type complex-string-type complex-bit-vector-type
494 complex-vector-type complex-array-type)
496 (def-type-vops stringp check-string nil object-not-string-error
497 simple-string-type complex-string-type)
499 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
500 simple-bit-vector-type complex-bit-vector-type)
502 (def-type-vops vectorp check-vector nil object-not-vector-error
503 simple-string-type simple-bit-vector-type simple-vector-type
504 simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
505 simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
506 simple-array-unsigned-byte-32-type
507 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
508 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
509 simple-array-single-float-type simple-array-double-float-type
510 #!+long-float simple-array-long-float-type
511 simple-array-complex-single-float-type
512 simple-array-complex-double-float-type
513 #!+long-float simple-array-complex-long-float-type
514 complex-string-type complex-bit-vector-type complex-vector-type)
516 ;;; Note that this "type VOP" is sort of an oddball; it doesn't so
517 ;;; much test for a Lisp-level type as just expose a low-level type
518 ;;; code at the Lisp level. It is used as a building block to help us
519 ;;; to express things like the test for (TYPEP FOO '(VECTOR T))
520 ;;; efficiently in Lisp code, but it doesn't correspond to any type
521 ;;; expression which would actually occur in reasonable application
522 ;;; code. (Common Lisp doesn't have any natural way of expressing this
523 ;;; type.) Thus, there's no point in building up the full machinery of
524 ;;; associated backend type predicates and so forth as we do for
525 ;;; ordinary type VOPs.
526 (def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
529 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
530 simple-array-type simple-string-type simple-bit-vector-type
531 simple-vector-type simple-array-unsigned-byte-2-type
532 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
533 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
534 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
535 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
536 simple-array-single-float-type simple-array-double-float-type
537 #!+long-float simple-array-long-float-type
538 simple-array-complex-single-float-type
539 simple-array-complex-double-float-type
540 #!+long-float simple-array-complex-long-float-type)
542 (def-type-vops arrayp check-array nil object-not-array-error
543 simple-array-type simple-string-type simple-bit-vector-type
544 simple-vector-type simple-array-unsigned-byte-2-type
545 simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
546 simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
547 simple-array-signed-byte-8-type simple-array-signed-byte-16-type
548 simple-array-signed-byte-30-type simple-array-signed-byte-32-type
549 simple-array-single-float-type simple-array-double-float-type
550 #!+long-float simple-array-long-float-type
551 simple-array-complex-single-float-type
552 simple-array-complex-double-float-type
553 #!+long-float simple-array-complex-long-float-type
554 complex-string-type complex-bit-vector-type complex-vector-type
557 (def-type-vops numberp check-number nil object-not-number-error
558 even-fixnum-lowtag odd-fixnum-lowtag bignum-type ratio-type
559 single-float-type double-float-type #!+long-float long-float-type complex-type
560 complex-single-float-type complex-double-float-type
561 #!+long-float complex-long-float-type)
563 (def-type-vops rationalp check-rational nil object-not-rational-error
564 even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type)
566 (def-type-vops integerp check-integer nil object-not-integer-error
567 even-fixnum-lowtag odd-fixnum-lowtag bignum-type)
569 (def-type-vops floatp check-float nil object-not-float-error
570 single-float-type double-float-type #!+long-float long-float-type)
572 (def-type-vops realp check-real nil object-not-real-error
573 even-fixnum-lowtag odd-fixnum-lowtag ratio-type bignum-type
574 single-float-type double-float-type #!+long-float long-float-type)
576 ;;;; other integer ranges
578 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
579 ;;; exactly one digit.
581 (define-vop (signed-byte-32-p type-predicate)
582 (:translate signed-byte-32-p)
584 (multiple-value-bind (yep nope)
586 (values not-target target)
587 (values target not-target))
588 (generate-fixnum-test value)
591 (inst and al-tn lowtag-mask)
592 (inst cmp al-tn other-pointer-lowtag)
594 (loadw eax-tn value 0 other-pointer-lowtag)
595 (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
596 (inst jmp (if not-p :ne :e) target))
599 (define-vop (check-signed-byte-32 check-type)
601 (let ((nope (generate-error-code vop
602 object-not-signed-byte-32-error
604 (generate-fixnum-test value)
607 (inst and al-tn lowtag-mask)
608 (inst cmp al-tn other-pointer-lowtag)
610 (loadw eax-tn value 0 other-pointer-lowtag)
611 (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
614 (move result value)))
616 ;;; An (unsigned-byte 32) can be represented with either a positive
617 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
618 ;;; exactly two digits and the second digit all zeros.
619 (define-vop (unsigned-byte-32-p type-predicate)
620 (:translate unsigned-byte-32-p)
622 (let ((not-target (gen-label))
623 (single-word (gen-label))
624 (fixnum (gen-label)))
625 (multiple-value-bind (yep nope)
627 (values not-target target)
628 (values target not-target))
630 (generate-fixnum-test value)
634 ;; If not, is it an other pointer?
635 (inst and al-tn lowtag-mask)
636 (inst cmp al-tn other-pointer-lowtag)
639 (loadw eax-tn value 0 other-pointer-lowtag)
641 (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
642 (inst jmp :e single-word)
643 ;; If it's other than two, we can't be an (unsigned-byte 32)
644 (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
646 ;; Get the second digit.
647 (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
648 ;; All zeros, its an (unsigned-byte 32).
649 (inst or eax-tn eax-tn)
653 (emit-label single-word)
654 ;; Get the single digit.
655 (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
657 ;; positive implies (unsigned-byte 32).
659 (inst or eax-tn eax-tn)
660 (inst jmp (if not-p :s :ns) target)
662 (emit-label not-target)))))
664 (define-vop (check-unsigned-byte-32 check-type)
667 (generate-error-code vop object-not-unsigned-byte-32-error value))
670 (single-word (gen-label)))
673 (generate-fixnum-test value)
677 ;; If not, is it an other pointer?
678 (inst and al-tn lowtag-mask)
679 (inst cmp al-tn other-pointer-lowtag)
682 (loadw eax-tn value 0 other-pointer-lowtag)
684 (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
685 (inst jmp :e single-word)
686 ;; If it's other than two, we can't be an (unsigned-byte 32)
687 (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
689 ;; Get the second digit.
690 (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
691 ;; All zeros, its an (unsigned-byte 32).
692 (inst or eax-tn eax-tn)
696 (emit-label single-word)
697 ;; Get the single digit.
698 (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
700 ;; positive implies (unsigned-byte 32).
702 (inst or eax-tn eax-tn)
706 (move result value))))
708 ;;;; list/symbol types
710 ;;; symbolp (or symbol (eq nil))
711 ;;; consp (and list (not (eq nil)))
713 (define-vop (symbolp type-predicate)
716 (let ((is-symbol-label (if not-p drop-thru target)))
717 (inst cmp value nil-value)
718 (inst jmp :e is-symbol-label)
719 (test-type value target not-p symbol-header-type))
722 (define-vop (check-symbol check-type)
724 (let ((error (generate-error-code vop object-not-symbol-error value)))
725 (inst cmp value nil-value)
726 (inst jmp :e drop-thru)
727 (test-type value error t symbol-header-type))
729 (move result value)))
731 (define-vop (consp type-predicate)
734 (let ((is-not-cons-label (if not-p target drop-thru)))
735 (inst cmp value nil-value)
736 (inst jmp :e is-not-cons-label)
737 (test-type value target not-p list-pointer-lowtag))
740 (define-vop (check-cons check-type)
742 (let ((error (generate-error-code vop object-not-cons-error value)))
743 (inst cmp value nil-value)
745 (test-type value error t list-pointer-lowtag)
746 (move result value))))