;;; -*- Mode: LISP; Syntax: Common-Lisp; Base: 10; Package: x86 -*-
;;;
;;; **********************************************************************
;;; This code was written as part of the CMU Common Lisp project at
;;; Carnegie Mellon University, and has been placed in the public domain.
;;; If you want to use this code or any part of CMU Common Lisp, please contact
;;; Scott Fahlman or slisp-group@cs.cmu.edu.
;;;
(ext:file-comment

 "$Header: src/compiler/x86/type-vops.lisp $")

;;;
;;; **********************************************************************
;;; 
;;; This file contains the VM definition of type testing and checking VOPs
;;; for the x86.
;;;
;;; Written by William Lott.
;;;
;;; Debugged by Paul F. Werkowski, Spring-95.

;;; Enhancements/debugging by Douglas T. Crosher 1996,1997,1998.

;;;
(in-package :x86)

(intl:textdomain "cmucl-x86-vm")


;;;; Test generation utilities.

(eval-when (compile eval)

(defparameter immediate-types
  (list unbound-marker-type base-char-type))


(defparameter function-header-types

  (list funcallable-instance-header-type 

	byte-code-function-type byte-code-closure-type
	function-header-type closure-function-header-type
	closure-header-type))

(defun canonicalize-headers (headers)
  (collect ((results))
    (let ((start nil)
	  (prev nil)
	  (delta (- other-immediate-1-type other-immediate-0-type)))
      (flet ((emit-test ()
	       (results (if (= start prev)
			    start
			    (cons start prev)))))
	(dolist (header (sort headers #'<))
	  (cond ((null start)
		 (setf start header)
		 (setf prev header))
		((= header (+ prev delta))
		 (setf prev header))
		(t
		 (emit-test)
		 (setf start header)
		 (setf prev header))))
	(emit-test)))
    (results)))

(defmacro test-type (value temp target not-p &rest type-codes)

  ;; Determine what interesting combinations we need to test for.
  (let* ((type-codes (mapcar #'eval type-codes))
	 (fixnump (and (member even-fixnum-type type-codes)
		       (member odd-fixnum-type type-codes)
		       t))
	 (lowtags (remove lowtag-limit type-codes :test #'<))
	 (extended (remove lowtag-limit type-codes :test #'>))
	 (immediates (intersection extended immediate-types :test #'eql))
	 (headers (set-difference extended immediate-types :test #'eql))
	 (function-p (if (intersection headers function-header-types)
			 (if (subsetp headers function-header-types)
			     t
			     (error "Can't test for mix of function subtypes ~
				     and normal header types."))
			 nil)))
    (unless type-codes
      (error "Must supply at least one type for test-type."))
    (cond
     (fixnump
      (when (remove-if #'(lambda (x)
			   (or (= x even-fixnum-type)
			       (= x odd-fixnum-type)))
		       lowtags)
	(error "Can't mix fixnum testing with other lowtags."))
      (when function-p
	(error "Can't mix fixnum testing with function subtype testing."))
      (when immediates
	(error "Can't mix fixnum testing with other immediates."))
      (if headers

	  `(%test-fixnum-and-headers ,value ,temp ,target ,not-p

				     ',(canonicalize-headers headers))
	  `(%test-fixnum ,value ,target ,not-p)))
     (immediates
      (when headers
	(error "Can't mix testing of immediates with testing of headers."))
      (when lowtags
	(error "Can't mix testing of immediates with testing of lowtags."))
      (when (cdr immediates)
	(error "Can't test multiple immediates at the same time."))

      `(%test-immediate ,value ,temp ,target ,not-p ,(car immediates)))

     (lowtags
      (when (cdr lowtags)
	(error "Can't test multiple lowtags at the same time."))
      (if headers
	  `(%test-lowtag-and-headers

	    ,value ,temp ,target ,not-p ,(car lowtags)

	    ,function-p ',(canonicalize-headers headers))

	  `(%test-lowtag ,value ,temp ,target ,not-p ,(car lowtags))))

     (headers

      `(%test-headers ,value ,temp ,target ,not-p ,function-p

		      ',(canonicalize-headers headers)))
     (t
      (error "Nothing to test?")))))


); eval-when (compile eval)

;;; Emit the most compact form of the test immediate instruction,
;;; using an 8 bit test when the immediate is only 8 bits and the
;;; value is one of the four low registers (eax, ebx, ecx, edx) or the
;;; control-stack.
;;;

(defun generate-fixnum-test (value)

  (let ((offset (tn-offset value)))

    (cond ((and (sc-is value any-reg descriptor-reg)

		(or (= offset eax-offset) (= offset ebx-offset)
		    (= offset ecx-offset) (= offset edx-offset)))
	   (inst test (make-random-tn :kind :normal

				      :sc (sc-or-lose 'byte-reg *backend*)

				      :offset offset)

		 3))

	  ((sc-is value control-stack)
	   (inst test (make-ea :byte :base ebp-tn
			       :disp (- (* (1+ offset) vm:word-bytes)))

		 3))

	  (t
	   (inst test value 3)))))

(defun %test-fixnum (value target not-p)

  (generate-fixnum-test value)

  (inst jmp (if not-p :nz :z) target))

(defun %test-fixnum-and-headers (value temp target not-p headers)

  (let ((drop-through (gen-label)))

    (generate-fixnum-test value)

    (inst jmp :z (if not-p drop-through target))

    (%test-headers value temp target not-p nil headers drop-through)))

(defun %test-immediate (value temp target not-p immediate)

  ;; Code a single instruction byte test if possible.
  (let ((offset (tn-offset value)))
    (cond ((and (sc-is value any-reg descriptor-reg)
		(or (= offset eax-offset) (= offset ebx-offset)
		    (= offset ecx-offset) (= offset edx-offset)))
	   (inst cmp (make-random-tn :kind :normal

				     :sc (sc-or-lose 'byte-reg *backend*)

				     :offset offset)
		 immediate))
	  (t

	   (move temp value)
	   (inst and temp type-mask)
	   (inst cmp temp immediate))))

  (inst jmp (if not-p :ne :e) target))

(defun %test-lowtag (value temp target not-p lowtag &optional temp-loaded)
  (unless temp-loaded
    (move temp value)
    (inst and temp lowtag-mask))
  (inst cmp temp lowtag)

  (inst jmp (if not-p :ne :e) target))

(defun %test-lowtag-and-headers (value temp target not-p lowtag
				       function-p headers)

  (let ((drop-through (gen-label)))

    (%test-lowtag value temp (if not-p drop-through target) nil lowtag)
    (%test-headers value temp target not-p function-p headers drop-through t)))

(defun %test-headers (value temp target not-p function-p headers
			    &optional (drop-through (gen-label)) temp-loaded)

  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
    (multiple-value-bind
	(equal less-or-equal when-true when-false)
	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
	;; it's true and when we know it's false respectively.
	(if not-p
	    (values :ne :a drop-through target)
	    (values :e :na target drop-through))

      (%test-lowtag value temp when-false t lowtag temp-loaded)
      (load-type temp value (- lowtag))

      (do ((remaining headers (cdr remaining)))
	  ((null remaining))
	(let ((header (car remaining))
	      (last (null (cdr remaining))))
	  (cond
	   ((atom header)

	    (inst cmp temp header)

	    (if last
		(inst jmp equal target)
		(inst jmp :e when-true)))
	   (t
	     (let ((start (car header))
		   (end (cdr header)))
	       (unless (= start bignum-type)

		 (inst cmp temp start)

		 (inst jmp :b when-false)) ; was :l

	       (inst cmp temp end)

	       (if last
		   (inst jmp less-or-equal target)
		   (inst jmp :be when-true))))))) ; was :le
      (emit-label drop-through))))

;; pw -- based on RISC version. Not sure extra hair is needed yet.
;; difference is that this one uses SUB which overwrites operand
;; both cmp and sub take 2 cycles so maybe its a wash
#+nil
(defun %test-headers (value target not-p function-p headers

			    &optional (drop-through (gen-label)) temp-loaded)

  (let ((lowtag (if function-p function-pointer-type other-pointer-type)))
    (multiple-value-bind
	(equal less-or-equal when-true when-false)
	;; EQUAL and LESS-OR-EQUAL are the conditions for branching to TARGET.
	;; WHEN-TRUE and WHEN-FALSE are the labels to branch to when we know
	;; it's true and when we know it's false respectively.
	(if not-p
	    (values :ne :a drop-through target)
	    (values :e :na target drop-through))

      (%test-lowtag value when-false t lowtag temp-loaded)
      (load-type temp value (- lowtag))

      (let ((delta 0))
	(do ((remaining headers (cdr remaining)))
	    ((null remaining))
	  (let ((header (car remaining))
		(last (null (cdr remaining))))
	    (cond
	      ((atom header)

	       (inst sub temp (- header delta))

	       (setf delta header)
	       (if last
		   (inst jmp equal target)
		   (inst jmp :e when-true)))
	      (t
	       (let ((start (car header))
		     (end (cdr header)))
		 (unless (= start bignum-type)

		   (inst sub temp (- start delta))

		   (setf delta start)
		   (inst jmp :l when-false))

		 (inst sub temp (- end delta))

		 (setf delta end)
		 (if last
		     (inst jmp less-or-equal target)
		     (inst jmp :le when-true))))))))
      (emit-label drop-through))))


;;;; Type checking and testing:

(define-vop (check-type)
  (:args (value :target result :scs (any-reg descriptor-reg)))
  (:results (result :scs (any-reg descriptor-reg)))

  (:temporary (:scs (unsigned-reg) :to (:result 0)) temp)

  (:vop-var vop)
  (:save-p :compute-only))

(define-vop (type-predicate)
  (:args (value :scs (any-reg descriptor-reg)))

  (:temporary (:scs (unsigned-reg)) temp)

  (:conditional)
  (:info target not-p)
  (:policy :fast-safe))

;;; Simpler VOP that don't need a temporary register.
(define-vop (simple-check-type)
  (:args (value :target result :scs (any-reg descriptor-reg)))
  (:results (result :scs (any-reg descriptor-reg)
		    :load-if (not (and (sc-is value any-reg descriptor-reg)
				       (sc-is result control-stack)))))
  (:vop-var vop)
  (:save-p :compute-only))

(define-vop (simple-type-predicate)
  (:args (value :scs (any-reg descriptor-reg control-stack)))
  (:conditional)
  (:info target not-p)
  (:policy :fast-safe))

(eval-when (compile eval)

(defun cost-to-test-types (type-codes)
  (+ (* 2 (length type-codes))
     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))

(defmacro def-type-vops (pred-name check-name ptype error-code
				   &rest type-codes)
  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
    `(progn
       ,@(when pred-name
	   `((define-vop (,pred-name type-predicate)
	       (:translate ,pred-name)
	       (:generator ,cost

		 (test-type value temp target not-p ,@type-codes)))))

       ,@(when check-name
	   `((define-vop (,check-name check-type)
	       (:generator ,cost
		 (let ((err-lab
			(generate-error-code vop ,error-code value)))

		   (test-type value temp err-lab t ,@type-codes)

		   (move result value))))))
       ,@(when ptype
	   `((primitive-type-vop ,check-name (:check) ,ptype))))))

(defmacro def-simple-type-vops (pred-name check-name ptype error-code
					  &rest type-codes)
  (let ((cost (cost-to-test-types (mapcar #'eval type-codes))))
    `(progn
       ,@(when pred-name
	   `((define-vop (,pred-name simple-type-predicate)
	       (:translate ,pred-name)
	       (:generator ,cost

		 (test-type value temp target not-p ,@type-codes)))))

       ,@(when check-name
	   `((define-vop (,check-name simple-check-type)
	       (:generator ,cost
		 (let ((err-lab
			(generate-error-code vop ,error-code value)))

		   (test-type value temp err-lab t ,@type-codes)

		   (move result value))))))
       ,@(when ptype
	   `((primitive-type-vop ,check-name (:check) ,ptype))))))

); eval-when (compile eval)

(def-simple-type-vops fixnump check-fixnum fixnum object-not-fixnum-error

  even-fixnum-type odd-fixnum-type)

(def-type-vops functionp check-function function
  object-not-function-error function-pointer-type)

(def-type-vops listp check-list list object-not-list-error
  list-pointer-type)

(def-type-vops %instancep check-instance instance object-not-instance-error
  instance-pointer-type)

(def-type-vops bignump check-bignum bignum
  object-not-bignum-error bignum-type)

(def-type-vops ratiop check-ratio ratio
  object-not-ratio-error ratio-type)

(def-type-vops complexp check-complex complex object-not-complex-error

  complex-type complex-single-float-type complex-double-float-type

  #+long-float complex-long-float-type
  #+double-double vm::complex-double-double-float-type)

(def-type-vops complex-rational-p check-complex-rational nil
  object-not-complex-rational-error complex-type)

(def-type-vops complex-float-p check-complex-float nil

  object-not-complex-float-error

  complex-single-float-type complex-double-float-type

  #+long-float complex-long-float-type
  #+double-double vm::complex-double-double-float-type)

(def-type-vops complex-single-float-p check-complex-single-float
  complex-single-float object-not-complex-single-float-error
  complex-single-float-type)

(def-type-vops complex-double-float-p check-complex-double-float
  complex-double-float object-not-complex-double-float-error
  complex-double-float-type)

#+long-float

(def-type-vops complex-long-float-p check-complex-long-float
  complex-long-float object-not-complex-long-float-error
  complex-long-float-type)

#+double-double
(def-type-vops complex-double-double-float-p check-complex-double-double-float
  complex-double-double-float object-not-complex-double-double-float-error
  vm::complex-double-double-float-type)

(def-type-vops single-float-p check-single-float single-float
  object-not-single-float-error single-float-type)

(def-type-vops double-float-p check-double-float double-float
  object-not-double-float-error double-float-type)

#+long-float
(def-type-vops long-float-p check-long-float long-float
  object-not-long-float-error long-float-type)

#+double-double
(def-type-vops double-double-float-p check-double-double-float
  double-double-float object-not-double-double-float-error
  vm:double-double-float-type)
	       

(def-type-vops simple-string-p check-simple-string simple-string
  object-not-simple-string-error simple-string-type)

(def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
  object-not-simple-bit-vector-error simple-bit-vector-type)

(def-type-vops simple-vector-p check-simple-vector simple-vector
  object-not-simple-vector-error simple-vector-type)

(def-type-vops simple-array-unsigned-byte-2-p
  check-simple-array-unsigned-byte-2
  simple-array-unsigned-byte-2
  object-not-simple-array-unsigned-byte-2-error
  simple-array-unsigned-byte-2-type)

(def-type-vops simple-array-unsigned-byte-4-p
  check-simple-array-unsigned-byte-4
  simple-array-unsigned-byte-4
  object-not-simple-array-unsigned-byte-4-error
  simple-array-unsigned-byte-4-type)

(def-type-vops simple-array-unsigned-byte-8-p
  check-simple-array-unsigned-byte-8
  simple-array-unsigned-byte-8
  object-not-simple-array-unsigned-byte-8-error
  simple-array-unsigned-byte-8-type)

(def-type-vops simple-array-unsigned-byte-16-p
  check-simple-array-unsigned-byte-16
  simple-array-unsigned-byte-16
  object-not-simple-array-unsigned-byte-16-error
  simple-array-unsigned-byte-16-type)

(def-type-vops simple-array-unsigned-byte-32-p
  check-simple-array-unsigned-byte-32
  simple-array-unsigned-byte-32
  object-not-simple-array-unsigned-byte-32-error
  simple-array-unsigned-byte-32-type)

(def-type-vops simple-array-signed-byte-8-p
  check-simple-array-signed-byte-8
  simple-array-signed-byte-8
  object-not-simple-array-signed-byte-8-error
  simple-array-signed-byte-8-type)

(def-type-vops simple-array-signed-byte-16-p
  check-simple-array-signed-byte-16
  simple-array-signed-byte-16
  object-not-simple-array-signed-byte-16-error
  simple-array-signed-byte-16-type)

(def-type-vops simple-array-signed-byte-30-p
  check-simple-array-signed-byte-30
  simple-array-signed-byte-30
  object-not-simple-array-signed-byte-30-error
  simple-array-signed-byte-30-type)

(def-type-vops simple-array-signed-byte-32-p
  check-simple-array-signed-byte-32
  simple-array-signed-byte-32
  object-not-simple-array-signed-byte-32-error
  simple-array-signed-byte-32-type)

(def-type-vops simple-array-single-float-p check-simple-array-single-float
  simple-array-single-float object-not-simple-array-single-float-error
  simple-array-single-float-type)

(def-type-vops simple-array-double-float-p check-simple-array-double-float
  simple-array-double-float object-not-simple-array-double-float-error
  simple-array-double-float-type)

#+long-float
(def-type-vops simple-array-long-float-p check-simple-array-long-float
  simple-array-long-float object-not-simple-array-long-float-error
  simple-array-long-float-type)

#+double-double
(def-type-vops simple-array-double-double-float-p check-simple-array-double-double-float
  simple-array-double-double-float object-not-simple-array-double-double-float-error
  vm::simple-array-double-double-float-type)

(def-type-vops simple-array-complex-single-float-p
  check-simple-array-complex-single-float
  simple-array-complex-single-float
  object-not-simple-array-complex-single-float-error
  simple-array-complex-single-float-type)

(def-type-vops simple-array-complex-double-float-p
  check-simple-array-complex-double-float
  simple-array-complex-double-float
  object-not-simple-array-complex-double-float-error
  simple-array-complex-double-float-type)

#+long-float

(def-type-vops simple-array-complex-long-float-p
  check-simple-array-complex-long-float
  simple-array-complex-long-float
  object-not-simple-array-complex-long-float-error
  simple-array-complex-long-float-type)

#+double-double
(def-type-vops simple-array-complex-double-double-float-p
  check-simple-array-complex-double-double-float
  simple-array-complex-double-double-float
  object-not-simple-array-complex-double-double-float-error
  vm::simple-array-complex-double-double-float-type)

(def-type-vops base-char-p check-base-char base-char
  object-not-base-char-error base-char-type)

(def-type-vops system-area-pointer-p check-system-area-pointer
  system-area-pointer object-not-sap-error sap-type)

(def-type-vops weak-pointer-p check-weak-pointer weak-pointer
  object-not-weak-pointer-error weak-pointer-type)

(def-type-vops scavenger-hook-p nil nil nil

  #-gencgc 0 #+gencgc scavenger-hook-type)

(def-type-vops code-component-p nil nil nil
  code-header-type)

(def-type-vops lra-p nil nil nil
  return-pc-header-type)

(def-type-vops fdefn-p nil nil nil
  fdefn-type)

(def-type-vops funcallable-instance-p nil nil nil
  funcallable-instance-header-type)

(def-type-vops array-header-p nil nil nil
  simple-array-type complex-string-type complex-bit-vector-type
  complex-vector-type complex-array-type)

(def-type-vops nil check-function-or-symbol nil
  object-not-function-or-symbol-error
  function-pointer-type symbol-header-type)

(def-type-vops stringp check-string nil object-not-string-error
  simple-string-type complex-string-type)

(def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
  simple-bit-vector-type complex-bit-vector-type)

(def-type-vops vectorp check-vector nil object-not-vector-error
  simple-string-type simple-bit-vector-type simple-vector-type
  simple-array-unsigned-byte-2-type simple-array-unsigned-byte-4-type
  simple-array-unsigned-byte-8-type simple-array-unsigned-byte-16-type

  simple-array-unsigned-byte-32-type

  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
  simple-array-signed-byte-30-type simple-array-signed-byte-32-type

  simple-array-single-float-type simple-array-double-float-type

  #+long-float simple-array-long-float-type

  #+double-double vm::simple-array-double-double-float-type

  simple-array-complex-single-float-type
  simple-array-complex-double-float-type
  #+long-float simple-array-complex-long-float-type

  #+double-double vm::simple-array-complex-double-double-float-type

  complex-string-type complex-bit-vector-type complex-vector-type)

(def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
  simple-array-type simple-string-type simple-bit-vector-type
  simple-vector-type simple-array-unsigned-byte-2-type
  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type

  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
  simple-array-signed-byte-30-type simple-array-signed-byte-32-type

  simple-array-single-float-type simple-array-double-float-type

  #+long-float simple-array-long-float-type

  #+double-double vm::simple-array-double-double-float-type

  simple-array-complex-single-float-type
  simple-array-complex-double-float-type

  #+long-float simple-array-complex-long-float-type
  #+double-double vm::simple-array-complex-double-double-float-type
  )

(def-type-vops arrayp check-array nil object-not-array-error
  simple-array-type simple-string-type simple-bit-vector-type
  simple-vector-type simple-array-unsigned-byte-2-type
  simple-array-unsigned-byte-4-type simple-array-unsigned-byte-8-type
  simple-array-unsigned-byte-16-type simple-array-unsigned-byte-32-type

  simple-array-signed-byte-8-type simple-array-signed-byte-16-type
  simple-array-signed-byte-30-type simple-array-signed-byte-32-type

  simple-array-single-float-type simple-array-double-float-type

  #+long-float simple-array-long-float-type

  #+double-double vm::simple-array-double-double-float-type

  simple-array-complex-single-float-type
  simple-array-complex-double-float-type
  #+long-float simple-array-complex-long-float-type

  #+double-double vm::simple-array-complex-double-double-float-type

  complex-string-type complex-bit-vector-type complex-vector-type
  complex-array-type)

(def-type-vops numberp check-number nil object-not-number-error
  even-fixnum-type odd-fixnum-type bignum-type ratio-type

  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type
  complex-type

  complex-single-float-type complex-double-float-type

  #+long-float complex-long-float-type
  #+double-double vm::complex-double-double-float-type)

(def-type-vops rationalp check-rational nil object-not-rational-error
  even-fixnum-type odd-fixnum-type ratio-type bignum-type)

(def-type-vops integerp check-integer nil object-not-integer-error
  even-fixnum-type odd-fixnum-type bignum-type)

(def-type-vops floatp check-float nil object-not-float-error

  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type)

(def-type-vops realp check-real nil object-not-real-error
  even-fixnum-type odd-fixnum-type ratio-type bignum-type

  single-float-type double-float-type #+long-float long-float-type
  #+double-double vm:double-double-float-type)


;;;; Other integer ranges.

;;; A (signed-byte 32) can be represented with either fixnum or a bignum with
;;; exactly one digit.

(define-vop (signed-byte-32-p type-predicate)
  (:translate signed-byte-32-p)
  (:generator 45
    (multiple-value-bind
	(yep nope)
	(if not-p
	    (values not-target target)
	    (values target not-target))

      (generate-fixnum-test value)

      (inst jmp :e yep)

      (move temp value)
      (inst and temp lowtag-mask)
      (inst cmp temp other-pointer-type)

      (inst jmp :ne nope)

      (loadw temp value 0 other-pointer-type)
      (inst cmp temp (+ (ash 1 type-bits) bignum-type))

      (inst jmp (if not-p :ne :e) target))
    NOT-TARGET))

(define-vop (check-signed-byte-32 check-type)
  (:generator 45
    (let ((nope (generate-error-code vop
				     object-not-signed-byte-32-error
				     value)))

      (generate-fixnum-test value)

      (inst jmp :e yep)

      (move temp value)
      (inst and temp lowtag-mask)
      (inst cmp temp other-pointer-type)

      (inst jmp :ne nope)

      (loadw temp value 0 other-pointer-type)
      (inst cmp temp (+ (ash 1 type-bits) bignum-type))

      (inst jmp :ne nope))
    YEP
    (move result value)))

;;; An (unsigned-byte 32) can be represented with either a positive fixnum, a
;;; bignum with exactly one positive digit, or a bignum with exactly two digits
;;; and the second digit all zeros.

(define-vop (unsigned-byte-32-p type-predicate)
  (:translate unsigned-byte-32-p)
  (:generator 45
    (let ((not-target (gen-label))
	  (single-word (gen-label))
	  (fixnum (gen-label)))
      (multiple-value-bind
	  (yep nope)
	  (if not-p
	      (values not-target target)
	      (values target not-target))
	;; Is it a fixnum?

	(generate-fixnum-test value)

	(move temp value)

	(inst jmp :e fixnum)

	;; If not, is it an other pointer?

	(inst and temp lowtag-mask)
	(inst cmp temp other-pointer-type)

	(inst jmp :ne nope)
	;; Get the header.

	(loadw temp value 0 other-pointer-type)

	;; Is it one?

	(inst cmp temp (+ (ash 1 type-bits) bignum-type))

	(inst jmp :e single-word)
	;; If it's other than two, we can't be an (unsigned-byte 32)

	(inst cmp temp (+ (ash 2 type-bits) bignum-type))

	(inst jmp :ne nope)
	;; Get the second digit.

	(loadw temp value (1+ bignum-digits-offset) other-pointer-type)

	;; All zeros, its an (unsigned-byte 32).

	(inst test temp temp)

	(inst jmp :z yep)
	(inst jmp nope)
	
	(emit-label single-word)
	;; Get the single digit.

	(loadw temp value bignum-digits-offset other-pointer-type)

	;; positive implies (unsigned-byte 32).
	(emit-label fixnum)

	(inst test temp temp)

	(inst jmp (if not-p :s :ns) target)

	(emit-label not-target)))))

(define-vop (check-unsigned-byte-32 check-type)
  (:generator 45
    (let ((nope
	   (generate-error-code vop object-not-unsigned-byte-32-error value))
	  (yep (gen-label))
	  (fixnum (gen-label))
	  (single-word (gen-label)))

      ;; Is it a fixnum?

      (generate-fixnum-test value)

      (move temp value)

      (inst jmp :e fixnum)

      ;; If not, is it an other pointer?

      (inst and temp lowtag-mask)
      (inst cmp temp other-pointer-type)

      (inst jmp :ne nope)
      ;; Get the header.

      (loadw temp value 0 other-pointer-type)

      ;; Is it one?

      (inst cmp temp (+ (ash 1 type-bits) bignum-type))

      (inst jmp :e single-word)
      ;; If it's other than two, we can't be an (unsigned-byte 32)

      (inst cmp temp (+ (ash 2 type-bits) bignum-type))

      (inst jmp :ne nope)
      ;; Get the second digit.

      (loadw temp value (1+ bignum-digits-offset) other-pointer-type)

      ;; All zeros, its an (unsigned-byte 32).

      (inst or temp temp)

      (inst jmp :z yep)
      (inst jmp nope)
	
      (emit-label single-word)
      ;; Get the single digit.

      (loadw temp value bignum-digits-offset other-pointer-type)

      ;; positive implies (unsigned-byte 32).
      (emit-label fixnum)

      (inst or temp temp)

      (inst jmp :s nope)

      (emit-label yep)
      (move result value))))


;;;; List/symbol types:
;;; 
;;; symbolp (or symbol (eq nil))
;;; consp (and list (not (eq nil)))

(define-vop (symbolp type-predicate)
  (:translate symbolp)
  (:generator 12
    (let ((is-symbol-label (if not-p drop-thru target)))
      (inst cmp value nil-value)
      (inst jmp :e is-symbol-label)

      (test-type value temp target not-p symbol-header-type))

    DROP-THRU))

(define-vop (check-symbol check-type)
  (:generator 12
    (let ((error (generate-error-code vop object-not-symbol-error value)))
      (inst cmp value nil-value)
      (inst jmp :e drop-thru)

      (test-type value temp error t symbol-header-type))

    DROP-THRU
    (move result value)))
  
(define-vop (consp type-predicate)
  (:translate consp)
  (:generator 8
    (let ((is-not-cons-label (if not-p target drop-thru)))
      (inst cmp value nil-value)
      (inst jmp :e is-not-cons-label)

      (test-type value temp target not-p list-pointer-type))

    DROP-THRU))

(define-vop (check-cons check-type)
  (:generator 8
    (let ((error (generate-error-code vop object-not-cons-error value)))
      (inst cmp value nil-value)
      (inst jmp :e error)

      (test-type value temp error t list-pointer-type)