From 9109df608080457c2fb2437c7eb5b9af23fe6cf2 Mon Sep 17 00:00:00 2001
From: Juho Snellman <jsnell@iki.fi>
Date: Sat, 14 Apr 2007 12:28:15 +0000
Subject: [PATCH] 1.0.4.87: better EQUALP hash function for arrays

        * Hashing on just the first 4 elements makes EQUALP tables essentially
          useless for many kinds of data due to collisions. Hash all the
          elements.
        * Optimize a couple of other cases that are probably common
          (u-b 8 vectors, fixnum vectors).
        * Change EQUALP-HASH to punt to EQ-HASH when appropriate
---
 src/code/sxhash.lisp            |  6 ++++++
 src/code/target-hash-table.lisp |  8 +++++++-
 src/code/target-sxhash.lisp     | 33 +++++++++++++++++----------------
 src/compiler/fndb.lisp          |  2 ++
 version.lisp-expr               |  2 +-
 5 files changed, 33 insertions(+), 18 deletions(-)

diff --git a/src/code/sxhash.lisp b/src/code/sxhash.lisp
index 53431b29c..dde2e15f1 100644
--- a/src/code/sxhash.lisp
+++ b/src/code/sxhash.lisp
@@ -129,3 +129,9 @@
                   (%set-symbol-hash x sxhash)
                   sxhash)
                 result)))))
+
+(deftransform psxhash ((x &optional depthoid) (character &optional t))
+  `(char-code (char-upcase x)))
+
+(deftransform psxhash ((x &optional depthoid) (integer &optional t))
+  `(sxhash x))
diff --git a/src/code/target-hash-table.lisp b/src/code/target-hash-table.lisp
index d6c756031..c25c73081 100644
--- a/src/code/target-hash-table.lisp
+++ b/src/code/target-hash-table.lisp
@@ -84,7 +84,13 @@
 
 (defun equalp-hash (key)
   (declare (values hash (member t nil)))
-  (values (psxhash key) nil))
+  (typecase key
+    ;; Types requiring special treatment. Note that PATHNAME and
+    ;; HASH-TABLE are caught by the STRUCTURE-OBJECT test.
+    ((or array cons number character structure-object)
+     (values (psxhash key) nil))
+    (t
+     (eq-hash key))))
 
 (defun almost-primify (num)
   (declare (type index num))
diff --git a/src/code/target-sxhash.lisp b/src/code/target-sxhash.lisp
index a58beb2e5..5ddbd212d 100644
--- a/src/code/target-sxhash.lisp
+++ b/src/code/target-sxhash.lisp
@@ -40,6 +40,7 @@
                             (and fixnum unsigned-byte))
                            (and fixnum unsigned-byte))
                 mix))
+(declaim (inline 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,
@@ -234,7 +235,7 @@
     (structure-object (structure-object-psxhash key depthoid))
     (cons (list-psxhash key depthoid))
     (number (number-psxhash key))
-    (character (sxhash (char-upcase key)))
+    (character (char-code (char-upcase key)))
     (t (sxhash key))))
 
 (defun array-psxhash (key depthoid)
@@ -249,31 +250,31 @@
                   '(let ((result 572539))
                      (declare (type fixnum result))
                      (mixf result (length key))
-                     (dotimes (i (min depthoid (length key)))
+                     (dotimes (i (length key))
                        (declare (type fixnum i))
                        (mixf result
                              (psxhash (aref key i)
                                       (- depthoid 1 i))))
-                     result)))
-       ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently
-       ;; than the general case that it's probably worth picking off the
-       ;; common special cases.
-       (typecase key
-         (simple-string
-          ;;(format t "~&SIMPLE-STRING special case~%")
-          (frob))
-         (simple-vector
-          ;;(format t "~&SIMPLE-VECTOR special case~%")
-          (frob))
-         (t (frob)))))
+                     result))
+                (make-dispatch (types)
+                  `(typecase key
+                     ,@(loop for type in types
+                             collect `(,type
+                                       (frob))))))
+       (make-dispatch (simple-base-string
+                       (simple-array character (*))
+                       simple-vector
+                       (simple-array (unsigned-byte 8) (*))
+                       (simple-array fixnum (*))
+                       t))))
     ;; Any other array can be hashed by working with its underlying
     ;; one-dimensional physical representation.
     (t
      (let ((result 60828))
        (declare (type fixnum result))
-       (dotimes (i (min depthoid (array-rank key)))
+       (dotimes (i (array-rank key))
          (mixf result (array-dimension key i)))
-       (dotimes (i (min depthoid (array-total-size key)))
+       (dotimes (i (array-total-size key))
          (mixf result
                (psxhash (row-major-aref key i)
                         (- depthoid 1 i))))
diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp
index dd908262c..609eb1001 100644
--- a/src/compiler/fndb.lisp
+++ b/src/compiler/fndb.lisp
@@ -809,6 +809,8 @@
 (defknown hash-table-test (hash-table) symbol (foldable flushable))
 (defknown sxhash (t) (integer 0 #.sb!xc:most-positive-fixnum)
   (#-sb-xc-host foldable flushable))
+(defknown psxhash (t &optional t) (integer 0 #.sb!xc:most-positive-fixnum)
+  (#-sb-xc-host foldable flushable))
 
 ;;;; from the "Arrays" chapter
 
diff --git a/version.lisp-expr b/version.lisp-expr
index 3106642e6..bc899fd9f 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.4.86"
+"1.0.4.87"
-- 
2.11.4.GIT