X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fsparc%2Ftype-vops.lisp;h=ef4d12618dfa5ceda946976b4852e0970ac045c6;hb=74149058e97f29fe8907c125da65f5e4fa6ddf2c;hp=3185d8e4c91b78b9ab9306d59b148467163238e6;hpb=369029d73f198b59135c6c005b7a70ae5a753650;p=sbcl.git

diff --git a/src/compiler/sparc/type-vops.lisp b/src/compiler/sparc/type-vops.lisp
index 3185d8e..ef4d126 100644
--- a/src/compiler/sparc/type-vops.lisp
+++ b/src/compiler/sparc/type-vops.lisp
@@ -49,14 +49,6 @@
     (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)))
@@ -73,27 +65,62 @@
 		(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)))
+	       (cond
+		 ((and (not last) (null (cddr remaining))
+		       (atom (cadr remaining))
+		       (= (logcount (logxor header (cadr remaining))) 1))
+		  (inst and temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
+		  (inst cmp temp (ldb (byte 8 0) (logand header (cadr remaining))))
+		  (inst b (if not-p :ne :eq) target)
+		  (return))
+		 (t
+		  (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)))))))
+		 (cond 
+		   ;; FIXME: this doesn't catch the {0x2 0x6 0xA 0xE}
+		   ;; group
+		   ;;
+		   ;; also FIXME: exuberant cut'n'paste between
+		   ;; backends
+		   ((and last (not (= start bignum-widetag))
+			 (= (+ start 4) end)
+			 (= (logcount (logxor start end)) 1))
+		    (inst and temp temp (ldb (byte 8 0) (logeqv start end)))
+		    (inst cmp temp (ldb (byte 8 0) (logand start end)))
+		    (inst b (if not-p :ne :eq) target))
+		   ((and (not last) (null (cddr remaining))
+			 (= (+ start 4) end) (= (logcount (logxor start end)) 1)
+			 (listp (cadr remaining))
+			 (= (+ (caadr remaining) 4) (cdadr remaining))	
+			 (= (logcount (logxor (caadr remaining) (cdadr remaining))) 1)
+			 (= (logcount (logxor (caadr remaining) start)) 1))
+		    (inst and temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+		    (inst cmp temp (ldb (byte 8 0) (logand start (cdadr remaining))))
+		    (inst b (if not-p :ne :eq) target)
+		    (return))
+		   (t
+		    (unless (= start bignum-widetag)
+		      (inst cmp temp start)
+		      (if (= end complex-array-widetag)
+			  (progn
+			    (aver last)
+			    (inst b (if not-p :lt :ge) target))
+			  (inst b :lt when-false)))
+		    (unless (= end complex-array-widetag)
+		      (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)))))