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
"%BREAK"
"NTH-BUT-WITH-SANE-ARG-ORDER"
"DEPRECATION-WARNING"
+ "BIT-VECTOR-="
;; ..and macros..
"COLLECT"
"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
(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
(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.
(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))
(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))))))))
\f
;;;; %BYTE-BLT
) ; 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)
(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)
;;; 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"
projects / sbcl.git / commitdiff