X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fcompiler%2Fx86%2Ftype-vops.lisp;h=7335973ffa5f8afff5000b98b42090ee6c9e3b1e;hb=7646aefa188758e2892fea2ad02be4f29b3938f2;hp=36f49a60123126233e9e0536bd3c9ee70a6b6e3d;hpb=faa0ea92986f4c2b361c9378c69a540e42a70c62;p=sbcl.git

diff --git a/src/compiler/x86/type-vops.lisp b/src/compiler/x86/type-vops.lisp
index 36f49a6..7335973 100644
--- a/src/compiler/x86/type-vops.lisp
+++ b/src/compiler/x86/type-vops.lisp
@@ -64,23 +64,18 @@
     (inst and al-tn lowtag-mask))
   (inst cmp al-tn lowtag)
   (inst jmp (if not-p :ne :e) target))
-
-(defun %test-lowtag-and-headers (value target not-p lowtag function-p headers)
-  (let ((drop-through (gen-label)))
-    (%test-lowtag value (if not-p drop-through target) nil lowtag)
-    (%test-headers value target not-p function-p headers drop-through t)))
-
-
+  
 (defun %test-headers (value target not-p function-p headers
 			    &optional (drop-through (gen-label)) al-loaded)
   (let ((lowtag (if function-p fun-pointer-lowtag other-pointer-lowtag)))
-    (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.
+    (multiple-value-bind (equal less-or-equal greater-or-equal when-true when-false)
+	;; EQUAL, LESS-OR-EQUAL and GREATER-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))
+	    (values :ne :a :b drop-through target)
+	    (values :e :na :nb target drop-through))
       (%test-lowtag value when-false t lowtag al-loaded)
       (inst mov al-tn (make-ea :byte :base value :disp (- lowtag)))
       (do ((remaining headers (cdr remaining)))
@@ -89,22 +84,59 @@
 	      (last (null (cdr remaining))))
 	  (cond
 	   ((atom header)
-	    (inst cmp al-tn header)
-	    (if last
-		(inst jmp equal target)
-		(inst jmp :e when-true)))
+	    (cond
+	      ((and (not last) (null (cddr remaining))
+		    (atom (cadr remaining))
+		    (= (logcount (logxor header (cadr remaining))) 1))
+	       ;; BASE-STRING, (VECTOR NIL), BIT-VECTOR, (VECTOR T)
+	       (inst and al-tn (ldb (byte 8 0) (logeqv header (cadr remaining))))
+	       (inst cmp al-tn (ldb (byte 8 0) (logand header (cadr remaining))))
+	       (inst jmp equal target)
+	       (return))
+	      (t
+	       (inst cmp al-tn header)
+	       (if last
+		   (inst jmp equal target)
+		   (inst jmp :e when-true)))))
 	   (t
 	     (let ((start (car header))
 		   (end (cdr header)))
-	       (unless (= start bignum-widetag)
-		 (inst cmp al-tn start)
-		 (inst jmp :b when-false)) ; was :l
-	       (inst cmp al-tn end)
-	       (if last
-		   (inst jmp less-or-equal target)
-		   (inst jmp :be when-true))))))) ; was :le
+	       (cond
+		 ;; LAST = don't need al-tn later
+		 ((and last (not (= start bignum-widetag))
+		       (= (+ start 4) end) (= (logcount (logxor start end)) 1))
+		  ;; SIMPLE-STRING
+		  (inst and al-tn (ldb (byte 8 0) (logeqv start end)))
+		  (inst cmp al-tn (ldb (byte 8 0) (logand start end)))
+		  (inst jmp equal 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))
+		  ;; STRING
+		  (inst and al-tn (ldb (byte 8 0) (logeqv start (cdadr remaining))))
+		  (inst cmp al-tn (ldb (byte 8 0) (logand start (cdadr remaining))))
+		  (inst jmp equal target)
+		  ;; we've shortcircuited the DO, so we must return.
+		  ;; It's OK to do so, because (NULL (CDDR REMAINING))
+		  ;; was true.
+		  (return))
+		 (t
+		  (unless (= start bignum-widetag)
+		    (inst cmp al-tn start)
+		    (if (= end complex-array-widetag)
+			(progn
+			  (aver last)
+			  (inst jmp greater-or-equal target))
+			(inst jmp :b when-false))) ; was :l
+		  (unless (= end complex-array-widetag)
+		    (inst cmp al-tn end)
+		    (if last
+			(inst jmp less-or-equal target)
+			(inst jmp :be when-true)))))))))) ; was :le
       (emit-label drop-through))))
-
 
 ;;;; type checking and testing
 
@@ -145,7 +177,7 @@
 
 (defmacro !define-type-vops (pred-name check-name ptype error-code
 			     (&rest type-codes)
-			     &key (variant nil variant-p))
+			     &key (variant nil variant-p) &allow-other-keys)
   ;; KLUDGE: UGH. Why do we need this eval? Can't we put this in the
   ;; expansion?
   (let* ((cost (cost-to-test-types (mapcar #'eval type-codes)))
@@ -170,6 +202,14 @@
 
 ;;;; other integer ranges
 
+(define-vop (fixnump/unsigned-byte-32 simple-type-predicate)
+  (:args (value :scs (unsigned-reg)))
+  (:arg-types unsigned-num)
+  (:translate fixnump)
+  (:generator 5
+    (inst cmp value #.sb!xc:most-positive-fixnum)
+    (inst jmp (if not-p :a :be) target)))
+
 ;;; A (SIGNED-BYTE 32) can be represented with either fixnum or a bignum with
 ;;; exactly one digit.