0.7.13.30:

	Install faster EQUAL on simple-bit-vectors
	... word-at-a-time, not bit-at-a-time
	Frobs for correctness
	... much like one that was solved for 0.7.3.5, we must be
		careful about identifying the last word of the bit vector,
		particularly for bit-vectors whose length is divisible by
        	32^Wn-word-bits.  Less critical in this case, but we could
		still be reading into random space, even if not writing.
	Frobs for yet more speed
	... allow CMUCL to optimize ASH, as long as none of the values
		are in the danger zone.  Also reported the bug to CMUCL
		people, and it is now fixed, so when all traces of 18d
		are removed from this earth, the conditional in
		ASH-DERIVE-TYPE-AUX can go too.

NEWS

@@ -1584,9 +1584,10 @@ changes in sbcl-0.7.13 relative to sbcl-0.7.12:
     DEFSTRUCT-SLOT-DESCRIPTION structure.
 
 changes in sbcl-0.7.14 relative to sbcl-0.7.13:
-  * a better implementation of SXHASH on bit vectors, measured both in
-    execution speed and in distribution of results over the positive
-    fixnums, has been installed.
+  * a better implementation of SXHASH on (simple) bit vectors,
+    measured both in execution speed and in distribution of results
+    over the positive fixnums, has been installed.  Likewise, a better
+    implementation of EQUAL for simple bit vectors is now available.
   * fixed CEILING optimization for a divisor of form 2^k.
   * fixed bug 240 (emitting extra style warnings "using the lexical
     binding of the symbol *XXX*" for &OPTIONAL arguments).  (reported

package-data-list.lisp-expr

@@ -745,6 +745,7 @@ retained, possibly temporariliy, because it might be used internally."
              "%BREAK"
 	     "NTH-BUT-WITH-SANE-ARG-ORDER"
 	     "DEPRECATION-WARNING"
+	     "BIT-VECTOR-="
 
              ;; ..and macros..
              "COLLECT"

src/code/pred.lisp

@@ -135,6 +135,19 @@
   "Return T if OBJ1 and OBJ2 are the same object, otherwise NIL."
   (eq obj1 obj2))
 
+(defun bit-vector-= (x y)
+  (declare (type bit-vector x y))
+  (if (and (simple-bit-vector-p x)
+	   (simple-bit-vector-p y))
+      (bit-vector-= x y) ; DEFTRANSFORM
+      (and (= (length x) (length y))
+	   (do ((i 0 (1+ i))
+		(length (length x)))
+	       ((= i length) t)
+	     (declare (fixnum i))
+	     (unless (= (bit x i) (bit y i))
+	       (return nil))))))
+
 (defun equal (x y)
   #!+sb-doc
   "Return T if X and Y are EQL or if they are structured components
@@ -152,15 +165,7 @@
 	 (and (pathnamep y) (pathname= x y)))
 	((bit-vector-p x)
 	 (and (bit-vector-p y)
-	      (= (the fixnum (length x))
-		 (the fixnum (length y)))
-	      (do ((i 0 (1+ i))
-		   (length (length x)))
-		  ((= i length) t)
-		(declare (fixnum i))
-		(or (= (the fixnum (bit x i))
-		       (the fixnum (bit y i)))
-		    (return nil)))))
+	      (bit-vector-= x y)))
 	(t nil)))
 
 ;;; EQUALP comparison of HASH-TABLE values

src/code/sxhash.lisp

@@ -47,34 +47,46 @@
 (deftransform sxhash ((x) (simple-bit-vector))
   `(let ((result 410823708))
     (declare (type fixnum result))
-    (mixf result (sxhash (length x)))
-    (do* ((i sb!vm:vector-data-offset (+ i 1))
-	  ;; FIXME: should we respect DEPTHOID?  SXHASH on strings
-	  ;; doesn't seem to...
-	  (end (+ sb!vm:vector-data-offset
-		  (ceiling (length x) sb!vm:n-word-bits))))
-	 ((= i end) result)
-      (declare (type index i end))
-      (let ((num
-	     (if (= i (1- end))
-		 (logand
-		  (ash (1- (ash 1 (mod (length x) sb!vm:n-word-bits)))
-		       ,(ecase sb!c:*backend-byte-order*
-			  (:little-endian 0)
-			  (:big-endian
-			   '(- sb!vm:n-word-bits
-			       (mod (length x) sb!vm:n-word-bits)))))
-		  (%raw-bits x i))
-		 (%raw-bits x i))))
-	(declare (type (unsigned-byte 32) num))
-	(mixf result ,(ecase sb!c:*backend-byte-order*
-			(:little-endian '(logand num most-positive-fixnum))
-			;; FIXME: I'm not certain that N-LOWTAG-BITS
-			;; is the clearest way of expressing this:
-			;; it's essentially the difference between
-			;; `(UNSIGNED-BYTE ,SB!VM:N-WORD-BITS) and
-			;; (AND FIXNUM UNSIGNED-BYTE).
-			(:big-endian '(ash num (- sb!vm:n-lowtag-bits)))))))))
+    (let ((length (length x)))
+      (cond
+	((= length 0) (mix result (sxhash 0)))
+	(t
+	 (mixf result (sxhash (length x)))
+	 (do* ((i sb!vm:vector-data-offset (+ i 1))
+	       ;; FIXME: should we respect DEPTHOID?  SXHASH on
+	       ;; strings doesn't seem to...
+	       (end-1 (+ sb!vm:vector-data-offset
+			 (floor (1- length) sb!vm:n-word-bits))))
+	      ((= i end-1)
+	       (let ((num
+		      (logand
+		       (ash (1- (ash 1 (mod length sb!vm:n-word-bits)))
+			    ,(ecase sb!c:*backend-byte-order*
+			       (:little-endian 0)
+			       (:big-endian
+				'(- sb!vm:n-word-bits
+				    (mod length sb!vm:n-word-bits)))))
+		       (%raw-bits x i))))
+		 (declare (type (unsigned-byte 32) num))
+		 (mix result ,(ecase sb!c:*backend-byte-order*
+				(:little-endian
+				 '(logand num most-positive-fixnum))
+				(:big-endian
+				 '(ash num (- sb!vm:n-lowtag-bits)))))))
+	   (declare (type index i end-1))
+	   (let ((num (%raw-bits x i)))
+	     (declare (type (unsigned-byte 32) num))
+	     (mixf result ,(ecase sb!c:*backend-byte-order*
+			     (:little-endian
+			      '(logand num most-positive-fixnum))
+			     ;; FIXME: I'm not certain that
+			     ;; N-LOWTAG-BITS is the clearest way of
+			     ;; expressing this: it's essentially the
+			     ;; difference between `(UNSIGNED-BYTE
+			     ;; ,SB!VM:N-WORD-BITS) and (AND FIXNUM
+			     ;; UNSIGNED-BYTE).
+			     (:big-endian
+			      '(ash num (- sb!vm:n-lowtag-bits))))))))))))
 
 ;;; Some other common SXHASH cases are defined as DEFTRANSFORMs in
 ;;; order to avoid having to do TYPECASE at runtime.

src/compiler/fndb.lisp

@@ -829,6 +829,9 @@
   (foldable)
   #|:derive-type #'result-type-last-arg|#)
 
+(defknown bit-vector-= (bit-vector bit-vector) boolean
+  (movable foldable flushable))
+
 (defknown array-has-fill-pointer-p (array) boolean
   (movable foldable flushable))
 (defknown fill-pointer (vector) index (foldable unsafely-flushable))

src/compiler/generic/vm-tran.lisp

@@ -264,6 +264,42 @@
 		     (type index index end-1))
 	    (setf (%raw-bits result-bit-array index)
 		  (32bit-logical-not (%raw-bits bit-array index))))))))
+
+(deftransform bit-vector-= ((x y) (simple-bit-vector simple-bit-vector))
+  `(and (= (length x) (length y))
+        (let ((length (length x)))
+	  (or (= length 0)
+	      (do* ((i sb!vm:vector-data-offset (+ i 1))
+		    (end-1 (+ sb!vm:vector-data-offset
+			      (floor (1- length) sb!vm:n-word-bits))))
+		   ((= i end-1)
+		    (let* ((extra (mod length sb!vm:n-word-bits))
+			   (mask (1- (ash 1 extra)))
+			   (numx
+			    (logand
+			     (ash mask
+				  ,(ecase sb!c:*backend-byte-order*
+				     (:little-endian 0)
+				     (:big-endian
+				      '(- sb!vm:n-word-bits extra))))
+			     (%raw-bits x i)))
+			   (numy
+			    (logand
+			     (ash mask
+				  ,(ecase sb!c:*backend-byte-order*
+				     (:little-endian 0)
+				     (:big-endian
+				      '(- sb!vm:n-word-bits extra))))
+			     (%raw-bits y i))))
+		      (declare (type (integer 0 31) extra)
+			       (type (unsigned-byte 32) mask numx numy))
+		      (= numx numy)))
+		(declare (type index i end-1))
+		(let ((numx (%raw-bits x i))
+		      (numy (%raw-bits y i)))
+		  (declare (type (unsigned-byte 32) numx numy))
+		  (unless (= numx numy)
+		    (return nil))))))))
 
 ;;;; %BYTE-BLT
 

src/compiler/srctran.lisp

@@ -1347,16 +1347,19 @@
 
 ) ; PROGN
 
-
-;;; KLUDGE: All this ASH optimization is suppressed under CMU CL
-;;; because as of version 2.4.6 for Debian, CMU CL blows up on (ASH
-;;; 1000000000 -100000000000) (i.e. ASH of two bignums yielding zero)
-;;; and it's hard to avoid that calculation in here.
-#-(and cmu sb-xc-host)
-(progn
-
 (defun ash-derive-type-aux (n-type shift same-arg)
   (declare (ignore same-arg))
+  ;; KLUDGE: All this ASH optimization is suppressed under CMU CL for
+  ;; some bignum cases because as of version 2.4.6 for Debian and 18d,
+  ;; CMU CL blows up on (ASH 1000000000 -100000000000) (i.e. ASH of
+  ;; two bignums yielding zero) and it's hard to avoid that
+  ;; calculation in here.
+  #+(and cmu sb-xc-host)
+  (when (and (or (typep (numeric-type-low n-type) 'bignum)
+		 (typep (numeric-type-high n-type) 'bignum))
+	     (or (typep (numeric-type-low shift) 'bignum)
+		 (typep (numeric-type-high shift) 'bignum)))
+    (return-from ash-derive-type-aux *universal-type*))
   (flet ((ash-outer (n s)
 	   (when (and (fixnump s)
 		      (<= s 64)
@@ -1389,7 +1392,6 @@
 
 (defoptimizer (ash derive-type) ((n shift))
   (two-arg-derive-type n shift #'ash-derive-type-aux #'ash))
-) ; PROGN
 
 #+sb-xc-host ; (See CROSS-FLOAT-INFINITY-KLUDGE.)
 (macrolet ((frob (fun)

version.lisp-expr

@@ -18,4 +18,4 @@
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
 
-"0.7.13.29"
+"0.7.13.30"