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
  14 (file-comment
  15  "$Header$")
  16 \f
  17 ;;;; test generation utilities
  18
  19 (eval-when (:compile-toplevel :execute)
  20
  21 (defparameter immediate-types
  22   (list unbound-marker-type base-char-type))
  23
  24 (defparameter function-header-types
  25   (list funcallable-instance-header-type
  26         byte-code-function-type byte-code-closure-type
  27         function-header-type closure-function-header-type
  28         closure-header-type))
  29
  30 (defun canonicalize-headers (headers)
  31   (collect ((results))
  32     (let ((start nil)
  33           (prev nil)
  34           (delta (- other-immediate-1-type other-immediate-0-type)))
  35       (flet ((emit-test ()
  36                (results (if (= start prev)
  37                             start
  38                             (cons start prev)))))
  39         (dolist (header (sort headers #'<))
  40           (cond ((null start)
  41                  (setf start header)
  42                  (setf prev header))
  43                 ((= header (+ prev delta))
  44                  (setf prev header))
  45                 (t
  46                  (emit-test)
  47                  (setf start header)
  48                  (setf prev header))))
  49         (emit-test)))
  50     (results)))
  51
  52 ) ; EVAL-WHEN
  53
  54 (macrolet ((test-type (value target not-p &rest type-codes)
  55   ;; Determine what interesting combinations we need to test for.
  56   (let* ((type-codes (mapcar #'eval type-codes))
  57          (fixnump (and (member even-fixnum-type type-codes)
  58                        (member odd-fixnum-type type-codes)
  59                        t))
  60          (lowtags (remove lowtag-limit type-codes :test #'<))
  61          (extended (remove lowtag-limit type-codes :test #'>))
  62          (immediates (intersection extended immediate-types :test #'eql))
  63          (headers (set-difference extended immediate-types :test #'eql))
  64          (function-p (if (intersection headers function-header-types)
  65                          (if (subsetp headers function-header-types)
  66                              t
  67                              (error "can't test for mix of function subtypes ~
  68                                      and normal header types"))
  69                          nil)))
  70     (unless type-codes
  71       (error "At least one type must be supplied for TEST-TYPE."))
  72     (cond
  73      (fixnump
  74       (when (remove-if #'(lambda (x)
  75                            (or (= x even-fixnum-type)
  76                                (= x odd-fixnum-type)))
  77                        lowtags)
  78         (error "can't mix fixnum testing with other lowtags"))
  79       (when function-p
  80         (error "can't mix fixnum testing with function subtype testing"))
  81       (when immediates
  82         (error "can't mix fixnum testing with other immediates"))
  83       (if headers
  84           `(%test-fixnum-and-headers ,value ,target ,not-p
  85                                      ',(canonicalize-headers headers))
  86           `(%test-fixnum ,value ,target ,not-p)))
  87      (immediates
  88       (when headers
  89         (error "can't mix testing of immediates with testing of headers"))
  90       (when lowtags
  91         (error "can't mix testing of immediates with testing of lowtags"))
  92       (when (cdr immediates)
  93         (error "can't test multiple immediates at the same time"))
  94       `(%test-immediate ,value ,target ,not-p ,(car immediates)))
  95      (lowtags
  96       (when (cdr lowtags)
  97         (error "can't test multiple lowtags at the same time"))
  98       (if headers
  99           `(%test-lowtag-and-headers
 100             ,value ,target ,not-p ,(car lowtags)
 101             ,function-p ',(canonicalize-headers headers))
 102           `(%test-lowtag ,value ,target ,not-p ,(car lowtags))))
 103      (headers
 104       `(%test-headers ,value ,target ,not-p ,function-p
 105                       ',(canonicalize-headers headers)))
 106      (t
 107       (error "nothing to test?"))))))
 108
 109 ;;; Emit the most compact form of the test immediate instruction,
 110 ;;; using an 8 bit test when the immediate is only 8 bits and the
 111 ;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
 112 ;;; control-stack.
 113 (defun generate-fixnum-test (value)
 114   (let ((offset (tn-offset value)))
 115     (cond ((and (sc-is value any-reg descriptor-reg)
 116                 (or (= offset eax-offset) (= offset ebx-offset)
 117                     (= offset ecx-offset) (= offset edx-offset)))
 118            (inst test (make-random-tn :kind :normal
 119                                       :sc (sc-or-lose 'byte-reg)
 120                                       :offset offset)
 121                  3))
 122           ((sc-is value control-stack)
 123            (inst test (make-ea :byte :base ebp-tn
 124                                :disp (- (* (1+ offset) sb!vm:word-bytes)))
 125                  3))
 126           (t
 127            (inst test value 3)))))
 128
 129 (defun %test-fixnum (value target not-p)
 130   (generate-fixnum-test value)
 131   (inst jmp (if not-p :nz :z) target))
 132
 133 (defun %test-fixnum-and-headers (value target not-p headers)
 134   (let ((drop-through (gen-label)))
 135     (generate-fixnum-test value)
 136     (inst jmp :z (if not-p drop-through target))
 137     (%test-headers value target not-p nil headers drop-through)))
 138
 139 (defun %test-immediate (value target not-p immediate)
 140   ;; Code a single instruction byte test if possible.
 141   (let ((offset (tn-offset value)))
 142     (cond ((and (sc-is value any-reg descriptor-reg)
 143                 (or (= offset eax-offset) (= offset ebx-offset)
 144                     (= offset ecx-offset) (= offset edx-offset)))
 145            (inst cmp (make-random-tn :kind :normal
 146                                      :sc (sc-or-lose 'byte-reg)
 147                                      :offset offset)
 148                  immediate))
 149           (t
 150            (move eax-tn value)
 151            (inst cmp al-tn immediate))))
 152   (inst jmp (if not-p :ne :e) target))
 153
 154 (defun %test-lowtag (value target not-p lowtag &optional al-loaded)
 155   (unless al-loaded
 156     (move eax-tn value)
 157     (inst and al-tn lowtag-mask))
 158   (inst cmp al-tn lowtag)
 159   (inst jmp (if not-p :ne :e) target))
 160
 161 (defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
 162   (let ((drop-through (gen-label)))
 163     (%test-lowtag value (if not-p drop-through target) nil lowtag)
 164     (%test-headers value target not-p function-p headers drop-through t)))
 165
 166
 167 (defun %test-headers (value target not-p function-p headers
 168                             &optional (drop-through (gen-label)) al-loaded)
 169   (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
 170     (multiple-value-bind (equal less-or-equal when-true when-false)
 171         ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
 172         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
 173         ;; it's true and when we know it's false respectively.
 174         (if not-p
 175             (values :ne :a drop-through target)
 176             (values :e :na target drop-through))
 177       (%test-lowtag value when-false t lowtag al-loaded)
 178       (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
 179       (do ((remaining headers (cdr remaining)))
 180           ((null remaining))
 181         (let ((header (car remaining))
 182               (last (null (cdr remaining))))
 183           (cond
 184            ((atom header)
 185             (inst cmp al-tn header)
 186             (if last
 187                 (inst jmp equal target)
 188                 (inst jmp :e when-true)))
 189            (t
 190              (let ((start (car header))
 191                    (end (cdr header)))
 192                (unless (= start bignum-type)
 193                  (inst cmp al-tn start)
 194                  (inst jmp :b when-false)) ; was :l
 195                (inst cmp al-tn end)
 196                (if last
 197                    (inst jmp less-or-equal target)
 198                    (inst jmp :be when-true))))))) ; was :le
 199       (emit-label drop-through))))
 200
 201 ;; pw -- based on RISC version. Not sure extra hair is needed yet.
 202 ;; difference is that this one uses SUB which overwrites operand
 203 ;; both cmp and sub take 2 cycles so maybe its a wash
 204 #+nil
 205 (defun %test-headers (value target not-p function-p headers
 206                             &optional (drop-through (gen-label)) al-loaded)
 207   (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
 208     (multiple-value-bind (equal less-or-equal when-true when-false)
 209         ;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
 210         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
 211         ;; it's true and when we know it's false respectively.
 212         (if not-p
 213             (values :ne :a drop-through target)
 214             (values :e :na target drop-through))
 215       (%test-lowtag value when-false t lowtag al-loaded)
 216       (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
 217       (let ((delta 0))
 218         (do ((remaining headers (cdr remaining)))
 219             ((null remaining))
 220           (let ((header (car remaining))
 221                 (last (null (cdr remaining))))
 222             (cond
 223               ((atom header)
 224                (inst sub al-tn (- header delta))
 225                (setf delta header)
 226                (if last
 227                    (inst jmp equal target)
 228                    (inst jmp :e when-true)))
 229               (t
 230                (let ((start (car header))
 231                      (end (cdr header)))
 232                  (unless (= start bignum-type)
 233                    (inst sub al-tn (- start delta))
 234                    (setf delta start)
 235                    (inst jmp :l when-false))
 236                  (inst sub al-tn (- end delta))
 237                  (setf delta end)
 238                  (if last
 239                      (inst jmp less-or-equal target)
 240                      (inst jmp :le when-true))))))))
 241       (emit-label drop-through))))
 242 \f
 243 ;;;; type checking and testing
 244
 245 (define-vop (check-type)
 246   (:args (value :target result :scs (any-reg descriptor-reg)))
 247   (:results (result :scs (any-reg descriptor-reg)))
 248   (:temporary (:sc unsigned-reg :offset eax-offset :to (:result 0)) eax)
 249   (:ignore eax)
 250   (:vop-var vop)
 251   (:save-p :compute-only))
 252
 253 (define-vop (type-predicate)
 254   (:args (value :scs (any-reg descriptor-reg)))
 255   (:temporary (:sc unsigned-reg :offset eax-offset) eax)
 256   (:ignore eax)
 257   (:conditional)
 258   (:info target not-p)
 259   (:policy :fast-safe))
 260
 261 ;;; Simpler VOP that don't need a temporary register.
 262 (define-vop (simple-check-type)
 263   (:args (value :target result :scs (any-reg descriptor-reg)))
 264   (:results (result :scs (any-reg descriptor-reg)
 265                     :load-if (not (and (sc-is value any-reg descriptor-reg)
 266                                        (sc-is result control-stack)))))
 267   (:vop-var vop)
 268   (:save-p :compute-only))
 269
 270 (define-vop (simple-type-predicate)
 271   (:args (value :scs (any-reg descriptor-reg control-stack)))
 272   (:conditional)
 273   (:info target not-p)
 274   (:policy :fast-safe))
 275
 276 (eval-when (:compile-toplevel :execute)
 277
 278 (defun cost-to-test-types (type-codes)
 279   (+ (* 2 (length type-codes))
 280      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 281
 282 ); EVAL-WHEN
 283
 284 ;;; FIXME: DEF-TYPE-VOPS and DEF-SIMPLE-TYPE-VOPS are only used in
 285 ;;; this file, so they should be in the EVAL-WHEN above, or otherwise
 286 ;;; tweaked so that they don't appear in the target system.
 287
 288 (defmacro def-type-vops (pred-name check-name ptype error-code
 289                                    &rest type-codes)
 290   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 291     `(progn
 292        ,@(when pred-name
 293            `((define-vop (,pred-name type-predicate)
 294                (:translate ,pred-name)
 295                (:generator ,cost
 296                  (test-type value target not-p ,@type-codes)))))
 297        ,@(when check-name
 298            `((define-vop (,check-name check-type)
 299                (:generator ,cost
 300                  (let ((err-lab
 301                         (generate-error-code vop ,error-code value)))
 302                    (test-type value err-lab t ,@type-codes)
 303                    (move result value))))))
 304        ,@(when ptype
 305            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 306
 307 (defmacro def-simple-type-vops (pred-name check-name ptype error-code
 308                                           &rest type-codes)
 309   (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
 310     `(progn
 311        ,@(when pred-name
 312            `((define-vop (,pred-name simple-type-predicate)
 313                (:translate ,pred-name)
 314                (:generator ,cost
 315                  (test-type value target not-p ,@type-codes)))))
 316        ,@(when check-name
 317            `((define-vop (,check-name simple-check-type)
 318                (:generator ,cost
 319                  (let ((err-lab
 320                         (generate-error-code vop ,error-code value)))
 321                    (test-type value err-lab t ,@type-codes)
 322                    (move result value))))))
 323        ,@(when ptype
 324            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 325
 326 (def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
 327   even-fixnum-type odd-fixnum-type)
 328
 329 (def-type-vops functionp check-function function
 330   object-not-function-error function-pointer-type)
 331
 332 (def-type-vops listp check-list list object-not-list-error
 333   list-pointer-type)
 334
 335 (def-type-vops %instancep check-instance instance object-not-instance-error
 336   instance-pointer-type)
 337
 338 (def-type-vops bignump check-bignum bignum
 339   object-not-bignum-error bignum-type)
 340
 341 (def-type-vops ratiop check-ratio ratio
 342   object-not-ratio-error ratio-type)
 343
 344 (def-type-vops complexp check-complex complex object-not-complex-error
 345   complex-type complex-single-float-type complex-double-float-type
 346   #!+long-float complex-long-float-type)
 347
 348 (def-type-vops complex-rational-p check-complex-rational nil
 349   object-not-complex-rational-error complex-type)
 350
 351 (def-type-vops complex-float-p check-complex-float nil
 352   object-not-complex-float-error
 353   complex-single-float-type complex-double-float-type
 354   #!+long-float complex-long-float-type)
 355
 356 (def-type-vops complex-single-float-p check-complex-single-float
 357   complex-single-float object-not-complex-single-float-error
 358   complex-single-float-type)
 359
 360 (def-type-vops complex-double-float-p check-complex-double-float
 361   complex-double-float object-not-complex-double-float-error
 362   complex-double-float-type)
 363
 364 #!+long-float
 365 (def-type-vops complex-long-float-p check-complex-long-float
 366   complex-long-float object-not-complex-long-float-error
 367   complex-long-float-type)
 368
 369 (def-type-vops single-float-p check-single-float single-float
 370   object-not-single-float-error single-float-type)
 371
 372 (def-type-vops double-float-p check-double-float double-float
 373   object-not-double-float-error double-float-type)
 374
 375 #!+long-float
 376 (def-type-vops long-float-p check-long-float long-float
 377   object-not-long-float-error long-float-type)
 378
 379 (def-type-vops simple-string-p check-simple-string simple-string
 380   object-not-simple-string-error simple-string-type)
 381
 382 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
 383   object-not-simple-bit-vector-error simple-bit-vector-type)
 384
 385 (def-type-vops simple-vector-p check-simple-vector simple-vector
 386   object-not-simple-vector-error simple-vector-type)
 387
 388 (def-type-vops simple-array-unsigned-byte-2-p
 389   check-simple-array-unsigned-byte-2
 390   simple-array-unsigned-byte-2
 391   object-not-simple-array-unsigned-byte-2-error
 392   simple-array-unsigned-byte-2-type)
 393
 394 (def-type-vops simple-array-unsigned-byte-4-p
 395   check-simple-array-unsigned-byte-4
 396   simple-array-unsigned-byte-4
 397   object-not-simple-array-unsigned-byte-4-error
 398   simple-array-unsigned-byte-4-type)
 399
 400 (def-type-vops simple-array-unsigned-byte-8-p
 401   check-simple-array-unsigned-byte-8
 402   simple-array-unsigned-byte-8
 403   object-not-simple-array-unsigned-byte-8-error
 404   simple-array-unsigned-byte-8-type)
 405
 406 (def-type-vops simple-array-unsigned-byte-16-p
 407   check-simple-array-unsigned-byte-16
 408   simple-array-unsigned-byte-16
 409   object-not-simple-array-unsigned-byte-16-error
 410   simple-array-unsigned-byte-16-type)
 411
 412 (def-type-vops simple-array-unsigned-byte-32-p
 413   check-simple-array-unsigned-byte-32
 414   simple-array-unsigned-byte-32
 415   object-not-simple-array-unsigned-byte-32-error
 416   simple-array-unsigned-byte-32-type)
 417
 418 (def-type-vops simple-array-signed-byte-8-p
 419   check-simple-array-signed-byte-8
 420   simple-array-signed-byte-8
 421   object-not-simple-array-signed-byte-8-error
 422   simple-array-signed-byte-8-type)
 423
 424 (def-type-vops simple-array-signed-byte-16-p
 425   check-simple-array-signed-byte-16
 426   simple-array-signed-byte-16
 427   object-not-simple-array-signed-byte-16-error
 428   simple-array-signed-byte-16-type)
 429
 430 (def-type-vops simple-array-signed-byte-30-p
 431   check-simple-array-signed-byte-30
 432   simple-array-signed-byte-30
 433   object-not-simple-array-signed-byte-30-error
 434   simple-array-signed-byte-30-type)
 435
 436 (def-type-vops simple-array-signed-byte-32-p
 437   check-simple-array-signed-byte-32
 438   simple-array-signed-byte-32
 439   object-not-simple-array-signed-byte-32-error
 440   simple-array-signed-byte-32-type)
 441
 442 (def-type-vops simple-array-single-float-p check-simple-array-single-float
 443   simple-array-single-float object-not-simple-array-single-float-error
 444   simple-array-single-float-type)
 445
 446 (def-type-vops simple-array-double-float-p check-simple-array-double-float
 447   simple-array-double-float object-not-simple-array-double-float-error
 448   simple-array-double-float-type)
 449
 450 #!+long-float
 451 (def-type-vops simple-array-long-float-p check-simple-array-long-float
 452   simple-array-long-float object-not-simple-array-long-float-error
 453   simple-array-long-float-type)
 454
 455 (def-type-vops simple-array-complex-single-float-p
 456   check-simple-array-complex-single-float
 457   simple-array-complex-single-float
 458   object-not-simple-array-complex-single-float-error
 459   simple-array-complex-single-float-type)
 460
 461 (def-type-vops simple-array-complex-double-float-p
 462   check-simple-array-complex-double-float
 463   simple-array-complex-double-float
 464   object-not-simple-array-complex-double-float-error
 465   simple-array-complex-double-float-type)
 466
 467 #!+long-float
 468 (def-type-vops simple-array-complex-long-float-p
 469   check-simple-array-complex-long-float
 470   simple-array-complex-long-float
 471   object-not-simple-array-complex-long-float-error
 472   simple-array-complex-long-float-type)
 473
 474 (def-type-vops base-char-p check-base-char base-char
 475   object-not-base-char-error base-char-type)
 476
 477 (def-type-vops system-area-pointer-p check-system-area-pointer
 478   system-area-pointer object-not-sap-error sap-type)
 479
 480 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 481   object-not-weak-pointer-error weak-pointer-type)
 482
 483 (def-type-vops code-component-p nil nil nil
 484   code-header-type)
 485
 486 (def-type-vops lra-p nil nil nil
 487   return-pc-header-type)
 488
 489 (def-type-vops fdefn-p nil nil nil
 490   fdefn-type)
 491
 492 (def-type-vops funcallable-instance-p nil nil nil
 493   funcallable-instance-header-type)
 494
 495 (def-type-vops array-header-p nil nil nil
 496   simple-array-type complex-string-type complex-bit-vector-type
 497   complex-vector-type complex-array-type)
 498
 499 (def-type-vops nil check-function-or-symbol nil
 500   object-not-function-or-symbol-error
 501   function-pointer-type symbol-header-type)
 502
 503 (def-type-vops stringp check-string nil object-not-string-error
 504   simple-string-type complex-string-type)
 505
 506 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 507   simple-bit-vector-type complex-bit-vector-type)
 508
 509 (def-type-vops vectorp check-vector nil object-not-vector-error
 510   simple-string-type simple-bit-vector-type simple-vector-type
 511   simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
 512   simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
 513   simple-array-unsigned-byte-32-type
 514   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 515   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 516   simple-array-single-float-type simple-array-double-float-type
 517   #!+long-float simple-array-long-float-type
 518   simple-array-complex-single-float-type
 519   simple-array-complex-double-float-type
 520   #!+long-float simple-array-complex-long-float-type
 521   complex-string-type complex-bit-vector-type complex-vector-type)
 522
 523 ;;; Note that this "type VOP" is sort of an oddball; it doesn't so
 524 ;;; much test for a Lisp-level type as just expose a low-level type
 525 ;;; code at the Lisp level. It is used as a building block to help us
 526 ;;; to express things like the test for (TYPEP FOO '(VECTOR T))
 527 ;;; efficiently in Lisp code, but it doesn't correspond to any type
 528 ;;; expression which would actually occur in reasonable application
 529 ;;; code. (Common Lisp doesn't have any natural way of expressing this
 530 ;;; type.) Thus, there's no point in building up the full machinery of
 531 ;;; associated backend type predicates and so forth as we do for
 532 ;;; ordinary type VOPs.
 533 (def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
 534   complex-vector-type)
 535
 536 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 537   simple-array-type simple-string-type simple-bit-vector-type
 538   simple-vector-type simple-array-unsigned-byte-2-type
 539   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 540   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 541   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 542   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 543   simple-array-single-float-type simple-array-double-float-type
 544   #!+long-float simple-array-long-float-type
 545   simple-array-complex-single-float-type
 546   simple-array-complex-double-float-type
 547   #!+long-float simple-array-complex-long-float-type)
 548
 549 (def-type-vops arrayp check-array nil object-not-array-error
 550   simple-array-type simple-string-type simple-bit-vector-type
 551   simple-vector-type simple-array-unsigned-byte-2-type
 552   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 553   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 554   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 555   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 556   simple-array-single-float-type simple-array-double-float-type
 557   #!+long-float simple-array-long-float-type
 558   simple-array-complex-single-float-type
 559   simple-array-complex-double-float-type
 560   #!+long-float simple-array-complex-long-float-type
 561   complex-string-type complex-bit-vector-type complex-vector-type
 562   complex-array-type)
 563
 564 (def-type-vops numberp check-number nil object-not-number-error
 565   even-fixnum-type odd-fixnum-type bignum-type ratio-type
 566   single-float-type double-float-type #!+long-float long-float-type complex-type
 567   complex-single-float-type complex-double-float-type
 568   #!+long-float complex-long-float-type)
 569
 570 (def-type-vops rationalp check-rational nil object-not-rational-error
 571   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
 572
 573 (def-type-vops integerp check-integer nil object-not-integer-error
 574   even-fixnum-type odd-fixnum-type bignum-type)
 575
 576 (def-type-vops floatp check-float nil object-not-float-error
 577   single-float-type double-float-type #!+long-float long-float-type)
 578
 579 (def-type-vops realp check-real nil object-not-real-error
 580   even-fixnum-type odd-fixnum-type ratio-type bignum-type
 581   single-float-type double-float-type #!+long-float long-float-type)
 582 \f
 583 ;;;; other integer ranges
 584
 585 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
 586 ;;; exactly one digit.
 587
 588 (define-vop (signed-byte-32-p type-predicate)
 589   (:translate signed-byte-32-p)
 590   (:generator 45
 591     (multiple-value-bind (yep nope)
 592         (if not-p
 593             (values not-target target)
 594             (values target not-target))
 595       (generate-fixnum-test value)
 596       (inst jmp :e yep)
 597       (move eax-tn value)
 598       (inst and al-tn lowtag-mask)
 599       (inst cmp al-tn other-pointer-type)
 600       (inst jmp :ne nope)
 601       (loadw eax-tn value 0 other-pointer-type)
 602       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 603       (inst jmp (if not-p :ne :e) target))
 604     NOT-TARGET))
 605
 606 (define-vop (check-signed-byte-32 check-type)
 607   (:generator 45
 608     (let ((nope (generate-error-code vop
 609                                      object-not-signed-byte-32-error
 610                                      value)))
 611       (generate-fixnum-test value)
 612       (inst jmp :e yep)
 613       (move eax-tn value)
 614       (inst and al-tn lowtag-mask)
 615       (inst cmp al-tn other-pointer-type)
 616       (inst jmp :ne nope)
 617       (loadw eax-tn value 0 other-pointer-type)
 618       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 619       (inst jmp :ne nope))
 620     YEP
 621     (move result value)))
 622
 623 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 624 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 625 ;;; and the second digit all zeros.
 626
 627 (define-vop (unsigned-byte-32-p type-predicate)
 628   (:translate unsigned-byte-32-p)
 629   (:generator 45
 630     (let ((not-target (gen-label))
 631           (single-word (gen-label))
 632           (fixnum (gen-label)))
 633       (multiple-value-bind (yep nope)
 634           (if not-p
 635               (values not-target target)
 636               (values target not-target))
 637         ;; Is it a fixnum?
 638         (generate-fixnum-test value)
 639         (move eax-tn value)
 640         (inst jmp :e fixnum)
 641
 642         ;; If not, is it an other pointer?
 643         (inst and al-tn lowtag-mask)
 644         (inst cmp al-tn other-pointer-type)
 645         (inst jmp :ne nope)
 646         ;; Get the header.
 647         (loadw eax-tn value 0 other-pointer-type)
 648         ;; Is it one?
 649         (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 650         (inst jmp :e single-word)
 651         ;; If it's other than two, we can't be an (unsigned-byte 32)
 652         (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
 653         (inst jmp :ne nope)
 654         ;; Get the second digit.
 655         (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 656         ;; All zeros, its an (unsigned-byte 32).
 657         (inst or eax-tn eax-tn)
 658         (inst jmp :z yep)
 659         (inst jmp nope)
 660
 661         (emit-label single-word)
 662         ;; Get the single digit.
 663         (loadw eax-tn value bignum-digits-offset other-pointer-type)
 664
 665         ;; positive implies (unsigned-byte 32).
 666         (emit-label fixnum)
 667         (inst or eax-tn eax-tn)
 668         (inst jmp (if not-p :s :ns) target)
 669
 670         (emit-label not-target)))))
 671
 672 (define-vop (check-unsigned-byte-32 check-type)
 673   (:generator 45
 674     (let ((nope
 675            (generate-error-code vop object-not-unsigned-byte-32-error value))
 676           (yep (gen-label))
 677           (fixnum (gen-label))
 678           (single-word (gen-label)))
 679
 680       ;; Is it a fixnum?
 681       (generate-fixnum-test value)
 682       (move eax-tn value)
 683       (inst jmp :e fixnum)
 684
 685       ;; If not, is it an other pointer?
 686       (inst and al-tn lowtag-mask)
 687       (inst cmp al-tn other-pointer-type)
 688       (inst jmp :ne nope)
 689       ;; Get the header.
 690       (loadw eax-tn value 0 other-pointer-type)
 691       ;; Is it one?
 692       (inst cmp eax-tn (+ (ash 1 type-bits) bignum-type))
 693       (inst jmp :e single-word)
 694       ;; If it's other than two, we can't be an (unsigned-byte 32)
 695       (inst cmp eax-tn (+ (ash 2 type-bits) bignum-type))
 696       (inst jmp :ne nope)
 697       ;; Get the second digit.
 698       (loadw eax-tn value (1+ bignum-digits-offset) other-pointer-type)
 699       ;; All zeros, its an (unsigned-byte 32).
 700       (inst or eax-tn eax-tn)
 701       (inst jmp :z yep)
 702       (inst jmp nope)
 703
 704       (emit-label single-word)
 705       ;; Get the single digit.
 706       (loadw eax-tn value bignum-digits-offset other-pointer-type)
 707
 708       ;; positive implies (unsigned-byte 32).
 709       (emit-label fixnum)
 710       (inst or eax-tn eax-tn)
 711       (inst jmp :s nope)
 712
 713       (emit-label yep)
 714       (move result value))))
 715 \f
 716 ;;;; list/symbol types
 717 ;;;
 718 ;;; symbolp (or symbol (eq nil))
 719 ;;; consp (and list (not (eq nil)))
 720
 721 (define-vop (symbolp type-predicate)
 722   (:translate symbolp)
 723   (:generator 12
 724     (let ((is-symbol-label (if not-p drop-thru target)))
 725       (inst cmp value *nil-value*)
 726       (inst jmp :e is-symbol-label)
 727       (test-type value target not-p symbol-header-type))
 728     DROP-THRU))
 729
 730 (define-vop (check-symbol check-type)
 731   (:generator 12
 732     (let ((error (generate-error-code vop object-not-symbol-error value)))
 733       (inst cmp value *nil-value*)
 734       (inst jmp :e drop-thru)
 735       (test-type value error t symbol-header-type))
 736     DROP-THRU
 737     (move result value)))
 738
 739 (define-vop (consp type-predicate)
 740   (:translate consp)
 741   (:generator 8
 742     (let ((is-not-cons-label (if not-p target drop-thru)))
 743       (inst cmp value *nil-value*)
 744       (inst jmp :e is-not-cons-label)
 745       (test-type value target not-p list-pointer-type))
 746     DROP-THRU))
 747
 748 (define-vop (check-cons check-type)
 749   (:generator 8
 750     (let ((error (generate-error-code vop object-not-cons-error value)))
 751       (inst cmp value *nil-value*)
 752       (inst jmp :e error)
 753       (test-type value error t list-pointer-type)
 754       (move result value))))
 755 \f
 756 ) ; MACROLET