src/compiler/alpha/type-vops.lisp

   1 ;;;; type testing and checking VOPs for the Alpha VM
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; This software is derived from the CMU CL system, which was
   7 ;;;; written at Carnegie Mellon University and released into the
   8 ;;;; public domain. The software is in the public domain and is
   9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
  10 ;;;; files for more information.
  11
  12 (in-package "SB!VM")
  13 \f
  14 ;;;; test generation utilities
  15
  16 (eval-when (:compile-toplevel :execute)
  17
  18 (defparameter *immediate-types*
  19   (list unbound-marker-widetag base-char-widetag))
  20
  21 (defparameter *fun-header-widetags*
  22   (list funcallable-instance-header-widetag
  23         simple-fun-header-widetag
  24         closure-fun-header-widetag
  25         closure-header-widetag))
  26
  27 (defun canonicalize-headers (headers)
  28   (collect ((results))
  29     (let ((start nil)
  30           (prev nil)
  31           (delta (- other-immediate-1-lowtag other-immediate-0-lowtag)))
  32       (flet ((emit-test ()
  33                (results (if (= start prev)
  34                             start
  35                             (cons start prev)))))
  36         (dolist (header (sort headers #'<))
  37           (cond ((null start)
  38                  (setf start header)
  39                  (setf prev header))
  40                 ((= header (+ prev delta))
  41                  (setf prev header))
  42                 (t
  43                  (emit-test)
  44                  (setf start header)
  45                  (setf prev header))))
  46         (emit-test)))
  47     (results)))
  48
  49 ) ; EVAL-WHEN
  50
  51 (macrolet ((test-type (value temp target not-p &rest type-codes)
  52   ;; Determine what interesting combinations we need to test for.
  53   (let* ((type-codes (mapcar #'eval type-codes))
  54          (fixnump (and (member even-fixnum-lowtag type-codes)
  55                        (member odd-fixnum-lowtag type-codes)
  56                        t))
  57          (lowtags (remove lowtag-limit type-codes :test #'<))
  58          (extended (remove lowtag-limit type-codes :test #'>))
  59          (immediates (intersection extended *immediate-types* :test #'eql))
  60          (headers (set-difference extended *immediate-types* :test #'eql))
  61          (function-p (if (intersection headers *fun-header-widetags*)
  62                          (if (subsetp headers *fun-header-widetags*)
  63                              t
  64                              (error "can't test for mix of function subtypes ~
  65                                      and normal header types."))
  66                          nil)))
  67     (unless type-codes
  68       (error "must supply at least one type for test-type"))
  69     (cond
  70      (fixnump
  71       (when (remove-if (lambda (x)
  72                          (or (= x even-fixnum-lowtag)
  73                              (= x odd-fixnum-lowtag)))
  74                        lowtags)
  75         (error "can't mix fixnum testing with other lowtags"))
  76       (when function-p
  77         (error "can't mix fixnum testing with function subtype testing"))
  78       (when immediates
  79         (error "can't mix fixnum testing with other immediates"))
  80       (if headers
  81           `(%test-fixnum-and-headers ,value ,temp ,target ,not-p
  82                                      ',(canonicalize-headers headers))
  83           `(%test-fixnum ,value ,temp ,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 ,temp ,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 ,temp ,target ,not-p ,(car lowtags)
  98             ,function-p ',(canonicalize-headers headers))
  99           `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))
 100      (headers
 101       `(%test-headers ,value ,temp ,target ,not-p ,function-p
 102                       ',(canonicalize-headers headers)))
 103      (t
 104       (error "nothing to test?"))))))
 105
 106 (defun %test-fixnum (value temp target not-p)
 107   (assemble ()
 108     (inst and value 3 temp)
 109     (if not-p
 110         (inst bne temp target)
 111         (inst beq temp target))))
 112
 113 (defun %test-fixnum-and-headers (value temp target not-p headers)
 114   (let ((drop-through (gen-label)))
 115     (assemble ()
 116       (inst and value 3 temp)
 117       (inst beq temp (if not-p drop-through target)))
 118     (%test-headers value temp target not-p nil headers drop-through)))
 119
 120 (defun %test-immediate (value temp target not-p immediate)
 121   (assemble ()
 122     (inst and value 255 temp)
 123     (inst xor temp immediate temp)
 124     (if not-p
 125         (inst bne temp target)
 126         (inst beq temp target))))
 127
 128 (defun %test-lowtag (value temp target not-p lowtag)
 129   (assemble ()
 130     (inst and value lowtag-mask temp)
 131     (inst xor temp lowtag temp)
 132     (if not-p
 133         (inst bne temp target)
 134         (inst beq temp target))))
 135
 136 (defun %test-lowtag-and-headers (value temp target not-p lowtag
 137                                        function-p headers)
 138   (let ((drop-through (gen-label)))
 139     (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
 140     (%test-headers value temp target not-p function-p headers drop-through)))
 141
 142 (defun %test-headers (value temp target not-p function-p headers
 143                             &optional (drop-through (gen-label)))
 144   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
 145     (multiple-value-bind
 146         (when-true when-false)
 147         ;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when
 148         ;; we know it's true and when we know it's false respectively.
 149         (if not-p
 150             (values drop-through target)
 151             (values target drop-through))
 152       (assemble ()
 153         (%test-lowtag value temp when-false t lowtag)
 154         (load-type temp value (- lowtag))
 155         (let ((delta 0))
 156           (do ((remaining headers (cdr remaining)))
 157               ((null remaining))
 158             (let ((header (car remaining))
 159                   (last (null (cdr remaining))))
 160               (cond
 161                ((atom header)
 162                 (inst subq temp (- header delta) temp)
 163                 (setf delta header)
 164                 (if last
 165                     (if not-p
 166                         (inst bne temp target)
 167                         (inst beq temp target))
 168                     (inst beq temp when-true)))
 169                (t
 170                 (let ((start (car header))
 171                       (end (cdr header)))
 172                   (unless (= start bignum-widetag)
 173                     (inst subq temp (- start delta) temp)
 174                     (setf delta start)
 175                     (inst blt temp when-false))
 176                   (inst subq temp (- end delta) temp)
 177                   (setf delta end)
 178                   (if last
 179                       (if not-p
 180                           (inst bgt temp target)
 181                           (inst ble temp target))
 182                       (inst ble temp when-true))))))))
 183         (emit-label drop-through)))))
 184
 185
 186 \f
 187 ;;;; Type checking and testing:
 188
 189 (define-vop (check-type)
 190   (:args (value :target result :scs (any-reg descriptor-reg)))
 191   (:results (result :scs (any-reg descriptor-reg)))
 192   (:temporary (:scs (non-descriptor-reg) :to (:result 0)) temp)
 193   (:vop-var vop)
 194   (:save-p :compute-only))
 195
 196 (define-vop (type-predicate)
 197   (:args (value :scs (any-reg descriptor-reg)))
 198   (:temporary (:scs (non-descriptor-reg)) temp)
 199   (:conditional)
 200   (:info target not-p)
 201   (:policy :fast-safe))
 202
 203
 204 (eval-when  (:compile-toplevel :execute)
 205
 206
 207 (defun cost-to-test-types (type-codes)
 208   (+ (* 2 (length type-codes))
 209      (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
 210 )
 211
 212 (defmacro def-type-vops (pred-name check-name ptype error-code
 213                                    &rest type-codes)
 214   (let ((cost #+sb-xc-host (cost-to-test-types (mapcar #'eval type-codes))
 215               #-sb-xc-host 10))
 216     `(progn
 217        ,@(when pred-name
 218            `((define-vop (,pred-name type-predicate)
 219                (:translate ,pred-name)
 220                (:generator ,cost
 221                  (test-type value temp target not-p ,@type-codes)))))
 222        ,@(when check-name
 223            `((define-vop (,check-name check-type)
 224                (:generator ,cost
 225                  (let ((err-lab
 226                         (generate-error-code vop ,error-code value)))
 227                    (test-type value temp err-lab t ,@type-codes)
 228                    (move value result))))))
 229        ,@(when ptype
 230            `((primitive-type-vop ,check-name (:check) ,ptype))))))
 231
 232
 233 (def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
 234   even-fixnum-lowtag odd-fixnum-lowtag)
 235
 236 (def-type-vops functionp check-fun function
 237   object-not-fun-error fun-pointer-lowtag)
 238
 239 (def-type-vops listp check-list list object-not-list-error
 240   list-pointer-lowtag)
 241
 242 (def-type-vops %instancep check-instance instance object-not-instance-error
 243   instance-pointer-lowtag)
 244
 245 (def-type-vops bignump check-bignum bignum
 246   object-not-bignum-error bignum-widetag)
 247
 248 (def-type-vops ratiop check-ratio ratio
 249   object-not-ratio-error ratio-widetag)
 250
 251 (def-type-vops complexp check-complex complex
 252   object-not-complex-error complex-widetag
 253   complex-single-float-widetag complex-double-float-widetag)
 254
 255 (def-type-vops complex-rational-p check-complex-rational nil
 256   object-not-complex-rational-error complex-widetag)
 257
 258 (def-type-vops complex-float-p check-complex-float nil
 259   object-not-complex-float-error
 260   complex-single-float-widetag complex-double-float-widetag)
 261
 262 (def-type-vops complex-single-float-p check-complex-single-float
 263   complex-single-float object-not-complex-single-float-error
 264   complex-single-float-widetag)
 265
 266 (def-type-vops complex-double-float-p check-complex-double-float
 267   complex-double-float object-not-complex-double-float-error
 268   complex-double-float-widetag)
 269
 270 (def-type-vops single-float-p check-single-float single-float
 271   object-not-single-float-error single-float-widetag)
 272
 273 (def-type-vops double-float-p check-double-float double-float
 274   object-not-double-float-error double-float-widetag)
 275
 276 (def-type-vops simple-string-p check-simple-string simple-string
 277   object-not-simple-string-error simple-string-widetag)
 278
 279 (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
 280   object-not-simple-bit-vector-error simple-bit-vector-widetag)
 281
 282 (def-type-vops simple-vector-p check-simple-vector simple-vector
 283   object-not-simple-vector-error simple-vector-widetag)
 284
 285 (def-type-vops simple-array-unsigned-byte-2-p
 286   check-simple-array-unsigned-byte-2
 287   simple-array-unsigned-byte-2
 288   object-not-simple-array-unsigned-byte-2-error
 289   simple-array-unsigned-byte-2-widetag)
 290
 291 (def-type-vops simple-array-unsigned-byte-4-p
 292   check-simple-array-unsigned-byte-4
 293   simple-array-unsigned-byte-4
 294   object-not-simple-array-unsigned-byte-4-error
 295   simple-array-unsigned-byte-4-widetag)
 296
 297 (def-type-vops simple-array-unsigned-byte-8-p
 298   check-simple-array-unsigned-byte-8
 299   simple-array-unsigned-byte-8
 300   object-not-simple-array-unsigned-byte-8-error
 301   simple-array-unsigned-byte-8-widetag)
 302
 303 (def-type-vops simple-array-unsigned-byte-16-p
 304   check-simple-array-unsigned-byte-16
 305   simple-array-unsigned-byte-16
 306   object-not-simple-array-unsigned-byte-16-error
 307   simple-array-unsigned-byte-16-widetag)
 308
 309 (def-type-vops simple-array-unsigned-byte-32-p
 310   check-simple-array-unsigned-byte-32
 311   simple-array-unsigned-byte-32
 312   object-not-simple-array-unsigned-byte-32-error
 313   simple-array-unsigned-byte-32-widetag)
 314
 315 (def-type-vops simple-array-signed-byte-8-p
 316   check-simple-array-signed-byte-8
 317   simple-array-signed-byte-8
 318   object-not-simple-array-signed-byte-8-error
 319   simple-array-signed-byte-8-widetag)
 320
 321 (def-type-vops simple-array-signed-byte-16-p
 322   check-simple-array-signed-byte-16
 323   simple-array-signed-byte-16
 324   object-not-simple-array-signed-byte-16-error
 325   simple-array-signed-byte-16-widetag)
 326
 327 (def-type-vops simple-array-signed-byte-30-p
 328   check-simple-array-signed-byte-30
 329   simple-array-signed-byte-30
 330   object-not-simple-array-signed-byte-30-error
 331   simple-array-signed-byte-30-widetag)
 332
 333 (def-type-vops simple-array-signed-byte-32-p
 334   check-simple-array-signed-byte-32
 335   simple-array-signed-byte-32
 336   object-not-simple-array-signed-byte-32-error
 337   simple-array-signed-byte-32-widetag)
 338
 339 (def-type-vops simple-array-single-float-p check-simple-array-single-float
 340   simple-array-single-float object-not-simple-array-single-float-error
 341   simple-array-single-float-widetag)
 342
 343 (def-type-vops simple-array-double-float-p check-simple-array-double-float
 344   simple-array-double-float object-not-simple-array-double-float-error
 345   simple-array-double-float-widetag)
 346
 347 (def-type-vops simple-array-complex-single-float-p
 348   check-simple-array-complex-single-float
 349   simple-array-complex-single-float
 350   object-not-simple-array-complex-single-float-error
 351   simple-array-complex-single-float-widetag)
 352
 353 (def-type-vops simple-array-complex-double-float-p
 354   check-simple-array-complex-double-float
 355   simple-array-complex-double-float
 356   object-not-simple-array-complex-double-float-error
 357   simple-array-complex-double-float-widetag)
 358
 359 (def-type-vops base-char-p check-base-char base-char
 360   object-not-base-char-error base-char-widetag)
 361
 362 (def-type-vops system-area-pointer-p check-system-area-pointer
 363   system-area-pointer object-not-sap-error sap-widetag)
 364
 365 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 366   object-not-weak-pointer-error weak-pointer-widetag)
 367
 368
 369 ;;; XXX
 370 #|
 371 (def-type-vops scavenger-hook-p nil nil nil
 372   #-gengc 0 #+gengc scavenger-hook-type)
 373 |#
 374
 375 (def-type-vops code-component-p nil nil nil
 376   code-header-widetag)
 377
 378 (def-type-vops lra-p nil nil nil
 379   #-gengc return-pc-header-widetag #+gengc 0)
 380
 381 (def-type-vops fdefn-p nil nil nil
 382   fdefn-widetag)
 383
 384 (def-type-vops funcallable-instance-p nil nil nil
 385   funcallable-instance-header-widetag)
 386
 387 (def-type-vops array-header-p nil nil nil
 388   simple-array-widetag complex-string-widetag complex-bit-vector-widetag
 389   complex-vector-widetag complex-array-widetag)
 390
 391 (def-type-vops stringp check-string nil object-not-string-error
 392   simple-string-widetag complex-string-widetag)
 393
 394 ;;; XXX surely just sticking this in here is not all that's required
 395 ;;; to create the vop?  But I can't find out any other info
 396 (def-type-vops complex-vector-p check-complex-vector nil
 397   object-not-complex-vector-error complex-vector-widetag)
 398
 399 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 400   simple-bit-vector-widetag complex-bit-vector-widetag)
 401
 402 (def-type-vops vectorp check-vector nil object-not-vector-error
 403   simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
 404   simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
 405   simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
 406   simple-array-unsigned-byte-32-widetag
 407   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 408   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 409   simple-array-single-float-widetag simple-array-double-float-widetag
 410   simple-array-complex-single-float-widetag
 411   simple-array-complex-double-float-widetag
 412   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
 413
 414 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 415   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 416   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 417   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 418   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 419   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 420   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 421   simple-array-single-float-widetag simple-array-double-float-widetag
 422   simple-array-complex-single-float-widetag
 423   simple-array-complex-double-float-widetag)
 424
 425 (def-type-vops arrayp check-array nil object-not-array-error
 426   simple-array-widetag simple-string-widetag simple-bit-vector-widetag
 427   simple-vector-widetag simple-array-unsigned-byte-2-widetag
 428   simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
 429   simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
 430   simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
 431   simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
 432   simple-array-single-float-widetag simple-array-double-float-widetag
 433   simple-array-complex-single-float-widetag
 434   simple-array-complex-double-float-widetag
 435   complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
 436   complex-array-widetag)
 437
 438 (def-type-vops numberp check-number nil object-not-number-error
 439   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
 440   single-float-widetag double-float-widetag complex-widetag
 441   complex-single-float-widetag complex-double-float-widetag)
 442
 443 (def-type-vops rationalp check-rational nil object-not-rational-error
 444   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
 445
 446 (def-type-vops integerp check-integer nil object-not-integer-error
 447   even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
 448
 449 (def-type-vops floatp check-float nil object-not-float-error
 450   single-float-widetag double-float-widetag)
 451
 452 (def-type-vops realp check-real nil object-not-real-error
 453   even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
 454   single-float-widetag double-float-widetag)
 455
 456 \f
 457 ;;;; Other integer ranges.
 458
 459 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 460 ;;; exactly one digit.
 461
 462
 463 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
 464   (multiple-value-bind
 465       (yep nope)
 466       (if not-p
 467           (values not-target target)
 468           (values target not-target))
 469     (assemble ()
 470       (inst and value 3 temp)
 471       (inst beq temp yep)
 472       (inst and value lowtag-mask temp)
 473       (inst xor temp other-pointer-lowtag temp)
 474       (inst bne temp nope)
 475       (loadw temp value 0 other-pointer-lowtag)
 476       (inst li (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 477       (inst xor temp temp1 temp)
 478       (if not-p
 479           (inst bne temp target)
 480           (inst beq temp target))))
 481   (values))
 482
 483 (define-vop (signed-byte-32-p type-predicate)
 484   (:translate signed-byte-32-p)
 485   (:temporary (:scs (non-descriptor-reg)) temp1)
 486   (:generator 45
 487     (signed-byte-32-test value temp temp1 not-p target not-target)
 488     NOT-TARGET))
 489
 490 (define-vop (check-signed-byte-32 check-type)
 491   (:temporary (:scs (non-descriptor-reg)) temp1)
 492   (:generator 45
 493     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 494                                       value)))
 495       (signed-byte-32-test value temp temp1 t loose okay))
 496     OKAY
 497     (move value result)))
 498
 499 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 500 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 501 ;;; and the second digit all zeros.
 502
 503 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
 504   (multiple-value-bind (yep nope)
 505                        (if not-p
 506                            (values not-target target)
 507                            (values target not-target))
 508     (assemble ()
 509       ;; Is it a fixnum?
 510       (inst and value 3 temp1)
 511       (inst move value temp)
 512       (inst beq temp1 fixnum)
 513
 514       ;; If not, is it an other pointer?
 515       (inst and value lowtag-mask temp)
 516       (inst xor temp other-pointer-lowtag temp)
 517       (inst bne temp nope)
 518       ;; Get the header.
 519       (loadw temp value 0 other-pointer-lowtag)
 520       ;; Is it one?
 521       (inst li  (+ (ash 1 n-widetag-bits) bignum-widetag) temp1)
 522       (inst xor temp temp1 temp)
 523       (inst beq temp single-word)
 524       ;; If it's other than two, we can't be an (unsigned-byte 32)
 525       (inst li (logxor (+ (ash 1 n-widetag-bits) bignum-widetag)
 526                        (+ (ash 2 n-widetag-bits) bignum-widetag))
 527             temp1)
 528       (inst xor temp temp1 temp)
 529       (inst bne temp nope)
 530       ;; Get the second digit.
 531       (loadw temp value (1+ bignum-digits-offset) other-pointer-lowtag)
 532       ;; All zeros, its an (unsigned-byte 32).
 533       (inst beq temp yep)
 534       (inst br zero-tn nope)
 535
 536       SINGLE-WORD
 537       ;; Get the single digit.
 538       (loadw temp value bignum-digits-offset other-pointer-lowtag)
 539
 540       ;; positive implies (unsigned-byte 32).
 541       FIXNUM
 542       (if not-p
 543           (inst blt temp target)
 544           (inst bge temp target))))
 545   (values))
 546
 547 (define-vop (unsigned-byte-32-p type-predicate)
 548   (:translate unsigned-byte-32-p)
 549   (:temporary (:scs (non-descriptor-reg)) temp1)
 550   (:generator 45
 551     (unsigned-byte-32-test value temp temp1 not-p target not-target)
 552     NOT-TARGET))
 553
 554 (define-vop (check-unsigned-byte-32 check-type)
 555   (:temporary (:scs (non-descriptor-reg)) temp1)
 556   (:generator 45
 557     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 558                                       value)))
 559       (unsigned-byte-32-test value temp temp1 t loose okay))
 560     OKAY
 561     (move value result)))
 562
 563
 564 \f
 565 ;;;; List/symbol types:
 566 ;;;
 567 ;;; symbolp (or symbol (eq nil))
 568 ;;; consp (and list (not (eq nil)))
 569
 570 (define-vop (symbolp type-predicate)
 571   (:translate symbolp)
 572   (:temporary (:scs (non-descriptor-reg)) temp)
 573   (:generator 12
 574     (inst cmpeq value null-tn temp)
 575     (inst bne temp (if not-p drop-thru target))
 576     (test-type value temp target not-p symbol-header-widetag)
 577     DROP-THRU))
 578
 579 (define-vop (check-symbol check-type)
 580   (:temporary (:scs (non-descriptor-reg)) temp)
 581   (:generator 12
 582     (inst cmpeq value null-tn temp)
 583     (inst bne temp drop-thru)
 584     (let ((error (generate-error-code vop object-not-symbol-error value)))
 585       (test-type value temp error t symbol-header-widetag))
 586     DROP-THRU
 587     (move value result)))
 588
 589 (define-vop (consp type-predicate)
 590   (:translate consp)
 591   (:temporary (:scs (non-descriptor-reg)) temp)
 592   (:generator 8
 593     (inst cmpeq value null-tn temp)
 594     (inst bne temp (if not-p target drop-thru))
 595     (test-type value temp target not-p list-pointer-lowtag)
 596     DROP-THRU))
 597
 598 (define-vop (check-cons check-type)
 599   (:temporary (:scs (non-descriptor-reg)) temp)
 600   (:generator 8
 601     (let ((error (generate-error-code vop object-not-cons-error value)))
 602       (inst cmpeq value null-tn temp)
 603       (inst bne temp error)
 604       (test-type value temp error t list-pointer-lowtag))
 605     (move value result)))
 606
 607 ) ; MACROLET