src/compiler/x86/type-vops.lisp

   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 \f
  14 ;;;; test generation utilities
  15
  16 (eval-when (:compile-toplevel :execute)
  17
  18 (defparameter *immediate-types*
  19   (list unbound-marker-widetag base-char-widetag))
  20
  21 (defparameter *fun-header-widetags*
  22   (list funcallable-instance-header-widetag
  23         simple-fun-header-widetag
  24         closure-fun-header-widetag
  25         closure-header-widetag))
  26
  27 (defun canonicalize-headers (headers)
  28   (collect ((results))
  29     (let ((start nil)
  30           (prev nil)
  31           (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  32       (flet ((emit-test ()
  33                (results (if (= start prev)
  34                             start
  35                             (cons start prev)))))
  36         (dolist (header (sort headers #'<))
  37           (cond ((null start)
  38                  (setf start header)
  39                  (setf prev header))
  40                 ((= header (+ prev delta))
  41                  (setf prev header))
  42                 (t
  43                  (emit-test)
  44                  (setf start header)
  45                  (setf prev header))))
  46         (emit-test)))
  47     (results)))
  48
  49 ) ; EVAL-WHEN
  50
  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)
  56                        t))
  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-widetags*)
  62                          (if (subsetp headers *fun-header-widetags*)
  63                              t
  64                              (error "can't test for mix of function subtypes ~
  65                                      and normal header types"))
  66                          nil)))
  67     (unless type-codes
  68       (error "At least one type must be supplied for TEST-TYPE."))
  69     (cond
  70      (fixnump
  71       (when (remove-if (lambda (x)
  72                          (or (= x even-fixnum-lowtag)
  73                              (= x odd-fixnum-lowtag)))
  74                        lowtags)
  75         (error "can't mix fixnum testing with other lowtags"))
  76       (when function-p
  77         (error "can't mix fixnum testing with function subtype testing"))
  78       (when immediates
  79         (error "can't mix fixnum testing with other immediates"))
  80       (if headers
  81           `(%test-fixnum-and-headers ,value ,target ,not-p
  82                                      ',(canonicalize-headers headers))
  83           `(%test-fixnum ,value ,target ,not-p)))
  84      (immediates
  85       (when headers
  86         (error "can't mix testing of immediates with testing of headers"))
  87       (when lowtags
  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)))
  92      (lowtags
  93       (when (cdr lowtags)
  94         (error "can't test multiple lowtags at the same time"))
  95       (if headers
  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))))
 100      (headers
 101       `(%test-headers ,value ,target ,not-p ,function-p
 102                       ',(canonicalize-headers headers)))
 103      (t
 104       (error "nothing to test?"))))))
 105
 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
 109 ;;; control stack.
 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)
 117                                       :offset offset)
 118                  3))
 119           ((sc-is value control-stack)
 120            (inst test (make-ea :byte :base ebp-tn
 121                                :disp (- (* (1+ offset) n-word-bytes)))
 122                  3))
 123           (t
 124            (inst test value 3)))))
 125
 126 (defun %test-fixnum (value target not-p)
 127   (generate-fixnum-test value)
 128   (inst jmp (if not-p :nz :z) target))
 129
 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)))
 135
 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)
 144                                      :offset offset)
 145                  immediate))
 146           (t
 147            (move eax-tn value)
 148            (inst cmp al-tn immediate))))
 149   (inst jmp (if not-p :ne :e) target))
 150
 151 (defun %test-lowtag (value target not-p lowtag &optional al-loaded)
 152   (unless al-loaded
 153     (move eax-tn value)
 154     (inst and al-tn lowtag-mask))
 155   (inst cmp al-tn lowtag)
 156   (inst jmp (if not-p :ne :e) target))
 157
 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)))
 162
 163
 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.
 171         (if not-p
 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)))
 177           ((null remaining))
 178         (let ((header (car remaining))
 179               (last (null (cdr remaining))))
 180           (cond
 181            ((atom header)
 182             (inst cmp al-tn header)
 183             (if last
 184                 (inst jmp equal target)
 185                 (inst jmp :e when-true)))
 186            (t
 187              (let ((start (car header))
 188                    (end (cdr header)))
 189                (unless (= start bignum-widetag)
 190                  (inst cmp al-tn start)
 191                  (inst jmp :b when-false)) ; was :l
 192                (inst cmp al-tn end)
 193                (if last
 194                    (inst jmp less-or-equal target)
 195                    (inst jmp :be when-true))))))) ; was :le
 196       (emit-label drop-through))))
 197
 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
 201 #+nil
 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.
 209         (if not-p
 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)))
 214       (let ((delta 0))
 215         (do ((remaining headers (cdr remaining)))
 216             ((null remaining))
 217           (let ((header (car remaining))
 218                 (last (null (cdr remaining))))
 219             (cond
 220               ((atom header)
 221                (inst sub al-tn (- header delta))
 222                (setf delta header)
 223                (if last
 224                    (inst jmp equal target)
 225                    (inst jmp :e when-true)))
 226               (t
 227                (let ((start (car header))
 228                      (end (cdr header)))
 229                  (unless (= start bignum-widetag)
 230                    (inst sub al-tn (- start delta))
 231                    (setf delta start)
 232                    (inst jmp :l when-false))
 233                  (inst sub al-tn (- end delta))
 234                  (setf delta end)
 235                  (if last
 236                      (inst jmp less-or-equal target)
 237                      (inst jmp :le when-true))))))))
 238       (emit-label drop-through))))
 239 \f
 240 ;;;; type checking and testing
 241
 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)
 246   (:ignore eax)
 247   (:vop-var vop)
 248   (:save-p :compute-only))
 249
 250 (define-vop (type-predicate)
 251   (:args (value :scs (any-reg descriptor-reg)))
 252   (:temporary (:sc unsigned-reg :offset eax-offset) eax)
 253   (:ignore eax)
 254   (:conditional)
 255   (:info target not-p)
 256   (:policy :fast-safe))
 257
 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)))))
 264   (:vop-var vop)
 265   (:save-p :compute-only))
 266
 267 (define-vop (simple-type-predicate)
 268   (:args (value :scs (any-reg descriptor-reg control-stack)))
 269   (:conditional)
 270   (:info target not-p)
 271   (:policy :fast-safe))
 272
 273 (eval-when (:compile-toplevel :execute)
 274
 275 (defun cost-to-test-types (type-codes)
 276   (+ (* 2 (length type-codes))
 277      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 278
 279 ); EVAL-WHEN
 280
 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.
 284
 285 (defmacro def-type-vops (pred-name check-name ptype error-code
 286                                    &rest type-codes)
 287   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 288     `(progn
 289        ,@(when pred-name
 290            `((define-vop (,pred-name type-predicate)
 291                (:translate ,pred-name)
 292                (:generator ,cost
 293                  (test-type value target not-p ,@type-codes)))))
 294        ,@(when check-name
 295            `((define-vop (,check-name check-type)
 296                (:generator ,cost
 297                  (let ((err-lab
 298                         (generate-error-code vop ,error-code value)))
 299                    (test-type value err-lab t ,@type-codes)
 300                    (move result value))))))
 301        ,@(when ptype
 302            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 303
 304 (defmacro def-simple-type-vops (pred-name check-name ptype error-code
 305                                           &rest type-codes)
 306   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 307     `(progn
 308        ,@(when pred-name
 309            `((define-vop (,pred-name simple-type-predicate)
 310                (:translate ,pred-name)
 311                (:generator ,cost
 312                  (test-type value target not-p ,@type-codes)))))
 313        ,@(when check-name
 314            `((define-vop (,check-name simple-check-type)
 315                (:generator ,cost
 316                  (let ((err-lab
 317                         (generate-error-code vop ,error-code value)))
 318                    (test-type value err-lab t ,@type-codes)
 319                    (move result value))))))
 320        ,@(when ptype
 321            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 322
 323 (def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
 324   even-fixnum-lowtag odd-fixnum-lowtag)
 325
 326 (def-type-vops functionp check-fun function
 327   object-not-fun-error fun-pointer-lowtag)
 328
 329 (def-type-vops listp check-list list object-not-list-error
 330   list-pointer-lowtag)
 331
 332 (def-type-vops %instancep check-instance instance object-not-instance-error
 333   instance-pointer-lowtag)
 334
 335 (def-type-vops bignump check-bignum bignum
 336   object-not-bignum-error bignum-widetag)
 337
 338 (def-type-vops ratiop check-ratio ratio
 339   object-not-ratio-error ratio-widetag)
 340
 341 (def-type-vops complexp check-complex complex object-not-complex-error
 342   complex-widetag complex-single-float-widetag complex-double-float-widetag
 343   #!+long-float complex-long-float-widetag)
 344
 345 (def-type-vops complex-rational-p check-complex-rational nil
 346   object-not-complex-rational-error complex-widetag)
 347
 348 (def-type-vops complex-float-p check-complex-float nil
 349   object-not-complex-float-error
 350   complex-single-float-widetag complex-double-float-widetag
 351   #!+long-float complex-long-float-widetag)
 352
 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-widetag)
 356
 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-widetag)
 360
 361 #!+long-float
 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-widetag)
 365
 366 (def-type-vops single-float-p check-single-float single-float
 367   object-not-single-float-error single-float-widetag)
 368
 369 (def-type-vops double-float-p check-double-float double-float
 370   object-not-double-float-error double-float-widetag)
 371
 372 #!+long-float
 373 (def-type-vops long-float-p check-long-float long-float
 374   object-not-long-float-error long-float-widetag)
 375
 376 (def-type-vops simple-string-p check-simple-string simple-string
 377   object-not-simple-string-error simple-string-widetag)
 378
 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-widetag)
 381
 382 (def-type-vops simple-vector-p check-simple-vector simple-vector
 383   object-not-simple-vector-error simple-vector-widetag)
 384
 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-widetag)
 390
 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-widetag)
 396
 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-widetag)
 402
 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-widetag)
 408
 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-widetag)
 414
 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-widetag)
 420
 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-widetag)
 426
 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-widetag)
 432
 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-widetag)
 438
 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-widetag)
 442
 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-widetag)
 446
 447 #!+long-float
 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-widetag)
 451
 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-widetag)
 457
 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-widetag)
 463
 464 #!+long-float
 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-widetag)
 470
 471 (def-type-vops base-char-p check-base-char base-char
 472   object-not-base-char-error base-char-widetag)
 473
 474 (def-type-vops system-area-pointer-p check-system-area-pointer
 475   system-area-pointer object-not-sap-error sap-widetag)
 476
 477 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 478   object-not-weak-pointer-error weak-pointer-widetag)
 479
 480 (def-type-vops code-component-p nil nil nil
 481   code-header-widetag)
 482
 483 (def-type-vops lra-p nil nil nil
 484   return-pc-header-widetag)
 485
 486 (def-type-vops fdefn-p nil nil nil
 487   fdefn-widetag)
 488
 489 (def-type-vops funcallable-instance-p nil nil nil
 490   funcallable-instance-header-widetag)
 491
 492 (def-type-vops array-header-p nil nil nil
 493   simple-array-widetag complex-string-widetag complex-bit-vector-widetag
 494   complex-vector-widetag complex-array-widetag)
 495
 496 (def-type-vops stringp check-string nil object-not-string-error
 497   simple-string-widetag complex-string-widetag)
 498
 499 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 500   simple-bit-vector-widetag complex-bit-vector-widetag)
 501
 502 (def-type-vops vectorp check-vector nil object-not-vector-error
 503   simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
 504   simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
 505   simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
 506   simple-array-unsigned-byte-32-widetag
 507   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 508   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 509   simple-array-single-float-widetag simple-array-double-float-widetag
 510   #!+long-float simple-array-long-float-widetag
 511   simple-array-complex-single-float-widetag
 512   simple-array-complex-double-float-widetag
 513   #!+long-float simple-array-complex-long-float-widetag
 514   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
 515
 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
 527   complex-vector-widetag)
 528
 529 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 530   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 531   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 532   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 533   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 534   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 535   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 536   simple-array-single-float-widetag simple-array-double-float-widetag
 537   #!+long-float simple-array-long-float-widetag
 538   simple-array-complex-single-float-widetag
 539   simple-array-complex-double-float-widetag
 540   #!+long-float simple-array-complex-long-float-widetag)
 541
 542 (def-type-vops arrayp check-array nil object-not-array-error
 543   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 544   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 545   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 546   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 547   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 548   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 549   simple-array-single-float-widetag simple-array-double-float-widetag
 550   #!+long-float simple-array-long-float-widetag
 551   simple-array-complex-single-float-widetag
 552   simple-array-complex-double-float-widetag
 553   #!+long-float simple-array-complex-long-float-widetag
 554   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
 555   complex-array-widetag)
 556
 557 (def-type-vops numberp check-number nil object-not-number-error
 558   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
 559   single-float-widetag double-float-widetag
 560   #!+long-float long-float-widetag
 561   complex-widetag complex-single-float-widetag complex-double-float-widetag
 562   #!+long-float complex-long-float-widetag)
 563
 564 (def-type-vops rationalp check-rational nil object-not-rational-error
 565   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
 566
 567 (def-type-vops integerp check-integer nil object-not-integer-error
 568   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
 569
 570 (def-type-vops floatp check-float nil object-not-float-error
 571   single-float-widetag double-float-widetag #!+long-float long-float-widetag)
 572
 573 (def-type-vops realp check-real nil object-not-real-error
 574   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
 575   single-float-widetag double-float-widetag #!+long-float long-float-widetag)
 576 \f
 577 ;;;; other integer ranges
 578
 579 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
 580 ;;; exactly one digit.
 581
 582 (define-vop (signed-byte-32-p type-predicate)
 583   (:translate signed-byte-32-p)
 584   (:generator 45
 585     (multiple-value-bind (yep nope)
 586         (if not-p
 587             (values not-target target)
 588             (values target not-target))
 589       (generate-fixnum-test value)
 590       (inst jmp :e yep)
 591       (move eax-tn value)
 592       (inst and al-tn lowtag-mask)
 593       (inst cmp al-tn other-pointer-lowtag)
 594       (inst jmp :ne nope)
 595       (loadw eax-tn value 0 other-pointer-lowtag)
 596       (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
 597       (inst jmp (if not-p :ne :e) target))
 598     NOT-TARGET))
 599
 600 (define-vop (check-signed-byte-32 check-type)
 601   (:generator 45
 602     (let ((nope (generate-error-code vop
 603                                      object-not-signed-byte-32-error
 604                                      value)))
 605       (generate-fixnum-test value)
 606       (inst jmp :e yep)
 607       (move eax-tn value)
 608       (inst and al-tn lowtag-mask)
 609       (inst cmp al-tn other-pointer-lowtag)
 610       (inst jmp :ne nope)
 611       (loadw eax-tn value 0 other-pointer-lowtag)
 612       (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
 613       (inst jmp :ne nope))
 614     YEP
 615     (move result value)))
 616
 617 ;;; An (unsigned-byte 32) can be represented with either a positive
 618 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
 619 ;;; exactly two digits and the second digit all zeros.
 620 (define-vop (unsigned-byte-32-p type-predicate)
 621   (:translate unsigned-byte-32-p)
 622   (:generator 45
 623     (let ((not-target (gen-label))
 624           (single-word (gen-label))
 625           (fixnum (gen-label)))
 626       (multiple-value-bind (yep nope)
 627           (if not-p
 628               (values not-target target)
 629               (values target not-target))
 630         ;; Is it a fixnum?
 631         (generate-fixnum-test value)
 632         (move eax-tn value)
 633         (inst jmp :e fixnum)
 634
 635         ;; If not, is it an other pointer?
 636         (inst and al-tn lowtag-mask)
 637         (inst cmp al-tn other-pointer-lowtag)
 638         (inst jmp :ne nope)
 639         ;; Get the header.
 640         (loadw eax-tn value 0 other-pointer-lowtag)
 641         ;; Is it one?
 642         (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
 643         (inst jmp :e single-word)
 644         ;; If it's other than two, we can't be an (unsigned-byte 32)
 645         (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
 646         (inst jmp :ne nope)
 647         ;; Get the second digit.
 648         (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
 649         ;; All zeros, its an (unsigned-byte 32).
 650         (inst or eax-tn eax-tn)
 651         (inst jmp :z yep)
 652         (inst jmp nope)
 653
 654         (emit-label single-word)
 655         ;; Get the single digit.
 656         (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
 657
 658         ;; positive implies (unsigned-byte 32).
 659         (emit-label fixnum)
 660         (inst or eax-tn eax-tn)
 661         (inst jmp (if not-p :s :ns) target)
 662
 663         (emit-label not-target)))))
 664
 665 (define-vop (check-unsigned-byte-32 check-type)
 666   (:generator 45
 667     (let ((nope
 668            (generate-error-code vop object-not-unsigned-byte-32-error value))
 669           (yep (gen-label))
 670           (fixnum (gen-label))
 671           (single-word (gen-label)))
 672
 673       ;; Is it a fixnum?
 674       (generate-fixnum-test value)
 675       (move eax-tn value)
 676       (inst jmp :e fixnum)
 677
 678       ;; If not, is it an other pointer?
 679       (inst and al-tn lowtag-mask)
 680       (inst cmp al-tn other-pointer-lowtag)
 681       (inst jmp :ne nope)
 682       ;; Get the header.
 683       (loadw eax-tn value 0 other-pointer-lowtag)
 684       ;; Is it one?
 685       (inst cmp eax-tn (+ (ash 1 n-widetag-bits) bignum-widetag))
 686       (inst jmp :e single-word)
 687       ;; If it's other than two, we can't be an (unsigned-byte 32)
 688       (inst cmp eax-tn (+ (ash 2 n-widetag-bits) bignum-widetag))
 689       (inst jmp :ne nope)
 690       ;; Get the second digit.
 691       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-lowtag)
 692       ;; All zeros, its an (unsigned-byte 32).
 693       (inst or eax-tn eax-tn)
 694       (inst jmp :z yep)
 695       (inst jmp nope)
 696
 697       (emit-label single-word)
 698       ;; Get the single digit.
 699       (loadw eax-tn value bignum-digits-offset other-pointer-lowtag)
 700
 701       ;; positive implies (unsigned-byte 32).
 702       (emit-label fixnum)
 703       (inst or eax-tn eax-tn)
 704       (inst jmp :s nope)
 705
 706       (emit-label yep)
 707       (move result value))))
 708 \f
 709 ;;;; list/symbol types
 710 ;;;
 711 ;;; symbolp (or symbol (eq nil))
 712 ;;; consp (and list (not (eq nil)))
 713
 714 (define-vop (symbolp type-predicate)
 715   (:translate symbolp)
 716   (:generator 12
 717     (let ((is-symbol-label (if not-p drop-thru target)))
 718       (inst cmp value nil-value)
 719       (inst jmp :e is-symbol-label)
 720       (test-type value target not-p symbol-header-widetag))
 721     DROP-THRU))
 722
 723 (define-vop (check-symbol check-type)
 724   (:generator 12
 725     (let ((error (generate-error-code vop object-not-symbol-error value)))
 726       (inst cmp value nil-value)
 727       (inst jmp :e drop-thru)
 728       (test-type value error t symbol-header-widetag))
 729     DROP-THRU
 730     (move result value)))
 731
 732 (define-vop (consp type-predicate)
 733   (:translate consp)
 734   (:generator 8
 735     (let ((is-not-cons-label (if not-p target drop-thru)))
 736       (inst cmp value nil-value)
 737       (inst jmp :e is-not-cons-label)
 738       (test-type value target not-p list-pointer-lowtag))
 739     DROP-THRU))
 740
 741 (define-vop (check-cons check-type)
 742   (:generator 8
 743     (let ((error (generate-error-code vop object-not-cons-error value)))
 744       (inst cmp value nil-value)
 745       (inst jmp :e error)
 746       (test-type value error t list-pointer-lowtag)
 747       (move result value))))
 748 \f
 749 ) ; MACROLET