1.0.4.76: add a new style-warning for duplicate CASE keys
[sbcl.git] / src / code / target-sxhash.lisp
1 ;;;; hashing functions
2
3 ;;;; This software is part of the SBCL system. See the README file for
4 ;;;; more information.
5 ;;;;
6 ;;;; This software is derived from the CMU CL system, which was
7 ;;;; written at Carnegie Mellon University and released into the
8 ;;;; public domain. The software is in the public domain and is
9 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
10 ;;;; files for more information.
11
12 (in-package "SB!IMPL")
13
14 ;;; the depthoid explored when calculating hash values
15 ;;;
16 ;;; "Depthoid" here is a sort of mixture of what Common Lisp ordinarily calls
17 ;;; depth and what Common Lisp ordinarily calls length; it's incremented either
18 ;;; when we descend into a compound object or when we step through elements of
19 ;;; a compound object.
20 (defconstant +max-hash-depthoid+ 4)
21 \f
22 ;;;; mixing hash values
23
24 ;;; a function for mixing hash values
25 ;;;
26 ;;; desiderata:
27 ;;;   * Non-commutativity keeps us from hashing e.g. #(1 5) to the
28 ;;;     same value as #(5 1), and ending up in real trouble in some
29 ;;;     special cases like bit vectors the way that CMUCL 18b SXHASH
30 ;;;     does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
31 ;;;   * We'd like to scatter our hash values over the entire possible range
32 ;;;     of values instead of hashing small or common key values (like
33 ;;;     2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
34 ;;;     SXHASH function does, again helping to avoid pathologies like
35 ;;;     hashing all bit vectors to 1.
36 ;;;   * We'd like this to be simple and fast, too.
37 ;;;
38 ;;; FIXME: Should this be INLINE?
39 (declaim (ftype (sfunction ((and fixnum unsigned-byte)
40                             (and fixnum unsigned-byte))
41                            (and fixnum unsigned-byte))
42                 mix))
43 (defun mix (x y)
44   ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
45   ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
46   ;; and the (SAFETY 0) declaration here to get the compiler to trust
47   ;; it, the sbcl-0.5.0m cross-compiler running under Debian
48   ;; cmucl-2.4.17 turns the ASH into a full call, requiring the
49   ;; UNSIGNED-BYTE 32 argument to be coerced to a bignum, requiring
50   ;; consing, and thus generally obliterating performance.)
51   (declare (optimize (speed 3) (safety 0)))
52   (declare (type (and fixnum unsigned-byte) x y))
53   ;; the ideas here:
54   ;;   * Bits diffuse in both directions (shifted left by up to 2 places
55   ;;     in the calculation of XY, and shifted right by up to 5 places
56   ;;     by the ASH).
57   ;;   * The #'+ and #'LOGXOR operations don't commute with each other,
58   ;;     so different bit patterns are mixed together as they shift
59   ;;     past each other.
60   ;;   * The arbitrary constant in the #'LOGXOR expression is intended
61   ;;     to help break up any weird anomalies we might otherwise get
62   ;;     when hashing highly regular patterns.
63   ;; (These are vaguely like the ideas used in many cryptographic
64   ;; algorithms, but we're not pushing them hard enough here for them
65   ;; to be cryptographically strong.)
66   (let* ((xy (+ (* x 3) y)))
67     (logand most-positive-fixnum
68             (logxor 441516657
69                     xy
70                     (ash xy -5)))))
71 \f
72 ;;;; hashing strings
73 ;;;;
74 ;;;; Note that this operation is used in compiler symbol table
75 ;;;; lookups, so we'd like it to be fast.
76 ;;;;
77 ;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
78 ;;;; designed by Bob Jenkins (see
79 ;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
80 ;;;; information).
81
82 #!-sb-fluid (declaim (inline %sxhash-substring))
83 (defun %sxhash-substring (string &optional (count (length string)))
84   ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
85   ;; cross-compiler were smarter about ASH, but we need it for
86   ;; sbcl-0.5.0m.  (probably no longer true?  We might need SAFETY 0
87   ;; to elide some type checks, but then again if this is inlined in
88   ;; all the critical places, we might not -- CSR, 2004-03-10)
89   (declare (optimize (speed 3) (safety 0)))
90   (declare (type string string))
91   (declare (type index count))
92   (macrolet ((set-result (form)
93                `(setf result (ldb (byte #.sb!vm:n-word-bits 0) ,form))))
94     (let ((result 0))
95       (declare (type (unsigned-byte #.sb!vm:n-word-bits) result))
96       (unless (typep string '(vector nil))
97         (dotimes (i count)
98           (declare (type index i))
99           (set-result (+ result (char-code (aref string i))))
100           (set-result (+ result (ash result 10)))
101           (set-result (logxor result (ash result -6)))))
102       (set-result (+ result (ash result 3)))
103       (set-result (logxor result (ash result -11)))
104       (set-result (logxor result (ash result 15)))
105       (logand result most-positive-fixnum))))
106 ;;; test:
107 ;;;   (let ((ht (make-hash-table :test 'equal)))
108 ;;;     (do-all-symbols (symbol)
109 ;;;       (let* ((string (symbol-name symbol))
110 ;;;           (hash (%sxhash-substring string)))
111 ;;;      (if (gethash hash ht)
112 ;;;          (unless (string= (gethash hash ht) string)
113 ;;;            (format t "collision: ~S ~S~%" string (gethash hash ht)))
114 ;;;          (setf (gethash hash ht) string))))
115 ;;;     (format t "final count=~W~%" (hash-table-count ht)))
116
117 (defun %sxhash-simple-string (x)
118   (declare (optimize speed))
119   (declare (type simple-string x))
120   ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence
121   ;; of let conversion in the cross compiler, which otherwise causes
122   ;; strongly suboptimal register allocation.
123   (flet ((trick (x)
124            (%sxhash-substring x)))
125     (declare (notinline trick))
126     (trick x)))
127
128 (defun %sxhash-simple-substring (x count)
129   (declare (optimize speed))
130   (declare (type simple-string x))
131   (declare (type index count))
132   ;; see comment in %SXHASH-SIMPLE-STRING
133   (flet ((trick (x count)
134            (%sxhash-substring x count)))
135     (declare (notinline trick))
136     (trick x count)))
137 \f
138 ;;;; the SXHASH function
139
140 ;; simple cases
141 (declaim (ftype (sfunction (integer) (integer 0 #.sb!xc:most-positive-fixnum))
142                 sxhash-bignum))
143 (declaim (ftype (sfunction (t) (integer 0 #.sb!xc:most-positive-fixnum))
144                 sxhash-instance))
145
146 (defmacro hash-array-using (recurse array depthoid)
147   ;; Any other array can be hashed by working with its underlying
148   ;; one-dimensional physical representation. Used by both SXHASH and
149   ;; PSXHASH.
150   (once-only ((array array) (depthoid depthoid))
151     `(let ((result 60828123))
152        (declare (type fixnum result))
153        (dotimes (i (min ,depthoid (array-rank ,array)))
154          (mixf result (array-dimension ,array i)))
155        (dotimes (i (min ,depthoid (array-total-size ,array)))
156          (mixf result
157                (,recurse (row-major-aref ,array i) (- ,depthoid 1 i))))
158        result)))
159
160 (defun sxhash (x)
161   ;; profiling SXHASH is hard, but we might as well try to make it go
162   ;; fast, in case it is the bottleneck somewhere.  -- CSR, 2003-03-14
163   (declare (optimize speed))
164   (labels ((sxhash-number (x)
165              (etypecase x
166                (fixnum (sxhash x))      ; through DEFTRANSFORM
167                (integer (sb!bignum:sxhash-bignum x))
168                (single-float (sxhash x)) ; through DEFTRANSFORM
169                (double-float (sxhash x)) ; through DEFTRANSFORM
170                #!+long-float (long-float (error "stub: no LONG-FLOAT"))
171                (ratio (let ((result 127810327))
172                         (declare (type fixnum result))
173                         (mixf result (sxhash-number (numerator x)))
174                         (mixf result (sxhash-number (denominator x)))
175                         result))
176                (complex (let ((result 535698211))
177                           (declare (type fixnum result))
178                           (mixf result (sxhash-number (realpart x)))
179                           (mixf result (sxhash-number (imagpart x)))
180                           result))))
181            (sxhash-recurse (x depthoid)
182              (declare (type index depthoid))
183              (typecase x
184                ;; we test for LIST here, rather than CONS, because the
185                ;; type test for CONS is in fact the test for
186                ;; LIST-POINTER-LOWTAG followed by a negated test for
187                ;; NIL.  If we're going to have to test for NIL anyway,
188                ;; we might as well do it explicitly and pick off the
189                ;; answer.  -- CSR, 2004-07-14
190                (list
191                 (if (null x)
192                     (sxhash x) ; through DEFTRANSFORM
193                     (if (plusp depthoid)
194                         (mix (sxhash-recurse (car x) (1- depthoid))
195                              (sxhash-recurse (cdr x) (1- depthoid)))
196                         261835505)))
197                (instance
198                 (if (or (typep x 'structure-object) (typep x 'condition))
199                     (logxor 422371266
200                             (sxhash ; through DEFTRANSFORM
201                              (classoid-name
202                               (layout-classoid (%instance-layout x)))))
203                     (sxhash-instance x)))
204                (symbol (sxhash x)) ; through DEFTRANSFORM
205                (array
206                 (typecase x
207                   (simple-string (sxhash x)) ; through DEFTRANSFORM
208                   (string (%sxhash-substring x))
209                   (simple-bit-vector (sxhash x)) ; through DEFTRANSFORM
210                   (bit-vector
211                    ;; FIXME: It must surely be possible to do better
212                    ;; than this.  The problem is that a non-SIMPLE
213                    ;; BIT-VECTOR could be displaced to another, with a
214                    ;; non-zero offset -- so that significantly more
215                    ;; work needs to be done using the %RAW-BITS
216                    ;; approach.  This will probably do for now.
217                    (sxhash-recurse (copy-seq x) depthoid))
218                   (t
219                    (hash-array-using sxhash-recurse x depthoid))))
220                (character
221                 (logxor 72185131
222                         (sxhash (char-code x)))) ; through DEFTRANSFORM
223                ;; general, inefficient case of NUMBER
224                (number (sxhash-number x))
225                (generic-function (sxhash-instance x))
226                (t 42))))
227     (sxhash-recurse x +max-hash-depthoid+)))
228 \f
229 ;;;; the PSXHASH function
230
231 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
232 ;;;; more efficient (in both time and space) by rewriting it along the lines
233 ;;;; of the SXHASH code above.
234
235 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
236 (defun psxhash (key &optional (depthoid +max-hash-depthoid+))
237   (declare (optimize speed))
238   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
239   ;; Note: You might think it would be cleaner to use the ordering given in the
240   ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
241   ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
242   ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
243   ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
244   ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
245   ;; comparison behavior.
246   (typecase key
247     (array (array-psxhash key depthoid))
248     (hash-table (hash-table-psxhash key))
249     (structure-object (structure-object-psxhash key depthoid))
250     (cons (list-psxhash key depthoid))
251     (number (number-psxhash key))
252     (character (sxhash (char-upcase key)))
253     (t (sxhash key))))
254
255 (defun array-psxhash (key depthoid)
256   (declare (optimize speed))
257   (declare (type array key))
258   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
259   (typecase key
260     ;; VECTORs have to be treated specially because ANSI specifies
261     ;; that we must respect fill pointers.
262     (vector
263      (macrolet ((frob ()
264                   '(let ((result 572539))
265                      (declare (type fixnum result))
266                      (mixf result (length key))
267                      (dotimes (i (min depthoid (length key)))
268                        (declare (type fixnum i))
269                        (mixf result
270                              (psxhash (aref key i)
271                                       (- depthoid 1 i))))
272                      result)))
273        ;; CMU can compile SIMPLE-ARRAY operations so much more efficiently
274        ;; than the general case that it's probably worth picking off the
275        ;; common special cases.
276        (typecase key
277          (simple-string
278           ;;(format t "~&SIMPLE-STRING special case~%")
279           (frob))
280          (simple-vector
281           ;;(format t "~&SIMPLE-VECTOR special case~%")
282           (frob))
283          (t (frob)))))
284     (t
285      (hash-array-using psxhash key depthoid))))
286
287 (defun structure-object-psxhash (key depthoid)
288   (declare (optimize speed))
289   (declare (type structure-object key))
290   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
291   (let* ((layout (%instance-layout key)) ; i.e. slot #0
292          (length (layout-length layout))
293          (classoid (layout-classoid layout))
294          (name (classoid-name classoid))
295          (result (mix (sxhash name) (the fixnum 79867))))
296     (declare (type fixnum result))
297     (dotimes (i (min depthoid (- length 1 (layout-n-untagged-slots layout))))
298       (declare (type fixnum i))
299       (let ((j (1+ i))) ; skipping slot #0, which is for LAYOUT
300         (declare (type fixnum j))
301         (mixf result
302               (psxhash (%instance-ref key j)
303                        (1- depthoid)))))
304     ;; KLUDGE: Should hash untagged slots, too.  (Although +max-hash-depthoid+
305     ;; is pretty low currently, so they might not make it into the hash
306     ;; value anyway.)
307     result))
308
309 (defun list-psxhash (key depthoid)
310   (declare (optimize speed))
311   (declare (type list key))
312   (declare (type (integer 0 #.+max-hash-depthoid+) depthoid))
313   (cond ((null key)
314          (the fixnum 480929))
315         ((zerop depthoid)
316          (the fixnum 779578))
317         (t
318          (mix (psxhash (car key) (1- depthoid))
319               (psxhash (cdr key) (1- depthoid))))))
320
321 (defun hash-table-psxhash (key)
322   (declare (optimize speed))
323   (declare (type hash-table key))
324   (let ((result 103924836))
325     (declare (type fixnum result))
326     (mixf result (hash-table-count key))
327     (mixf result (sxhash (hash-table-test key)))
328     result))
329
330 (defun number-psxhash (key)
331   (declare (optimize speed))
332   (declare (type number key))
333   (flet ((sxhash-double-float (val)
334            (declare (type double-float val))
335            ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
336            ;; resulting code works without consing. (In Debian cmucl 2.4.17,
337            ;; it didn't.)
338            (sxhash val)))
339     (etypecase key
340       (integer (sxhash key))
341       (float (macrolet ((frob (type)
342                           (let ((lo (coerce most-negative-fixnum type))
343                                 (hi (coerce most-positive-fixnum type)))
344                             `(cond (;; This clause allows FIXNUM-sized integer
345                                     ;; values to be handled without consing.
346                                     (<= ,lo key ,hi)
347                                     (multiple-value-bind (q r)
348                                         (floor (the (,type ,lo ,hi) key))
349                                       (if (zerop (the ,type r))
350                                           (sxhash q)
351                                           (sxhash-double-float
352                                            (coerce key 'double-float)))))
353                                    (t
354                                     (multiple-value-bind (q r) (floor key)
355                                       (if (zerop (the ,type r))
356                                           (sxhash q)
357                                           (sxhash-double-float
358                                            (coerce key 'double-float)))))))))
359                (etypecase key
360                  (single-float (frob single-float))
361                  (double-float (frob double-float))
362                  #!+long-float
363                  (long-float (error "LONG-FLOAT not currently supported")))))
364       (rational (if (and (<= most-negative-double-float
365                              key
366                              most-positive-double-float)
367                          (= (coerce key 'double-float) key))
368                     (sxhash-double-float (coerce key 'double-float))
369                     (sxhash key)))
370       (complex (if (zerop (imagpart key))
371                    (number-psxhash (realpart key))
372                    (let ((result 330231))
373                      (declare (type fixnum result))
374                      (mixf result (number-psxhash (realpart key)))
375                      (mixf result (number-psxhash (imagpart key)))
376                      result))))))