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-type base-char-type))
  20
  21 (defparameter function-header-types
  22   (list funcallable-instance-header-type
  23         byte-code-function-type byte-code-closure-type
  24         function-header-type closure-function-header-type
  25         closure-header-type))
  26
  27 (defun canonicalize-headers (headers)
  28   (collect ((results))
  29     (let ((start nil)
  30           (prev nil)
  31           (delta (- other-immediate-1-type other-immediate-0-type)))
  32       (flet ((emit-test ()
  33                (results (if (= start prev)
  34                             start
  35                             (cons start prev)))))
  36         (dolist (header (sort headers #'<))
  37           (cond ((null start)
  38                  (setf start header)
  39                  (setf prev header))
  40                 ((= header (+ prev delta))
  41                  (setf prev header))
  42                 (t
  43                  (emit-test)
  44                  (setf start header)
  45                  (setf prev header))))
  46         (emit-test)))
  47     (results)))
  48
  49 ) ; EVAL-WHEN
  50
  51 (macrolet ((test-type (value 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-type type-codes)
  55                        (member odd-fixnum-type type-codes)
  56                        t))
  57          (lowtags (remove lowtag-limit type-codes :test #'<))
  58          (extended (remove lowtag-limit type-codes :test #'>))
  59          (immediates (intersection extended immediate-types :test #'eql))
  60          (headers (set-difference extended immediate-types :test #'eql))
  61          (function-p (if (intersection headers function-header-types)
  62                          (if (subsetp headers function-header-types)
  63                              t
  64                              (error "Can't test for mix of function subtypes ~
  65                                      and normal header types."))
  66                          nil)))
  67     (unless type-codes
  68       (error "Must supply at least on type 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 ,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 function-pointer-type other-pointer-type)))
 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-type)
 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-type odd-fixnum-type)
 235
 236 (def-type-vops functionp check-function function
 237   object-not-function-error function-pointer-type)
 238
 239 (def-type-vops listp check-list list object-not-list-error
 240   list-pointer-type)
 241
 242 (def-type-vops %instancep check-instance instance object-not-instance-error
 243   instance-pointer-type)
 244
 245 (def-type-vops bignump check-bignum bignum
 246   object-not-bignum-error bignum-type)
 247
 248 (def-type-vops ratiop check-ratio ratio
 249   object-not-ratio-error ratio-type)
 250
 251 (def-type-vops complexp check-complex complex
 252   object-not-complex-error complex-type
 253   complex-single-float-type complex-double-float-type)
 254
 255 (def-type-vops complex-rational-p check-complex-rational nil
 256   object-not-complex-rational-error complex-type)
 257
 258 (def-type-vops complex-float-p check-complex-float nil
 259   object-not-complex-float-error
 260   complex-single-float-type complex-double-float-type)
 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-type)
 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-type)
 269
 270 (def-type-vops single-float-p check-single-float single-float
 271   object-not-single-float-error single-float-type)
 272
 273 (def-type-vops double-float-p check-double-float double-float
 274   object-not-double-float-error double-float-type)
 275
 276 (def-type-vops simple-string-p check-simple-string simple-string
 277   object-not-simple-string-error simple-string-type)
 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-type)
 281
 282 (def-type-vops simple-vector-p check-simple-vector simple-vector
 283   object-not-simple-vector-error simple-vector-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 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-type)
 358
 359 (def-type-vops base-char-p check-base-char base-char
 360   object-not-base-char-error base-char-type)
 361
 362 (def-type-vops system-area-pointer-p check-system-area-pointer
 363   system-area-pointer object-not-sap-error sap-type)
 364
 365 (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
 366   object-not-weak-pointer-error weak-pointer-type)
 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-type)
 377
 378 (def-type-vops lra-p nil nil nil
 379   #-gengc return-pc-header-type #+gengc 0)
 380
 381 (def-type-vops fdefn-p nil nil nil
 382   fdefn-type)
 383
 384 (def-type-vops funcallable-instance-p nil nil nil
 385   funcallable-instance-header-type)
 386
 387 (def-type-vops array-header-p nil nil nil
 388   simple-array-type complex-string-type complex-bit-vector-type
 389   complex-vector-type complex-array-type)
 390
 391 (def-type-vops nil check-function-or-symbol nil
 392   object-not-function-or-symbol-error
 393   function-pointer-type symbol-header-type)
 394
 395 (def-type-vops stringp check-string nil object-not-string-error
 396   simple-string-type complex-string-type)
 397
 398 ;;; XXX surely just sticking this in here is not all that's required
 399 ;;; to create the vop?  But I can't find out any other info
 400 (def-type-vops complex-vector-p check-complex-vector nil
 401   object-not-complex-vector-error complex-vector-type)
 402
 403 (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
 404   simple-bit-vector-type complex-bit-vector-type)
 405
 406 (def-type-vops vectorp check-vector nil object-not-vector-error
 407   simple-string-type simple-bit-vector-type simple-vector-type
 408   simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
 409   simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type
 410   simple-array-unsigned-byte-32-type
 411   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 412   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 413   simple-array-single-float-type simple-array-double-float-type
 414   simple-array-complex-single-float-type
 415   simple-array-complex-double-float-type
 416   complex-string-type complex-bit-vector-type complex-vector-type)
 417
 418 (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
 419   simple-array-type simple-string-type simple-bit-vector-type
 420   simple-vector-type simple-array-unsigned-byte-2-type
 421   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 422   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 423   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 424   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 425   simple-array-single-float-type simple-array-double-float-type
 426   simple-array-complex-single-float-type
 427   simple-array-complex-double-float-type)
 428
 429 (def-type-vops arrayp check-array nil object-not-array-error
 430   simple-array-type simple-string-type simple-bit-vector-type
 431   simple-vector-type simple-array-unsigned-byte-2-type
 432   simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
 433   simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type
 434   simple-array-signed-byte-8-type simple-array-signed-byte-16-type
 435   simple-array-signed-byte-30-type simple-array-signed-byte-32-type
 436   simple-array-single-float-type simple-array-double-float-type
 437   simple-array-complex-single-float-type
 438   simple-array-complex-double-float-type
 439   complex-string-type complex-bit-vector-type complex-vector-type
 440   complex-array-type)
 441
 442 (def-type-vops numberp check-number nil object-not-number-error
 443   even-fixnum-type odd-fixnum-type bignum-type ratio-type
 444   single-float-type double-float-type complex-type
 445   complex-single-float-type complex-double-float-type)
 446
 447 (def-type-vops rationalp check-rational nil object-not-rational-error
 448   even-fixnum-type odd-fixnum-type ratio-type bignum-type)
 449
 450 (def-type-vops integerp check-integer nil object-not-integer-error
 451   even-fixnum-type odd-fixnum-type bignum-type)
 452
 453 (def-type-vops floatp check-float nil object-not-float-error
 454   single-float-type double-float-type)
 455
 456 (def-type-vops realp check-real nil object-not-real-error
 457   even-fixnum-type odd-fixnum-type ratio-type bignum-type
 458   single-float-type double-float-type)
 459
 460 \f
 461 ;;;; Other integer ranges.
 462
 463 ;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
 464 ;;; exactly one digit.
 465
 466
 467 (defun signed-byte-32-test (value temp temp1 not-p target not-target)
 468   (multiple-value-bind
 469       (yep nope)
 470       (if not-p
 471           (values not-target target)
 472           (values target not-target))
 473     (assemble ()
 474       (inst and value 3 temp)
 475       (inst beq temp yep)
 476       (inst and value lowtag-mask temp)
 477       (inst xor temp other-pointer-type temp)
 478       (inst bne temp nope)
 479       (loadw temp value 0 other-pointer-type)
 480       (inst li (+ (ash 1 type-bits) bignum-type) temp1)
 481       (inst xor temp temp1 temp)
 482       (if not-p
 483           (inst bne temp target)
 484           (inst beq temp target))))
 485   (values))
 486
 487 (define-vop (signed-byte-32-p type-predicate)
 488   (:translate signed-byte-32-p)
 489   (:temporary (:scs (non-descriptor-reg)) temp1)
 490   (:generator 45
 491     (signed-byte-32-test value temp temp1 not-p target not-target)
 492     NOT-TARGET))
 493
 494 (define-vop (check-signed-byte-32 check-type)
 495   (:temporary (:scs (non-descriptor-reg)) temp1)
 496   (:generator 45
 497     (let ((loose (generate-error-code vop object-not-signed-byte-32-error
 498                                       value)))
 499       (signed-byte-32-test value temp temp1 t loose okay))
 500     OKAY
 501     (move value result)))
 502
 503 ;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
 504 ;;; bignum with exactly one positive digit, or a bignum with exactly two digits
 505 ;;; and the second digit all zeros.
 506
 507 (defun unsigned-byte-32-test (value temp temp1 not-p target not-target)
 508   (multiple-value-bind (yep nope)
 509                        (if not-p
 510                            (values not-target target)
 511                            (values target not-target))
 512     (assemble ()
 513       ;; Is it a fixnum?
 514       (inst and value 3 temp1)
 515       (inst move value temp)
 516       (inst beq temp1 fixnum)
 517
 518       ;; If not, is it an other pointer?
 519       (inst and value lowtag-mask temp)
 520       (inst xor temp other-pointer-type temp)
 521       (inst bne temp nope)
 522       ;; Get the header.
 523       (loadw temp value 0 other-pointer-type)
 524       ;; Is it one?
 525       (inst li  (+ (ash 1 type-bits) bignum-type) temp1)
 526       (inst xor temp temp1 temp)
 527       (inst beq temp single-word)
 528       ;; If it's other than two, we can't be an (unsigned-byte 32)
 529       (inst li (logxor (+ (ash 1 type-bits) bignum-type)
 530                        (+ (ash 2 type-bits) bignum-type))
 531             temp1)
 532       (inst xor temp temp1 temp)
 533       (inst bne temp nope)
 534       ;; Get the second digit.
 535       (loadw temp value (1+ bignum-digits-offset) other-pointer-type)
 536       ;; All zeros, its an (unsigned-byte 32).
 537       (inst beq temp yep)
 538       (inst br zero-tn nope)
 539
 540       SINGLE-WORD
 541       ;; Get the single digit.
 542       (loadw temp value bignum-digits-offset other-pointer-type)
 543
 544       ;; positive implies (unsigned-byte 32).
 545       FIXNUM
 546       (if not-p
 547           (inst blt temp target)
 548           (inst bge temp target))))
 549   (values))
 550
 551 (define-vop (unsigned-byte-32-p type-predicate)
 552   (:translate unsigned-byte-32-p)
 553   (:temporary (:scs (non-descriptor-reg)) temp1)
 554   (:generator 45
 555     (unsigned-byte-32-test value temp temp1 not-p target not-target)
 556     NOT-TARGET))
 557
 558 (define-vop (check-unsigned-byte-32 check-type)
 559   (:temporary (:scs (non-descriptor-reg)) temp1)
 560   (:generator 45
 561     (let ((loose (generate-error-code vop object-not-unsigned-byte-32-error
 562                                       value)))
 563       (unsigned-byte-32-test value temp temp1 t loose okay))
 564     OKAY
 565     (move value result)))
 566
 567
 568 \f
 569 ;;;; List/symbol types:
 570 ;;;
 571 ;;; symbolp (or symbol (eq nil))
 572 ;;; consp (and list (not (eq nil)))
 573
 574 (define-vop (symbolp type-predicate)
 575   (:translate symbolp)
 576   (:temporary (:scs (non-descriptor-reg)) temp)
 577   (:generator 12
 578     (inst cmpeq value null-tn temp)
 579     (inst bne temp (if not-p drop-thru target))
 580     (test-type value temp target not-p symbol-header-type)
 581     DROP-THRU))
 582
 583 (define-vop (check-symbol check-type)
 584   (:temporary (:scs (non-descriptor-reg)) temp)
 585   (:generator 12
 586     (inst cmpeq value null-tn temp)
 587     (inst bne temp drop-thru)
 588     (let ((error (generate-error-code vop object-not-symbol-error value)))
 589       (test-type value temp error t symbol-header-type))
 590     DROP-THRU
 591     (move value result)))
 592
 593 (define-vop (consp type-predicate)
 594   (:translate consp)
 595   (:temporary (:scs (non-descriptor-reg)) temp)
 596   (:generator 8
 597     (inst cmpeq value null-tn temp)
 598     (inst bne temp (if not-p target drop-thru))
 599     (test-type value temp target not-p list-pointer-type)
 600     DROP-THRU))
 601
 602 (define-vop (check-cons check-type)
 603   (:temporary (:scs (non-descriptor-reg)) temp)
 604   (:generator 8
 605     (let ((error (generate-error-code vop object-not-cons-error value)))
 606       (inst cmpeq value null-tn temp)
 607       (inst bne temp error)
 608       (test-type value temp error t list-pointer-type))
 609     (move value result)))
 610
 611 ) ; MACROLET