0.9.1.29:

[sbcl.git] / src / code / target-sxhash.lisp

diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp
index 99e0830..35fdcdc 100644 (file)
--- a/src/code/target-sxhash.lisp
+++ b/src/code/target-sxhash.lisp
@@ -36,9 +36,10 @@
 ;;;   * We'd like this to be simple and fast, too.
 ;;;
 ;;; FIXME: Should this be INLINE?
 ;;;   * We'd like this to be simple and fast, too.
 ;;;
 ;;; FIXME: Should this be INLINE?

-(declaim (ftype (function ((and fixnum unsigned-byte)
-                          (and fixnum unsigned-byte))
-                         (and fixnum unsigned-byte)) mix))
+(declaim (ftype (sfunction ((and fixnum unsigned-byte)
+                            (and fixnum unsigned-byte))
+                           (and fixnum unsigned-byte))
+                mix))

 (defun mix (x y)
   ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
   ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
 (defun mix (x y)
   ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
   ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,

@@ -88,28 +89,20 @@
   (declare (optimize (speed 3) (safety 0)))
   (declare (type string string))
   (declare (type index count))
   (declare (optimize (speed 3) (safety 0)))
   (declare (type string string))
   (declare (type index count))

-  (let ((result 0))
-    (declare (type (unsigned-byte 32) result))    
-    (unless (typep string '(vector nil))
-      (dotimes (i count)
-       (declare (type index i))
-       (setf result
-             (ldb (byte 32 0)
-                  (+ result (char-code (aref string i)))))
-       (setf result
-             (ldb (byte 32 0)
-                  (+ result (ash result 10))))
-       (setf result
-             (logxor result (ash result -6)))))
-    (setf result
-         (ldb (byte 32 0)
-              (+ result (ash result 3))))
-    (setf result
-         (logxor result (ash result -11)))
-    (setf result
-         (ldb (byte 32 0)
-              (logxor result (ash result 15))))
-    (logand result most-positive-fixnum)))
+  (macrolet ((set-result (form)
+              `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form))))
+    (let ((result 0))
+      (declare (type (unsigned-byte #.sb!vm:n-word-bits) result))
+      (unless (typep string '(vector nil))
+       (dotimes (i count)
+         (declare (type index i))
+         (set-result (+ result (char-code (aref string i))))
+         (set-result (+ result (ash result 10)))
+         (set-result (logxor result (ash result -6)))))
+      (set-result (+ result (ash result 3)))
+      (set-result (logxor result (ash result -11)))
+      (set-result (logxor result (ash result 15)))
+      (logand result most-positive-fixnum))))

 ;;; test:
 ;;;   (let ((ht (make-hash-table :test 'equal)))
 ;;;     (do-all-symbols (symbol)
 ;;; test:
 ;;;   (let ((ht (make-hash-table :test 'equal)))
 ;;;     (do-all-symbols (symbol)

@@ -144,6 +137,12 @@
 \f
 ;;;; the SXHASH function
 
 \f
 ;;;; the SXHASH function
 

+;; simple cases
+(declaim (ftype (sfunction (integer) (integer 0 #.sb!xc:most-positive-fixnum))
+                sxhash-bignum))
+(declaim (ftype (sfunction (t) (integer 0 #.sb!xc:most-positive-fixnum))
+                sxhash-instance))
+

 (defun sxhash (x)
   ;; profiling SXHASH is hard, but we might as well try to make it go
   ;; fast, in case it is the bottleneck somwhere.  -- CSR, 2003-03-14
 (defun sxhash (x)
   ;; profiling SXHASH is hard, but we might as well try to make it go
   ;; fast, in case it is the bottleneck somwhere.  -- CSR, 2003-03-14

@@ -165,14 +164,22 @@
                          (mixf result (sxhash-number (realpart x)))
                          (mixf result (sxhash-number (imagpart x)))
                          result))))
                          (mixf result (sxhash-number (realpart x)))
                          (mixf result (sxhash-number (imagpart x)))
                          result))))

-          (sxhash-recurse (x &optional (depthoid +max-hash-depthoid+))
+          (sxhash-recurse (x depthoid)

             (declare (type index depthoid))
             (typecase x
             (declare (type index depthoid))
             (typecase x

-              (cons
-               (if (plusp depthoid)
-                   (mix (sxhash-recurse (car x) (1- depthoid))
-                        (sxhash-recurse (cdr x) (1- depthoid)))
-                   261835505))
+              ;; we test for LIST here, rather than CONS, because the
+              ;; type test for CONS is in fact the test for
+              ;; LIST-POINTER-LOWTAG followed by a negated test for
+              ;; NIL.  If we're going to have to test for NIL anyway,
+              ;; we might as well do it explicitly and pick off the
+              ;; answer.  -- CSR, 2004-07-14
+              (list
+               (if (null x)
+                   (sxhash x) ; through DEFTRANSFORM
+                   (if (plusp depthoid)
+                       (mix (sxhash-recurse (car x) (1- depthoid))
+                            (sxhash-recurse (cdr x) (1- depthoid)))
+                       261835505)))

               (instance
                (if (or (typep x 'structure-object) (typep x 'condition))
                    (logxor 422371266
               (instance
                (if (or (typep x 'structure-object) (typep x 'condition))
                    (logxor 422371266

@@ -202,7 +209,7 @@
               (number (sxhash-number x))
               (generic-function (sxhash-instance x))
               (t 42))))
               (number (sxhash-number x))
               (generic-function (sxhash-instance x))
               (t 42))))

-    (sxhash-recurse x)))
+    (sxhash-recurse x +max-hash-depthoid+)))

 \f
 ;;;; the PSXHASH function
 
 \f
 ;;;; the PSXHASH function