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 *fun-header-types*
  22   (list funcallable-instance-header-type
  23         simple-fun-header-type
  24         closure-fun-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 *fun-header-types*)
  62                          (if (subsetp headers *fun-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 fun-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 fun-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 fun-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 stringp check-string nil object-not-string-error
 497   simple-string-type complex-string-type)
 498
 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)
 501
 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)
 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-type)
 528
 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)
 541
 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
 555   complex-array-type)
 556
 557 (def-type-vops numberp check-number nil object-not-number-error
 558   even-fixnum-type odd-fixnum-type 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)
 562
 563 (def-type-vops rationalp check-rational nil object-not-rational-error
 564   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
 565
 566 (def-type-vops integerp check-integer nil object-not-integer-error
 567   even-fixnum-type odd-fixnum-type bignum-type)
 568
 569 (def-type-vops floatp check-float nil object-not-float-error
 570   single-float-type double-float-type #!+long-float long-float-type)
 571
 572 (def-type-vops realp check-real nil object-not-real-error
 573   even-fixnum-type odd-fixnum-type ratio-type bignum-type
 574   single-float-type double-float-type #!+long-float long-float-type)
 575 \f
 576 ;;;; other integer ranges
 577
 578 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
 579 ;;; exactly one digit.
 580
 581 (define-vop (signed-byte-32-p type-predicate)
 582   (:translate signed-byte-32-p)
 583   (:generator 45
 584     (multiple-value-bind (yep nope)
 585         (if not-p
 586             (values not-target target)
 587             (values target not-target))
 588       (generate-fixnum-test value)
 589       (inst jmp :e yep)
 590       (move eax-tn value)
 591       (inst and al-tn lowtag-mask)
 592       (inst cmp al-tn other-pointer-type)
 593       (inst jmp :ne nope)
 594       (loadw eax-tn value 0 other-pointer-type)
 595       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 596       (inst jmp (if not-p :ne :e) target))
 597     NOT-TARGET))
 598
 599 (define-vop (check-signed-byte-32 check-type)
 600   (:generator 45
 601     (let ((nope (generate-error-code vop
 602                                      object-not-signed-byte-32-error
 603                                      value)))
 604       (generate-fixnum-test value)
 605       (inst jmp :e yep)
 606       (move eax-tn value)
 607       (inst and al-tn lowtag-mask)
 608       (inst cmp al-tn other-pointer-type)
 609       (inst jmp :ne nope)
 610       (loadw eax-tn value 0 other-pointer-type)
 611       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 612       (inst jmp :ne nope))
 613     YEP
 614     (move result value)))
 615
 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)
 621   (:generator 45
 622     (let ((not-target (gen-label))
 623           (single-word (gen-label))
 624           (fixnum (gen-label)))
 625       (multiple-value-bind (yep nope)
 626           (if not-p
 627               (values not-target target)
 628               (values target not-target))
 629         ;; Is it a fixnum?
 630         (generate-fixnum-test value)
 631         (move eax-tn value)
 632         (inst jmp :e fixnum)
 633
 634         ;; If not, is it an other pointer?
 635         (inst and al-tn lowtag-mask)
 636         (inst cmp al-tn other-pointer-type)
 637         (inst jmp :ne nope)
 638         ;; Get the header.
 639         (loadw eax-tn value 0 other-pointer-type)
 640         ;; Is it one?
 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))
 645         (inst jmp :ne nope)
 646         ;; Get the second digit.
 647         (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 648         ;; All zeros, its an (unsigned-byte 32).
 649         (inst or eax-tn eax-tn)
 650         (inst jmp :z yep)
 651         (inst jmp nope)
 652
 653         (emit-label single-word)
 654         ;; Get the single digit.
 655         (loadw eax-tn value bignum-digits-offset other-pointer-type)
 656
 657         ;; positive implies (unsigned-byte 32).
 658         (emit-label fixnum)
 659         (inst or eax-tn eax-tn)
 660         (inst jmp (if not-p :s :ns) target)
 661
 662         (emit-label not-target)))))
 663
 664 (define-vop (check-unsigned-byte-32 check-type)
 665   (:generator 45
 666     (let ((nope
 667            (generate-error-code vop object-not-unsigned-byte-32-error value))
 668           (yep (gen-label))
 669           (fixnum (gen-label))
 670           (single-word (gen-label)))
 671
 672       ;; Is it a fixnum?
 673       (generate-fixnum-test value)
 674       (move eax-tn value)
 675       (inst jmp :e fixnum)
 676
 677       ;; If not, is it an other pointer?
 678       (inst and al-tn lowtag-mask)
 679       (inst cmp al-tn other-pointer-type)
 680       (inst jmp :ne nope)
 681       ;; Get the header.
 682       (loadw eax-tn value 0 other-pointer-type)
 683       ;; Is it one?
 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))
 688       (inst jmp :ne nope)
 689       ;; Get the second digit.
 690       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 691       ;; All zeros, its an (unsigned-byte 32).
 692       (inst or eax-tn eax-tn)
 693       (inst jmp :z yep)
 694       (inst jmp nope)
 695
 696       (emit-label single-word)
 697       ;; Get the single digit.
 698       (loadw eax-tn value bignum-digits-offset other-pointer-type)
 699
 700       ;; positive implies (unsigned-byte 32).
 701       (emit-label fixnum)
 702       (inst or eax-tn eax-tn)
 703       (inst jmp :s nope)
 704
 705       (emit-label yep)
 706       (move result value))))
 707 \f
 708 ;;;; list/symbol types
 709 ;;;
 710 ;;; symbolp (or symbol (eq nil))
 711 ;;; consp (and list (not (eq nil)))
 712
 713 (define-vop (symbolp type-predicate)
 714   (:translate symbolp)
 715   (:generator 12
 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))
 720     DROP-THRU))
 721
 722 (define-vop (check-symbol check-type)
 723   (:generator 12
 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))
 728     DROP-THRU
 729     (move result value)))
 730
 731 (define-vop (consp type-predicate)
 732   (:translate consp)
 733   (:generator 8
 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-type))
 738     DROP-THRU))
 739
 740 (define-vop (check-cons check-type)
 741   (:generator 8
 742     (let ((error (generate-error-code vop object-not-cons-error value)))
 743       (inst cmp value nil-value)
 744       (inst jmp :e error)
 745       (test-type value error t list-pointer-type)
 746       (move result value))))
 747 \f
 748 ) ; MACROLET