X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fppc%2Ftype-vops.lisp;h=9a82f52e4351bdc4fccb341902f977e9f5fa37c8;hb=8a8568603cc7cacd188fe1cac18824a69bece6af;hp=87d5dee25ebde3eda089d9a9539ca9a6fad81745;hpb=7ce4dc62a7b03590b127bb950738e771e33341a7;p=sbcl.git

diff --git a/src/compiler/ppc/type-vops.lisp b/src/compiler/ppc/type-vops.lisp
index 87d5dee..9a82f52 100644
--- a/src/compiler/ppc/type-vops.lisp
+++ b/src/compiler/ppc/type-vops.lisp
@@ -13,14 +13,13 @@
 
 (defun %test-fixnum (value target not-p &key temp)
   (assemble ()
-    ;; FIXME: again, this 3 should be FIXNUM-MASK
-    (inst andi. temp value 3)
+    (inst andi. temp value fixnum-tag-mask)
     (inst b? (if not-p :ne :eq) target)))
 
 (defun %test-fixnum-and-headers (value target not-p headers &key temp)
   (let ((drop-through (gen-label)))
     (assemble ()
-      (inst andi. temp value 3)
+      (inst andi. temp value fixnum-tag-mask)
       (inst beq (if not-p drop-through target)))
     (%test-headers value target not-p nil headers
 		   :drop-through drop-through :temp temp)))
@@ -37,14 +36,6 @@
     (inst cmpwi temp lowtag)
     (inst b? (if not-p :ne :eq) target)))
 
-(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)
-    (%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)))
@@ -61,20 +52,52 @@
                 (last (null (cdr remaining))))
             (cond
               ((atom header)
-	       (inst cmpwi temp header)
-               (if last
-                   (inst b? (if not-p :ne :eq) target)
-                   (inst beq when-true)))
+	       (cond
+		 ((and (not last) (null (cddr remaining))
+		       (atom (cadr remaining))
+		       (= (logcount (logxor header (cadr remaining))) 1))
+		  (inst andi. temp temp (ldb (byte 8 0) (logeqv header (cadr remaining))))
+		  (inst cmpwi temp (ldb (byte 8 0) (logand header (cadr remaining))))
+		  (inst b? (if not-p :ne :eq) target)
+		  (return))
+		 (t
+		  (inst cmpwi temp header)
+		  (if last
+		      (inst b? (if not-p :ne :eq) target)
+		      (inst beq when-true)))))
               (t
                (let ((start (car header))
                      (end (cdr header)))
-                 (unless (= start bignum-widetag)
-                   (inst cmpwi temp start)
-                   (inst blt when-false))
-                 (inst cmpwi temp end)
-                 (if last
-                     (inst b? (if not-p :gt :le) target)
-                     (inst ble when-true)))))))
+		 (cond
+		   ((and last (not (= start bignum-widetag))
+			 (= (+ start 4) end) 
+			 (= (logcount (logxor start end)) 1))
+		    (inst andi. temp temp (ldb (byte 8 0) (logeqv start end)))
+		    (inst cmpwi 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 andi. temp temp (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+		    (inst cmpwi temp (ldb (byte 8 0) (logand start (cdadr remaining))))
+		    (inst b? (if not-p :ne :eq) target)
+		    (return))
+		   (t
+		    (unless (= start bignum-widetag)
+		      (inst cmpwi temp start)
+		      (if (= end complex-array-widetag)
+			  (progn
+			    (aver last)
+			    (inst b? (if not-p :lt :ge) target))
+			  (inst blt when-false)))
+		    (unless (= end complex-array-widetag)
+		      (inst cmpwi temp end)
+		      (if last
+			  (inst b? (if not-p :gt :le) target)
+			  (inst ble when-true))))))))))
         (emit-label drop-through)))))
 
 ;;; Simple type checking and testing:
@@ -116,13 +139,9 @@
 		 ,@(if mask
 		       `((inst andi. temp value ,mask)
 			 (inst twi 0 value (error-number-or-lose ',error-code))
-			 (inst twi :ne temp ,@(if ;; KLUDGE: At
-					          ;; present, MASK is
-					          ;; 3 or LOWTAG-MASK
-					          (eql mask 3)
-						  ;; KLUDGE
-						  `(0)
-						  type-codes))
+			 (inst twi :ne temp ,@(ecase mask
+						((fixnum-tag-mask) `(0))
+						((lowtag-mask) type-codes)))
 			 (move result value))
 		       `((let ((err-lab
 				(generate-error-code vop ,error-code value)))