From: Christophe Rhodes <csr21@cam.ac.uk>
Date: Tue, 10 Sep 2002 17:15:26 +0000 (+0000)
Subject: 0.7.7.20-backend-cleanup-1.5:
X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=369029d73f198b59135c6c005b7a70ae5a753650;p=sbcl.git

0.7.7.20-backend-cleanup-1.5:
	Convert SPARC backend to new !DEFINE-TYPE-VOPS system
	... define %TEST-FOO functions
	... delete old over-general test type generating code
	... delete DEF-TYPE-VOPS calls
	... move early-type-vops earlier in the build process, so other
		backend files can use TEST-TYPE
	... update TEST-TYPE calls for new interface
	CAVEAT: I haven't (yet) tested this precise version on either
		x86 or SPARC. A very similar version has just passed
		tests on SPARC/Solaris, however. It is expected that
		this version works on both SPARC and x86 platforms
---

diff --git a/build-order.lisp-expr b/build-order.lisp-expr
index b379151..9388117 100644
--- a/build-order.lisp-expr
+++ b/build-order.lisp-expr
@@ -478,6 +478,7 @@
 
  ("src/compiler/target/insts")
  ("src/compiler/target/macros")
+ ("src/compiler/generic/early-type-vops")
 
  ("src/assembly/target/support")
 
@@ -523,7 +524,6 @@
   :ignore-failure-p)
  ("src/compiler/target/pred")
 
- ("src/compiler/generic/early-type-vops")
  ("src/compiler/target/type-vops")
  ("src/compiler/generic/late-type-vops")
 
diff --git a/src/compiler/sparc/macros.lisp b/src/compiler/sparc/macros.lisp
index 17c1ddc..dc0e1f5 100644
--- a/src/compiler/sparc/macros.lisp
+++ b/src/compiler/sparc/macros.lisp
@@ -251,197 +251,3 @@
 	;; The C code needs to process this correctly and fixup alloc-tn.
 	(inst t :ne pseudo-atomic-trap)))))
 
-;;; FIXME: test typing macros. Should(?) be in type-vops.lisp, except
-;;; that they're also used in subprim.lisp
-
-(defun cost-to-test-types (type-codes)
-  (+ (* 2 (length type-codes))
-     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-
-(defparameter *immediate-types*
-  (list base-char-widetag unbound-marker-widetag))
-
-(defparameter *fun-header-widetags*
-  (list funcallable-instance-header-widetag
-	simple-fun-header-widetag
-	closure-fun-header-widetag
-	closure-header-widetag))
-
-(defun gen-range-test (reg target not-target not-p min seperation max values)
-  (let ((tests nil)
-	(start nil)
-	(end nil)
-	(insts nil))
-    (multiple-value-bind (equal less-or-equal greater-or-equal label)
-	(if not-p
-	    (values :ne :gt :lt not-target)
-	    (values :eq :le :ge target))
-      (flet ((emit-test ()
-	       (if (= start end)
-		   (push start tests)
-		   (push (cons start end) tests))))
-	(dolist (value values)
-	  (cond ((< value min)
-		 (error "~S is less than the specified minimum of ~S"
-			value min))
-		((> value max)
-		 (error "~S is greater than the specified maximum of ~S"
-			value max))
-		((not (zerop (rem (- value min) seperation)))
-		 (error "~S isn't an even multiple of ~S from ~S"
-			value seperation min))
-		((null start)
-		 (setf start value))
-		((> value (+ end seperation))
-		 (emit-test)
-		 (setf start value)))
-	  (setf end value))
-	(emit-test))
-      (macrolet ((inst (name &rest args)
-		   `(push (list 'inst ',name ,@args) insts)))
-	(do ((remaining (nreverse tests) (cdr remaining)))
-	    ((null remaining))
-	  (let ((test (car remaining))
-		(last (null (cdr remaining))))
-	    (if (atom test)
-		(progn
-		  (inst cmp reg test)
-		  (if last
-		      (inst b equal target)
-		      (inst b :eq label)))
-		(let ((start (car test))
-		      (end (cdr test)))
-		  (cond ((and (= start min) (= end max))
-			 (warn "The values ~S cover the entire range from ~
-			 ~S to ~S [step ~S]."
-			       values min max seperation)
-			 (push `(unless ,not-p (inst b ,target)) insts))
-			((= start min)
-			 (inst cmp reg end)
-			 (if last
-			     (inst b less-or-equal target)
-			     (inst b :le label)))
-			((= end max)
-			 (inst cmp reg start)
-			 (if last
-			     (inst b greater-or-equal target)
-			     (inst b :ge label)))
-			(t
-			 (inst cmp reg start)
-			 (inst b :lt (if not-p target not-target))
-			 (inst cmp reg end)
-			 (if last
-			     (inst b less-or-equal target)
-			     (inst b :le label))))))))))
-    (nreverse insts)))
-
-(defun gen-other-immediate-test (reg target not-target not-p values)
-  (gen-range-test reg target not-target not-p
-		  (+ other-immediate-0-lowtag lowtag-limit)
-		  (- other-immediate-1-lowtag other-immediate-0-lowtag)
-		  (ash 1 n-widetag-bits)
-		  values))
-
-(defun test-type-aux (reg temp target not-target not-p lowtags immed hdrs
-		      function-p)
-  (let* ((fixnump (and (member even-fixnum-lowtag lowtags :test #'eql)
-		       (member odd-fixnum-lowtag lowtags :test #'eql)))
-	 (lowtags (sort (if fixnump
-			    (delete even-fixnum-lowtag
-				    (remove odd-fixnum-lowtag lowtags
-					    :test #'eql)
-				    :test #'eql)
-			    (copy-list lowtags))
-			#'<))
-	 (lowtag (if function-p
-		     fun-pointer-lowtag
-		     other-pointer-lowtag))
-	 (hdrs (sort (copy-list hdrs) #'<))
-	 (immed (sort (copy-list immed) #'<)))
-    (append
-     (when immed
-       `((inst and ,temp ,reg widetag-mask)
-	 ,@(if (or fixnump lowtags hdrs)
-	       (let ((fall-through (gensym)))
-		 `((let (,fall-through (gen-label))
-		     ,@(gen-other-immediate-test
-			temp (if not-p not-target target)
-			fall-through nil immed)
-		     (emit-label ,fall-through))))
-	       (gen-other-immediate-test temp target not-target not-p immed))))
-     (when fixnump
-       `((inst andcc zero-tn ,reg fixnum-tag-mask)
-	 ,(if (or lowtags hdrs)
-	      `(if (member :sparc-v9 *backend-subfeatures*)
-   		   (inst b :eq ,(if not-p not-target target) ,(if not-p :pn :pt))
-		   (inst b :eq ,(if not-p not-target target)))
-	      `(if (member :sparc-v9 *backend-subfeatures*)
-		   (inst b ,(if not-p :ne :eq) ,target ,(if not-p :pn :pt))
-		   (inst b ,(if not-p :ne :eq) ,target)))))
-     (when (or lowtags hdrs)
-       `((inst and ,temp ,reg lowtag-mask)))
-     (when lowtags
-       (if hdrs
-	   (let ((fall-through (gensym)))
-	     `((let ((,fall-through (gen-label)))
-		 ,@(gen-range-test temp (if not-p not-target target)
-				   fall-through nil
-				   0 1 (1- lowtag-limit) lowtags)
-		 (emit-label ,fall-through))))
-	   (gen-range-test temp target not-target not-p 0 1
-			   (1- lowtag-limit) lowtags)))
-     (when hdrs
-       `((inst cmp ,temp ,lowtag)
-	 (if (member :sparc-v9 *backend-subfeatures*)
-	     (inst b :ne ,(if not-p target not-target) ,(if not-p :pn :pt))
-	     (inst b :ne ,(if not-p target not-target)))
-	 (inst nop)
-	 (load-type ,temp ,reg (- ,lowtag))
-	 ,@(gen-other-immediate-test temp target not-target not-p hdrs))))))
-
-(defmacro test-type (register temp target not-p &rest type-codes)
-  (let* ((type-codes (mapcar #'eval type-codes))
-	 (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 nil))
-    (unless type-codes
-      (error "Must supply at least on type for test-type."))
-    (when (and headers (member other-pointer-lowtag lowtags))
-      (warn "OTHER-POINTER-TYPE supersedes the use of ~S" headers)
-      (setf headers nil))
-    (when (and immediates
-	       (or (member other-immediate-0-lowtag lowtags)
-		   (member other-immediate-1-lowtag lowtags)))
-      (warn "OTHER-IMMEDIATE-n-TYPE supersedes the use of ~S" immediates)
-      (setf immediates nil))
-    (when (intersection headers *fun-header-widetags*)
-      (unless (subsetp headers *fun-header-widetags*)
-	(error "Can't test for mix of function subtypes and normal ~
-		header types."))
-      (setq function-p t))
-    
-    (let ((n-reg (gensym))
-	  (n-temp (gensym))
-	  (n-target (gensym))
-	  (not-target (gensym)))
-      `(let ((,n-reg ,register)
-	     (,n-temp ,temp)
-	     (,n-target ,target)
-	     (,not-target (gen-label)))
-	(declare (ignorable ,n-temp))
-	,@(if (constantp not-p)
-	      (test-type-aux n-reg n-temp n-target not-target
-			     (eval not-p) lowtags immediates headers
-			     function-p)
-	      `((cond (,not-p
-		       ,@(test-type-aux n-reg n-temp n-target not-target t
-					lowtags immediates headers
-					function-p))
-		      (t
-		       ,@(test-type-aux n-reg n-temp n-target not-target nil
-					lowtags immediates headers
-					function-p)))))
-	(inst nop)
-	(emit-label ,not-target)))))
diff --git a/src/compiler/sparc/subprim.lisp b/src/compiler/sparc/subprim.lisp
index 4ff2127..37b2edc 100644
--- a/src/compiler/sparc/subprim.lisp
+++ b/src/compiler/sparc/subprim.lisp
@@ -37,11 +37,14 @@
       (inst b :eq done)
       (inst nop)
 
-      (test-type ptr temp not-list t list-pointer-lowtag)
+      ;; FIXME: Maybe rewrite this to remove this TEST-TYPE (and the
+      ;; one below) to put it in line with all other architectures
+      ;; (apart from PPC)?
+      (test-type ptr not-list t (list-pointer-lowtag) :temp temp)
 
       (loadw ptr ptr cons-cdr-slot list-pointer-lowtag)
       (inst add count count (fixnumize 1))
-      (test-type ptr temp loop nil list-pointer-lowtag)
+      (test-type ptr loop nil (list-pointer-lowtag) :temp temp)
 
       (cerror-call vop done object-not-list-error ptr)
 
diff --git a/src/compiler/sparc/type-vops.lisp b/src/compiler/sparc/type-vops.lisp
index e9de8df..3185d8e 100644
--- a/src/compiler/sparc/type-vops.lisp
+++ b/src/compiler/sparc/type-vops.lisp
@@ -11,6 +11,92 @@
 
 (in-package "SB!VM")
 
+
+(defun %test-fixnum (value target not-p &key temp)
+  (declare (ignore temp))
+  (assemble ()
+    (inst andcc zero-tn value fixnum-tag-mask)
+    (if (member :sparc-v9 *backend-subfeatures*)
+	(inst b (if not-p :ne :eq) target (if not-p :pn :pt))
+	(inst b (if not-p :ne :eq) target))
+    (inst nop)))
+
+(defun %test-fixnum-and-headers (value target not-p headers
+				 &key temp)
+  (let ((drop-through (gen-label)))
+    (assemble ()
+      (inst andcc zero-tn value fixnum-tag-mask)
+      (inst b :eq (if not-p drop-through target)))
+    (%test-headers value target not-p nil headers
+		   :drop-through drop-through
+		   :temp temp)))
+
+(defun %test-immediate (value target not-p immediate &key temp)
+  (assemble ()
+    (inst and temp value widetag-mask)
+    (inst cmp temp immediate)
+    ;; FIXME: include SPARC-V9 magic
+    (inst b (if not-p :ne :eq) target)
+    (inst nop)))
+
+(defun %test-lowtag (value target not-p lowtag
+		     &key temp skip-nop)
+  (assemble ()
+    (inst and temp value lowtag-mask)
+    (inst cmp temp lowtag)
+    ;; FIXME: include SPARC-V9 magic
+    (inst b (if not-p :ne :eq) target)
+    (unless skip-nop
+      (inst nop))))
+
+(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers
+				 &key temp)
+  (let ((drop-through (gen-label)))
+    (%test-lowtag value (if not-p drop-through target) not-p lowtag
+		  :temp temp :skip-nop t)
+    (%test-headers value target not-p function-p headers
+		   :temp temp :drop-through drop-through)))
+
+(defun %test-headers (value target not-p function-p headers
+		      &key temp (drop-through (gen-label)))
+  (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
+    (multiple-value-bind (when-true when-false)
+	(if not-p
+	    (values drop-through target)
+	    (values target drop-through))
+      (assemble ()
+	(%test-lowtag value when-false t lowtag :temp temp)
+	(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
+		   ;; FIXME: Some SPARC-V9 magic might not go amiss
+		   ;; here, too, if I can figure out what it should
+		   ;; be.
+		   (inst b (if not-p :ne :eq) target)
+		   (inst b :eq when-true)))
+	      (t
+	       (let ((start (car header))
+		     (end (cdr header)))
+		 ;; FIXME: BIGNUM-WIDETAG here actually means (MIN
+		 ;; <widetags>).
+		 (unless (= start bignum-widetag)
+		   (inst cmp temp start)
+		   (inst b :lt when-false))
+		 ;; FIXME: conceivably, it might be worth having a
+		 ;; (MAX <widetags>) here too.
+		 (inst cmp temp end)
+		 (if last
+		     (inst b (if not-p :gt :le) target)
+		     (inst b :le when-true)))))))
+	(inst nop)
+	(emit-label drop-through)))))
+
 ;;;; Simple type checking and testing:
 ;;;
 ;;; These types are represented by a single type code, so are easily
@@ -29,342 +115,39 @@
   (:policy :fast-safe)
   (:temporary (:scs (non-descriptor-reg)) temp))
 
-;;; moved to macros. FIXME.
-;;;(defun cost-to-test-types (type-codes)
-;;;  (+ (* 2 (length type-codes))
-;;;     (if (> (apply #'max type-codes) lowtag-limit) 7 2)))
-;;;
-;;;(defparameter immediate-types
-;;;  (list base-char-type unbound-marker-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))
-;;;
-;; FIXME: there's a canonicalize-headers in alpha/ and x86/
+(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)
-  ;;; FIXME: #+sb-xc-host?
+(defmacro !define-type-vops (pred-name check-name ptype error-code
+			 (&rest type-codes)
+			 &key &allow-other-keys)
   (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
+		 (test-type value target not-p (,@type-codes)
+			    :temp temp)))))
+      ,@(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)
+		   (test-type value err-lab t (,@type-codes)
+			      :temp temp)
 		   (move result value))))))
        ,@(when ptype
 	   `((primitive-type-vop ,check-name (:check) ,ptype))))))
 
-;;; This is a direct translation of the code in CMUCL
-;;; compiler/sparc/macros.lisp. Don't blame me if it doesn't work.
-
-;;; moved test-type back to macros.lisp, as other bits of code use it
-;;; too. FIXME.
-
-
-
-
-  
-;; Don't use this because it uses the deprecated taddcctv instruction.
-#+ignore
-(progn
-  (def-type-vops fixnump nil nil nil even-fixnum-lowtag odd-fixnum-lowtag)
-  (define-vop (check-fixnum check-type)
-      (:ignore temp)
-    (:generator 1
-		(inst taddcctv result value zero-tn)))
-  (primitive-type-vop check-fixnum (:check) fixnum))
-  
-;; This avoids the taddcctv instruction
-(def-type-vops fixnump check-fixnum fixnum object-not-fixnum-error
-	       even-fixnum-lowtag odd-fixnum-lowtag)
-(def-type-vops functionp check-fun function
-	       object-not-fun-error fun-pointer-lowtag)
-  
-  ;; The following encode the error type and register in the trap
-  ;; instruction, however this breaks on the later sparc Ultra.
-  #+ignore
-  (progn
-    (def-type-vops listp nil nil nil list-pointer-lowtag)
-    (define-vop (check-list check-type)
-	(:generator 3
-		    (inst and temp value lowtag-mask)
-		    (inst cmp temp list-pointer-lowtag)
-		    (inst t :ne (logior (ash (tn-offset value) 8) object-not-list-trap))
-		    (move result value)))
-    (primitive-type-vop check-list (:check) list)
-    
-    (def-type-vops %instancep nil nil nil instance-pointer-lowtag)
-    (define-vop (check-instance check-type)
-	(:generator 3
-		    (inst and temp value lowtag-mask)
-		    (inst cmp temp instance-pointer-lowtag)
-		    (inst t :ne (logior (ash (tn-offset value) 8) object-not-instance-trap))
-		    (move result value)))
-    (primitive-type-vop check-instance (:check) instance))
-
-  ;; These avoid the trap instruction.
-  (def-type-vops listp check-list list object-not-list-error
-  list-pointer-lowtag)
-  (def-type-vops %instancep check-instance instance object-not-instance-error
-  instance-pointer-lowtag)
-      
-  (def-type-vops bignump check-bignum bignum
-  object-not-bignum-error bignum-widetag)
-      
-  (def-type-vops ratiop check-ratio ratio
-  object-not-ratio-error ratio-widetag)
-      
-  (def-type-vops complexp check-complex complex object-not-complex-error
-  complex-widetag complex-single-float-widetag
-  complex-double-float-widetag #!+long-float complex-long-float-widetag)
-
-  (def-type-vops complex-rational-p check-complex-rational nil
-  object-not-complex-rational-error complex-widetag)
-
-  (def-type-vops complex-float-p check-complex-float nil
-  object-not-complex-float-error
-  complex-single-float-widetag complex-double-float-widetag
-  #!+long-float complex-long-float-widetag)
-
-  (def-type-vops complex-single-float-p check-complex-single-float
-  complex-single-float object-not-complex-single-float-error
-  complex-single-float-widetag)
-
-  (def-type-vops complex-double-float-p check-complex-double-float
-  complex-double-float object-not-complex-double-float-error
-  complex-double-float-widetag)
-
-  #!+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-widetag)
-
-  (def-type-vops single-float-p check-single-float single-float
-  object-not-single-float-error single-float-widetag)
-
-  (def-type-vops double-float-p check-double-float double-float
-  object-not-double-float-error double-float-widetag)
-
-  #!+long-float
-  (def-type-vops long-float-p check-long-float long-float
-  object-not-long-float-error long-float-widetag)
-
-  (def-type-vops simple-string-p check-simple-string simple-string
-  object-not-simple-string-error simple-string-widetag)
-
-  (def-type-vops simple-bit-vector-p check-simple-bit-vector simple-bit-vector
-  object-not-simple-bit-vector-error simple-bit-vector-widetag)
-      
-  (def-type-vops simple-vector-p check-simple-vector simple-vector
-  object-not-simple-vector-error simple-vector-widetag)
-      
-  (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-widetag)
-      
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-
-  (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-widetag)
-      
-  (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-widetag)
-
-  (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-widetag)
-
-  #!+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-widetag)
-      
-  (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-widetag)
-      
-  (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-widetag)
-      
-  #!+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-widetag)
-
-  (def-type-vops base-char-p check-base-char base-char
-  object-not-base-char-error base-char-widetag)
-      
-  (def-type-vops system-area-pointer-p check-system-area-pointer
-  system-area-pointer object-not-sap-error sap-widetag)
-      
-  (def-type-vops weak-pointer-p check-weak-pointer weak-pointer
-  object-not-weak-pointer-error weak-pointer-widetag)
-  ;; FIXME
-#|       
-  (def-type-vops scavenger-hook-p nil nil nil
-  0)
-|#
-  (def-type-vops code-component-p nil nil nil
-  code-header-widetag)
-      
-  (def-type-vops lra-p nil nil nil
-  return-pc-header-widetag)
-
-  (def-type-vops fdefn-p nil nil nil
-  fdefn-widetag)
-
-  (def-type-vops funcallable-instance-p nil nil nil
-  funcallable-instance-header-widetag)
-      
-  (def-type-vops array-header-p nil nil nil
-  simple-array-widetag complex-string-widetag complex-bit-vector-widetag
-  complex-vector-widetag complex-array-widetag)
-
-  ;; This appears to have disappeared. FIXME -- CSR
-  (def-type-vops nil check-fun-or-symbol nil object-not-fun-or-symbol-error
-  fun-pointer-lowtag symbol-header-widetag)
-      
-  (def-type-vops stringp check-string nil object-not-string-error
-  simple-string-widetag complex-string-widetag)
-      
-  (def-type-vops bit-vector-p check-bit-vector nil object-not-bit-vector-error
-  simple-bit-vector-widetag complex-bit-vector-widetag)
-
-  (def-type-vops vectorp check-vector nil object-not-vector-error
-  simple-string-widetag simple-bit-vector-widetag simple-vector-widetag
-  simple-array-unsigned-byte-2-widetag simple-array-unsigned-byte-4-widetag
-  simple-array-unsigned-byte-8-widetag simple-array-unsigned-byte-16-widetag
-  simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag
-  complex-string-widetag complex-bit-vector-widetag complex-vector-widetag)
-
-(def-type-vops complex-vector-p check-complex-vector nil object-not-complex-vector-error
-  complex-vector-widetag)
-
-  (def-type-vops simple-array-p check-simple-array nil object-not-simple-array-error
-  simple-array-widetag simple-string-widetag simple-bit-vector-widetag
-  simple-vector-widetag simple-array-unsigned-byte-2-widetag
-  simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
-  simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag)
-      
-  (def-type-vops arrayp check-array nil object-not-array-error
-  simple-array-widetag simple-string-widetag simple-bit-vector-widetag
-  simple-vector-widetag simple-array-unsigned-byte-2-widetag
-  simple-array-unsigned-byte-4-widetag simple-array-unsigned-byte-8-widetag
-  simple-array-unsigned-byte-16-widetag simple-array-unsigned-byte-32-widetag
-  simple-array-signed-byte-8-widetag simple-array-signed-byte-16-widetag
-  simple-array-signed-byte-30-widetag simple-array-signed-byte-32-widetag
-  simple-array-single-float-widetag simple-array-double-float-widetag
-  #!+long-float simple-array-long-float-widetag
-  simple-array-complex-single-float-widetag
-  simple-array-complex-double-float-widetag
-  #!+long-float simple-array-complex-long-float-widetag
-  complex-string-widetag complex-bit-vector-widetag complex-vector-widetag
-  complex-array-widetag)
-      
-  (def-type-vops numberp check-number nil object-not-number-error
-  even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag ratio-widetag
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag
-  complex-widetag complex-single-float-widetag complex-double-float-widetag
-  #!+long-float complex-long-float-widetag)
-      
-  (def-type-vops rationalp check-rational nil object-not-rational-error
-  even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag)
-      
-  (def-type-vops integerp check-integer nil object-not-integer-error
-  even-fixnum-lowtag odd-fixnum-lowtag bignum-widetag)
-      
-  (def-type-vops floatp check-float nil object-not-float-error
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag)
-      
-  (def-type-vops realp check-real nil object-not-real-error
-  even-fixnum-lowtag odd-fixnum-lowtag ratio-widetag bignum-widetag
-  single-float-widetag double-float-widetag #!+long-float long-float-widetag)
-
-  
+
 ;;;; 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)
+(define-vop (signed-byte-32-p type-predicate)
   (:translate signed-byte-32-p)
   (:generator 45
 	      (let ((not-target (gen-label)))
@@ -375,7 +158,7 @@
 			(values target not-target))
 		  (inst andcc zero-tn value #x3)
 		  (inst b :eq yep)
-		  (test-type value temp nope t other-pointer-lowtag)
+		  (test-type value nope t (other-pointer-lowtag) :temp temp)
 		  (loadw temp value 0 other-pointer-lowtag)
 		  (inst cmp temp (+ (ash 1 n-widetag-bits)
 				    bignum-widetag))
@@ -383,13 +166,13 @@
 		  (inst nop)
 		  (emit-label not-target)))))
 
-  (define-vop (check-signed-byte-32 check-type)
+(define-vop (check-signed-byte-32 check-type)
   (:generator 45
 	      (let ((nope (generate-error-code vop object-not-signed-byte-32-error value))
 		    (yep (gen-label)))
 		(inst andcc temp value #x3)
 		(inst b :eq yep)
-		(test-type value temp nope t other-pointer-lowtag)
+		(test-type value nope t (other-pointer-lowtag) :temp temp)
 		(loadw temp value 0 other-pointer-lowtag)
 		(inst cmp temp (+ (ash 1 n-widetag-bits) bignum-widetag))
 		(inst b :ne nope)
@@ -403,7 +186,7 @@
   ;; a bignum with exactly two digits and the second digit all
   ;; zeros.
 
-  (define-vop (unsigned-byte-32-p type-predicate)
+(define-vop (unsigned-byte-32-p type-predicate)
   (:translate unsigned-byte-32-p)
   (:generator 45
 	      (let ((not-target (gen-label))
@@ -420,7 +203,7 @@
 		  (inst cmp value)
 
 		  ;; If not, is it an other pointer?
-		  (test-type value temp nope t other-pointer-lowtag)
+		  (test-type value nope t (other-pointer-lowtag) :temp temp)
 		  ;; Get the header.
 		  (loadw temp value 0 other-pointer-lowtag)
 		  ;; Is it one?
@@ -452,7 +235,7 @@
 			
 		  (emit-label not-target)))))	  
 
-  (define-vop (check-unsigned-byte-32 check-type)
+(define-vop (check-unsigned-byte-32 check-type)
   (:generator 45
 	      (let ((nope
 		     (generate-error-code vop object-not-unsigned-byte-32-error value))
@@ -465,7 +248,7 @@
 		(inst cmp value)
 			
 		;; If not, is it an other pointer?
-		(test-type value temp nope t other-pointer-lowtag)
+		(test-type value nope t (other-pointer-lowtag) :temp temp)
 		;; Get the number of digits.
 		(loadw temp value 0 other-pointer-lowtag)
 		;; Is it one?
@@ -503,40 +286,40 @@
   ;; symbolp (or symbol (eq nil))
   ;; consp (and list (not (eq nil)))
       
-  (define-vop (symbolp type-predicate)
+(define-vop (symbolp type-predicate)
   (:translate symbolp)
   (:generator 12
 	      (let* ((drop-thru (gen-label))
 		     (is-symbol-label (if not-p drop-thru target)))
 		(inst cmp value null-tn)
 		(inst b :eq is-symbol-label)
-		(test-type value temp target not-p symbol-header-widetag)
+		(test-type value target not-p (symbol-header-widetag) :temp temp)
 		(emit-label drop-thru))))
       
-  (define-vop (check-symbol check-type)
+(define-vop (check-symbol check-type)
   (:generator 12
 	      (let ((drop-thru (gen-label))
 		    (error (generate-error-code vop object-not-symbol-error value)))
 		(inst cmp value null-tn)
 		(inst b :eq drop-thru)
-		(test-type value temp error t symbol-header-widetag)
+		(test-type value error t (symbol-header-widetag) :temp temp)
 		(emit-label drop-thru)
 		(move result value))))
       
-  (define-vop (consp type-predicate)
+(define-vop (consp type-predicate)
   (:translate consp)
   (:generator 8
 	      (let* ((drop-thru (gen-label))
 		     (is-not-cons-label (if not-p target drop-thru)))
 		(inst cmp value null-tn)
 		(inst b :eq is-not-cons-label)
-		(test-type value temp target not-p list-pointer-lowtag)
+		(test-type value target not-p (list-pointer-lowtag) :temp temp)
 		(emit-label drop-thru))))
       
-  (define-vop (check-cons check-type)
+(define-vop (check-cons check-type)
   (:generator 8
 	      (let ((error (generate-error-code vop object-not-cons-error value)))
 		(inst cmp value null-tn)
 		(inst b :eq error)
-		(test-type value temp error t list-pointer-lowtag)
+		(test-type value error t (list-pointer-lowtag) :temp temp)
 		(move result value))))
diff --git a/src/compiler/sparc/values.lisp b/src/compiler/sparc/values.lisp
index 1a83482..b9db246 100644
--- a/src/compiler/sparc/values.lisp
+++ b/src/compiler/sparc/values.lisp
@@ -74,7 +74,7 @@
       (loadw list list cons-cdr-slot list-pointer-lowtag)
       (inst add csp-tn csp-tn n-word-bytes)
       (storew temp csp-tn -1)
-      (test-type list ndescr loop nil list-pointer-lowtag)
+      (test-type list loop nil (list-pointer-lowtag) :temp ndescr)
       (error-call vop bogus-arg-to-values-list-error list)
 
       (emit-label done)
diff --git a/version.lisp-expr b/version.lisp-expr
index c0f339a..beccc5a 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -18,4 +18,4 @@
 ;;; for internal versions, especially for internal versions off the
 ;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.7.20-backend-cleanup-1.4"
+"0.7.7.20-backend-cleanup-1.5"