3 ;;;; This software is part of the SBCL system. See the README file for
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.
12 (in-package "SB!IMPL")
14 (defun pointer-hash (key)
17 ;;; the depthoid explored when calculating hash values
19 ;;; "Depthoid" here is a sort of mixture of what Common Lisp ordinarily calls
20 ;;; depth and what Common Lisp ordinarily calls length; it's incremented either
21 ;;; when we descend into a compound object or when we step through elements of
22 ;;; a compound object.
23 (defconstant +max-hash-depthoid
+ 4)
25 ;;;; mixing hash values
27 ;;; a function for mixing hash values
30 ;;; * Non-commutativity keeps us from hashing e.g. #(1 5) to the
31 ;;; same value as #(5 1), and ending up in real trouble in some
32 ;;; special cases like bit vectors the way that CMUCL 18b SXHASH
33 ;;; does. (Under CMUCL 18b, SXHASH of any bit vector is 1..)
34 ;;; * We'd like to scatter our hash values over the entire possible range
35 ;;; of values instead of hashing small or common key values (like
36 ;;; 2 and NIL and #\a) to small FIXNUMs the way that the CMUCL 18b
37 ;;; SXHASH function does, again helping to avoid pathologies like
38 ;;; hashing all bit vectors to 1.
39 ;;; * We'd like this to be simple and fast, too.
40 (declaim (ftype (sfunction ((and fixnum unsigned-byte
)
41 (and fixnum unsigned-byte
))
42 (and fixnum unsigned-byte
))
44 (declaim (inline mix
))
46 (declare (optimize (speed 3)))
47 (declare (type (and fixnum unsigned-byte
) x y
))
49 ;; * Bits diffuse in both directions (shifted arbitrarily left by
50 ;; the multiplication in the calculation of XY, and shifted
51 ;; right by up to 5 places by the ASH).
52 ;; * The #'+ and #'LOGXOR operations don't commute with each other,
53 ;; so different bit patterns are mixed together as they shift
55 ;; * The arbitrary constant XOR used in the LOGXOR expression is
56 ;; intended to help break up any weird anomalies we might
57 ;; otherwise get when hashing highly regular patterns.
58 ;; (These are vaguely like the ideas used in many cryptographic
59 ;; algorithms, but we're not pushing them hard enough here for them
60 ;; to be cryptographically strong.)
62 ;; note: 3622009729038463111 is a 62-bit prime such that its low 61
63 ;; bits, low 60 bits and low 29 bits are all also primes, thus
64 ;; giving decent distributions no matter which of the possible
65 ;; values of most-positive-fixnum we have. It is derived by simple
66 ;; search starting from 2^60*pi. The multiplication should be
67 ;; efficient no matter what the platform thanks to modular
69 (let* ((mul (logand 3622009729038463111 sb
!xc
:most-positive-fixnum
))
70 (xor (logand 608948948376289905 sb
!xc
:most-positive-fixnum
))
71 (xy (logand (+ (* x mul
) y
) sb
!xc
:most-positive-fixnum
)))
72 (logand (logxor xor xy
(ash xy -
5)) sb
!xc
:most-positive-fixnum
)))
76 ;;;; Note that this operation is used in compiler symbol table
77 ;;;; lookups, so we'd like it to be fast.
79 ;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
80 ;;;; designed by Bob Jenkins (see
81 ;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
84 (declaim (inline %sxhash-substring
))
85 (defun %sxhash-substring
(string &optional
(count (length string
)))
86 ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
87 ;; cross-compiler were smarter about ASH, but we need it for
88 ;; sbcl-0.5.0m. (probably no longer true? We might need SAFETY 0
89 ;; to elide some type checks, but then again if this is inlined in
90 ;; all the critical places, we might not -- CSR, 2004-03-10)
91 (declare (optimize (speed 3) (safety 0)))
92 (declare (type string string
))
93 (declare (type index count
))
94 (macrolet ((set-result (form)
95 `(setf result
(ldb (byte #.sb
!vm
:n-word-bits
0) ,form
))))
97 (declare (type (unsigned-byte #.sb
!vm
:n-word-bits
) result
))
98 (unless (typep string
'(vector nil
))
100 (declare (type index i
))
101 (set-result (+ result
(char-code (aref string i
))))
102 (set-result (+ result
(ash result
10)))
103 (set-result (logxor result
(ash result -
6)))))
104 (set-result (+ result
(ash result
3)))
105 (set-result (logxor result
(ash result -
11)))
106 (set-result (logxor result
(ash result
15)))
107 (logand result most-positive-fixnum
))))
109 ;;; (let ((ht (make-hash-table :test 'equal)))
110 ;;; (do-all-symbols (symbol)
111 ;;; (let* ((string (symbol-name symbol))
112 ;;; (hash (%sxhash-substring string)))
113 ;;; (if (gethash hash ht)
114 ;;; (unless (string= (gethash hash ht) string)
115 ;;; (format t "collision: ~S ~S~%" string (gethash hash ht)))
116 ;;; (setf (gethash hash ht) string))))
117 ;;; (format t "final count=~W~%" (hash-table-count ht)))
119 (defun %sxhash-simple-string
(x)
120 (declare (optimize speed
))
121 (declare (type simple-string x
))
122 ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence
123 ;; of let conversion in the cross compiler, which otherwise causes
124 ;; strongly suboptimal register allocation.
126 (%sxhash-substring x
)))
127 (declare (notinline trick
))
130 (defun %sxhash-simple-substring
(x count
)
131 (declare (optimize speed
))
132 (declare (type simple-string x
))
133 (declare (type index count
))
134 ;; see comment in %SXHASH-SIMPLE-STRING
135 (flet ((trick (x count
)
136 (%sxhash-substring x count
)))
137 (declare (notinline trick
))
140 ;;;; the SXHASH function
143 (declaim (ftype (sfunction (integer) hash
) sxhash-bignum
))
144 (declaim (ftype (sfunction (t) hash
) sxhash-instance
))
147 ;; profiling SXHASH is hard, but we might as well try to make it go
148 ;; fast, in case it is the bottleneck somewhere. -- CSR, 2003-03-14
149 (declare (optimize speed
))
150 (labels ((sxhash-number (x)
152 (fixnum (sxhash x
)) ; through DEFTRANSFORM
153 (integer (sb!bignum
:sxhash-bignum x
))
154 (single-float (sxhash x
)) ; through DEFTRANSFORM
155 (double-float (sxhash x
)) ; through DEFTRANSFORM
156 #!+long-float
(long-float (error "stub: no LONG-FLOAT"))
157 (ratio (let ((result 127810327))
158 (declare (type fixnum result
))
159 (mixf result
(sxhash-number (numerator x
)))
160 (mixf result
(sxhash-number (denominator x
)))
162 (complex (let ((result 535698211))
163 (declare (type fixnum result
))
164 (mixf result
(sxhash-number (realpart x
)))
165 (mixf result
(sxhash-number (imagpart x
)))
167 (sxhash-recurse (x depthoid
)
168 (declare (type index depthoid
))
170 ;; we test for LIST here, rather than CONS, because the
171 ;; type test for CONS is in fact the test for
172 ;; LIST-POINTER-LOWTAG followed by a negated test for
173 ;; NIL. If we're going to have to test for NIL anyway,
174 ;; we might as well do it explicitly and pick off the
175 ;; answer. -- CSR, 2004-07-14
178 (sxhash x
) ; through DEFTRANSFORM
180 (mix (sxhash-recurse (car x
) (1- depthoid
))
181 (sxhash-recurse (cdr x
) (1- depthoid
)))
185 ;; Pathnames are EQUAL if all the components are EQUAL, so
186 ;; we hash all of the components of a pathname together.
187 (let ((hash (sxhash-recurse (pathname-host x
) depthoid
)))
188 (mixf hash
(sxhash-recurse (pathname-device x
) depthoid
))
189 (mixf hash
(sxhash-recurse (pathname-directory x
) depthoid
))
190 (mixf hash
(sxhash-recurse (pathname-name x
) depthoid
))
191 (mixf hash
(sxhash-recurse (pathname-type x
) depthoid
))
192 ;; Hash :NEWEST the same as NIL because EQUAL for
193 ;; pathnames assumes that :newest and nil are equal.
194 (let ((version (%pathname-version x
)))
195 (mixf hash
(sxhash-recurse (if (eq version
:newest
)
199 (if (or (typep x
'structure-object
) (typep x
'condition
))
201 (sxhash ; through DEFTRANSFORM
203 (layout-classoid (%instance-layout x
)))))
204 (sxhash-instance x
))))
205 (symbol (sxhash x
)) ; through DEFTRANSFORM
208 (simple-string (sxhash x
)) ; through DEFTRANSFORM
209 (string (%sxhash-substring x
))
210 (simple-bit-vector (sxhash x
)) ; through DEFTRANSFORM
212 ;; FIXME: It must surely be possible to do better
213 ;; than this. The problem is that a non-SIMPLE
214 ;; BIT-VECTOR could be displaced to another, with a
215 ;; non-zero offset -- so that significantly more
216 ;; work needs to be done using the %VECTOR-RAW-BITS
217 ;; approach. This will probably do for now.
218 (sxhash-recurse (copy-seq x
) depthoid
))
219 (t (logxor 191020317 (sxhash (array-rank x
))))))
222 (sxhash (char-code x
)))) ; through DEFTRANSFORM
223 ;; general, inefficient case of NUMBER
224 (number (sxhash-number x
))
225 (generic-function (sxhash-instance x
))
227 (sxhash-recurse x
+max-hash-depthoid
+)))
229 ;;;; the PSXHASH function
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.
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.
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 (char-code (char-upcase key
)))
255 (defun array-psxhash (key depthoid
)
256 (declare (optimize speed
))
257 (declare (type array key
))
258 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
260 ;; VECTORs have to be treated specially because ANSI specifies
261 ;; that we must respect fill pointers.
264 '(let ((result 572539))
265 (declare (type fixnum result
))
266 (mixf result
(length key
))
267 (when (plusp depthoid
)
269 (dotimes (i (length key
))
270 (declare (type fixnum i
))
272 (psxhash (aref key i
) depthoid
))))
274 (make-dispatch (types)
276 ,@(loop for type in types
279 (make-dispatch (simple-base-string
280 (simple-array character
(*))
282 (simple-array (unsigned-byte 8) (*))
283 (simple-array fixnum
(*))
285 ;; Any other array can be hashed by working with its underlying
286 ;; one-dimensional physical representation.
288 (let ((result 60828))
289 (declare (type fixnum result
))
290 (dotimes (i (array-rank key
))
291 (mixf result
(array-dimension key i
)))
292 (when (plusp depthoid
)
294 (dotimes (i (array-total-size key
))
296 (psxhash (row-major-aref key i
) depthoid
))))
299 (defun structure-object-psxhash (key depthoid
)
300 (declare (optimize speed
))
301 (declare (type structure-object key
))
302 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
303 (let* ((layout (%instance-layout key
)) ; i.e. slot #0
304 (length (layout-length layout
))
305 (classoid (layout-classoid layout
))
306 (name (classoid-name classoid
))
307 (result (mix (sxhash name
) (the fixnum
79867))))
308 (declare (type fixnum result
))
309 (dotimes (i (min depthoid
(- length
1 (layout-n-untagged-slots layout
))))
310 (declare (type fixnum i
))
311 (let ((j (1+ i
))) ; skipping slot #0, which is for LAYOUT
312 (declare (type fixnum j
))
314 (psxhash (%instance-ref key j
)
316 ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+
317 ;; is pretty low currently, so they might not make it into the hash
321 (defun list-psxhash (key depthoid
)
322 (declare (optimize speed
))
323 (declare (type list key
))
324 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
330 (mix (psxhash (car key
) (1- depthoid
))
331 (psxhash (cdr key
) (1- depthoid
))))))
333 (defun hash-table-psxhash (key)
334 (declare (optimize speed
))
335 (declare (type hash-table key
))
336 (let ((result 103924836))
337 (declare (type fixnum result
))
338 (mixf result
(hash-table-count key
))
339 (mixf result
(sxhash (hash-table-test key
)))
342 (defun number-psxhash (key)
343 (declare (optimize speed
))
344 (declare (type number key
))
345 (flet ((sxhash-double-float (val)
346 (declare (type double-float val
))
347 ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
348 ;; resulting code works without consing. (In Debian cmucl 2.4.17,
352 (integer (sxhash key
))
353 (float (macrolet ((frob (type)
354 (let ((lo (coerce sb
!xc
:most-negative-fixnum type
))
355 (hi (coerce sb
!xc
:most-positive-fixnum type
)))
356 `(cond (;; This clause allows FIXNUM-sized integer
357 ;; values to be handled without consing.
359 (multiple-value-bind (q r
)
360 (floor (the (,type
,lo
,hi
) key
))
361 (if (zerop (the ,type r
))
364 (coerce key
'double-float
)))))
366 (multiple-value-bind (q r
) (floor key
)
367 (if (zerop (the ,type r
))
370 (coerce key
'double-float
)))))))))
372 (single-float (frob single-float
))
373 (double-float (frob double-float
))
375 (long-float (error "LONG-FLOAT not currently supported")))))
376 (rational (if (and (<= most-negative-double-float
378 most-positive-double-float
)
379 (= (coerce key
'double-float
) key
))
380 (sxhash-double-float (coerce key
'double-float
))
382 (complex (if (zerop (imagpart key
))
383 (number-psxhash (realpart key
))
384 (let ((result 330231))
385 (declare (type fixnum result
))
386 (mixf result
(number-psxhash (realpart key
)))
387 (mixf result
(number-psxhash (imagpart key
)))