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-type base-char-type))
  20
  21 (defparameter function-header-types
  22   (list funcallable-instance-header-type
  23         byte-code-function-type byte-code-closure-type
  24         function-header-type closure-function-header-type
  25         closure-header-type))
  26
  27 (defun canonicalize-headers (headers)
  28   (collect ((results))
  29     (let ((start nil)
  30           (prev nil)
  31           (delta (- other-immediate-1-type other-immediate-0-type)))
  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-type type-codes)
  55                        (member odd-fixnum-type 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 function-header-types)
  62                          (if (subsetp headers function-header-types)
  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-type)
  73                                (= x odd-fixnum-type)))
  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) sb!vm: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 function-pointer-type other-pointer-type)))
 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-type)
 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 function-pointer-type other-pointer-type)))
 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-type)
 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-type odd-fixnum-type)
 325
 326 (def-type-vops functionp check-function function
 327   object-not-function-error function-pointer-type)
 328
 329 (def-type-vops listp check-list list object-not-list-error
 330   list-pointer-type)
 331
 332 (def-type-vops %instancep check-instance instance object-not-instance-error
 333   instance-pointer-type)
 334
 335 (def-type-vops bignump check-bignum bignum
 336   object-not-bignum-error bignum-type)
 337
 338 (def-type-vops ratiop check-ratio ratio
 339   object-not-ratio-error ratio-type)
 340
 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)
 344
 345 (def-type-vops complex-rational-p check-complex-rational nil
 346   object-not-complex-rational-error complex-type)
 347
 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)
 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-type)
 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-type)
 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-type)
 365
 366 (def-type-vops single-float-p check-single-float single-float
 367   object-not-single-float-error single-float-type)
 368
 369 (def-type-vops double-float-p check-double-float double-float
 370   object-not-double-float-error double-float-type)
 371
 372 #!+long-float
 373 (def-type-vops long-float-p check-long-float long-float
 374   object-not-long-float-error long-float-type)
 375
 376 (def-type-vops simple-string-p check-simple-string simple-string
 377   object-not-simple-string-error simple-string-type)
 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-type)
 381
 382 (def-type-vops simple-vector-p check-simple-vector simple-vector
 383   object-not-simple-vector-error simple-vector-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 470
 471 (def-type-vops base-char-p check-base-char base-char
 472   object-not-base-char-error base-char-type)
 473
 474 (def-type-vops system-area-pointer-p check-system-area-pointer
 475   system-area-pointer object-not-sap-error sap-type)
 476
 477 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 478   object-not-weak-pointer-error weak-pointer-type)
 479
 480 (def-type-vops code-component-p nil nil nil
 481   code-header-type)
 482
 483 (def-type-vops lra-p nil nil nil
 484   return-pc-header-type)
 485
 486 (def-type-vops fdefn-p nil nil nil
 487   fdefn-type)
 488
 489 (def-type-vops funcallable-instance-p nil nil nil
 490   funcallable-instance-header-type)
 491
 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)
 495
 496 (def-type-vops nil check-function-or-symbol nil
 497   object-not-function-or-symbol-error
 498   function-pointer-type symbol-header-type)
 499
 500 (def-type-vops stringp check-string nil object-not-string-error
 501   simple-string-type complex-string-type)
 502
 503 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 504   simple-bit-vector-type complex-bit-vector-type)
 505
 506 (def-type-vops vectorp check-vector nil object-not-vector-error
 507   simple-string-type simple-bit-vector-type simple-vector-type
 508   simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
 509   simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
 510   simple-array-unsigned-byte-32-type
 511   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 512   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 513   simple-array-single-float-type simple-array-double-float-type
 514   #!+long-float simple-array-long-float-type
 515   simple-array-complex-single-float-type
 516   simple-array-complex-double-float-type
 517   #!+long-float simple-array-complex-long-float-type
 518   complex-string-type complex-bit-vector-type complex-vector-type)
 519
 520 ;;; Note that this "type VOP" is sort of an oddball; it doesn't so
 521 ;;; much test for a Lisp-level type as just expose a low-level type
 522 ;;; code at the Lisp level. It is used as a building block to help us
 523 ;;; to express things like the test for (TYPEP FOO '(VECTOR T))
 524 ;;; efficiently in Lisp code, but it doesn't correspond to any type
 525 ;;; expression which would actually occur in reasonable application
 526 ;;; code. (Common Lisp doesn't have any natural way of expressing this
 527 ;;; type.) Thus, there's no point in building up the full machinery of
 528 ;;; associated backend type predicates and so forth as we do for
 529 ;;; ordinary type VOPs.
 530 (def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
 531   complex-vector-type)
 532
 533 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 534   simple-array-type simple-string-type simple-bit-vector-type
 535   simple-vector-type simple-array-unsigned-byte-2-type
 536   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 537   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 538   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 539   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 540   simple-array-single-float-type simple-array-double-float-type
 541   #!+long-float simple-array-long-float-type
 542   simple-array-complex-single-float-type
 543   simple-array-complex-double-float-type
 544   #!+long-float simple-array-complex-long-float-type)
 545
 546 (def-type-vops arrayp check-array nil object-not-array-error
 547   simple-array-type simple-string-type simple-bit-vector-type
 548   simple-vector-type simple-array-unsigned-byte-2-type
 549   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 550   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 551   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 552   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 553   simple-array-single-float-type simple-array-double-float-type
 554   #!+long-float simple-array-long-float-type
 555   simple-array-complex-single-float-type
 556   simple-array-complex-double-float-type
 557   #!+long-float simple-array-complex-long-float-type
 558   complex-string-type complex-bit-vector-type complex-vector-type
 559   complex-array-type)
 560
 561 (def-type-vops numberp check-number nil object-not-number-error
 562   even-fixnum-type odd-fixnum-type bignum-type ratio-type
 563   single-float-type double-float-type #!+long-float long-float-type complex-type
 564   complex-single-float-type complex-double-float-type
 565   #!+long-float complex-long-float-type)
 566
 567 (def-type-vops rationalp check-rational nil object-not-rational-error
 568   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
 569
 570 (def-type-vops integerp check-integer nil object-not-integer-error
 571   even-fixnum-type odd-fixnum-type bignum-type)
 572
 573 (def-type-vops floatp check-float nil object-not-float-error
 574   single-float-type double-float-type #!+long-float long-float-type)
 575
 576 (def-type-vops realp check-real nil object-not-real-error
 577   even-fixnum-type odd-fixnum-type ratio-type bignum-type
 578   single-float-type double-float-type #!+long-float long-float-type)
 579 \f
 580 ;;;; other integer ranges
 581
 582 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
 583 ;;; exactly one digit.
 584
 585 (define-vop (signed-byte-32-p type-predicate)
 586   (:translate signed-byte-32-p)
 587   (:generator 45
 588     (multiple-value-bind (yep nope)
 589         (if not-p
 590             (values not-target target)
 591             (values target not-target))
 592       (generate-fixnum-test value)
 593       (inst jmp :e yep)
 594       (move eax-tn value)
 595       (inst and al-tn lowtag-mask)
 596       (inst cmp al-tn other-pointer-type)
 597       (inst jmp :ne nope)
 598       (loadw eax-tn value 0 other-pointer-type)
 599       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 600       (inst jmp (if not-p :ne :e) target))
 601     NOT-TARGET))
 602
 603 (define-vop (check-signed-byte-32 check-type)
 604   (:generator 45
 605     (let ((nope (generate-error-code vop
 606                                      object-not-signed-byte-32-error
 607                                      value)))
 608       (generate-fixnum-test value)
 609       (inst jmp :e yep)
 610       (move eax-tn value)
 611       (inst and al-tn lowtag-mask)
 612       (inst cmp al-tn other-pointer-type)
 613       (inst jmp :ne nope)
 614       (loadw eax-tn value 0 other-pointer-type)
 615       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 616       (inst jmp :ne nope))
 617     YEP
 618     (move result value)))
 619
 620 ;;; An (unsigned-byte 32) can be represented with either a positive
 621 ;;; fixnum, a bignum with exactly one positive digit, or a bignum with
 622 ;;; exactly two digits and the second digit all zeros.
 623
 624 (define-vop (unsigned-byte-32-p type-predicate)
 625   (:translate unsigned-byte-32-p)
 626   (:generator 45
 627     (let ((not-target (gen-label))
 628           (single-word (gen-label))
 629           (fixnum (gen-label)))
 630       (multiple-value-bind (yep nope)
 631           (if not-p
 632               (values not-target target)
 633               (values target not-target))
 634         ;; Is it a fixnum?
 635         (generate-fixnum-test value)
 636         (move eax-tn value)
 637         (inst jmp :e fixnum)
 638
 639         ;; If not, is it an other pointer?
 640         (inst and al-tn lowtag-mask)
 641         (inst cmp al-tn other-pointer-type)
 642         (inst jmp :ne nope)
 643         ;; Get the header.
 644         (loadw eax-tn value 0 other-pointer-type)
 645         ;; Is it one?
 646         (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 647         (inst jmp :e single-word)
 648         ;; If it's other than two, we can't be an (unsigned-byte 32)
 649         (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
 650         (inst jmp :ne nope)
 651         ;; Get the second digit.
 652         (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 653         ;; All zeros, its an (unsigned-byte 32).
 654         (inst or eax-tn eax-tn)
 655         (inst jmp :z yep)
 656         (inst jmp nope)
 657
 658         (emit-label single-word)
 659         ;; Get the single digit.
 660         (loadw eax-tn value bignum-digits-offset other-pointer-type)
 661
 662         ;; positive implies (unsigned-byte 32).
 663         (emit-label fixnum)
 664         (inst or eax-tn eax-tn)
 665         (inst jmp (if not-p :s :ns) target)
 666
 667         (emit-label not-target)))))
 668
 669 (define-vop (check-unsigned-byte-32 check-type)
 670   (:generator 45
 671     (let ((nope
 672            (generate-error-code vop object-not-unsigned-byte-32-error value))
 673           (yep (gen-label))
 674           (fixnum (gen-label))
 675           (single-word (gen-label)))
 676
 677       ;; Is it a fixnum?
 678       (generate-fixnum-test value)
 679       (move eax-tn value)
 680       (inst jmp :e fixnum)
 681
 682       ;; If not, is it an other pointer?
 683       (inst and al-tn lowtag-mask)
 684       (inst cmp al-tn other-pointer-type)
 685       (inst jmp :ne nope)
 686       ;; Get the header.
 687       (loadw eax-tn value 0 other-pointer-type)
 688       ;; Is it one?
 689       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 690       (inst jmp :e single-word)
 691       ;; If it's other than two, we can't be an (unsigned-byte 32)
 692       (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
 693       (inst jmp :ne nope)
 694       ;; Get the second digit.
 695       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 696       ;; All zeros, its an (unsigned-byte 32).
 697       (inst or eax-tn eax-tn)
 698       (inst jmp :z yep)
 699       (inst jmp nope)
 700
 701       (emit-label single-word)
 702       ;; Get the single digit.
 703       (loadw eax-tn value bignum-digits-offset other-pointer-type)
 704
 705       ;; positive implies (unsigned-byte 32).
 706       (emit-label fixnum)
 707       (inst or eax-tn eax-tn)
 708       (inst jmp :s nope)
 709
 710       (emit-label yep)
 711       (move result value))))
 712 \f
 713 ;;;; list/symbol types
 714 ;;;
 715 ;;; symbolp (or symbol (eq nil))
 716 ;;; consp (and list (not (eq nil)))
 717
 718 (define-vop (symbolp type-predicate)
 719   (:translate symbolp)
 720   (:generator 12
 721     (let ((is-symbol-label (if not-p drop-thru target)))
 722       (inst cmp value nil-value)
 723       (inst jmp :e is-symbol-label)
 724       (test-type value target not-p symbol-header-type))
 725     DROP-THRU))
 726
 727 (define-vop (check-symbol check-type)
 728   (:generator 12
 729     (let ((error (generate-error-code vop object-not-symbol-error value)))
 730       (inst cmp value nil-value)
 731       (inst jmp :e drop-thru)
 732       (test-type value error t symbol-header-type))
 733     DROP-THRU
 734     (move result value)))
 735
 736 (define-vop (consp type-predicate)
 737   (:translate consp)
 738   (:generator 8
 739     (let ((is-not-cons-label (if not-p target drop-thru)))
 740       (inst cmp value nil-value)
 741       (inst jmp :e is-not-cons-label)
 742       (test-type value target not-p list-pointer-type))
 743     DROP-THRU))
 744
 745 (define-vop (check-cons check-type)
 746   (:generator 8
 747     (let ((error (generate-error-code vop object-not-cons-error value)))
 748       (inst cmp value nil-value)
 749       (inst jmp :e error)
 750       (test-type value error t list-pointer-type)
 751       (move result value))))
 752 \f
 753 ) ; MACROLET