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