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 ;;; the depthoid explored when calculating hash values
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)
22 ;;;; mixing hash values
24 ;;; a function for mixing hash values
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.
38 ;;; FIXME: Should this be INLINE?
39 (declaim (ftype (sfunction ((and fixnum unsigned-byte
)
40 (and fixnum unsigned-byte
))
41 (and fixnum unsigned-byte
))
43 (declaim (inline mix
))
45 ;; FIXME: We wouldn't need the nasty (SAFETY 0) here if the compiler
46 ;; were smarter about optimizing ASH. (Without the THE FIXNUM below,
47 ;; and the (SAFETY 0) declaration here to get the compiler to trust
48 ;; it, the sbcl-0.5.0m cross-compiler running under Debian
49 ;; cmucl-2.4.17 turns the ASH into a full call, requiring the
50 ;; UNSIGNED-BYTE 32 argument to be coerced to a bignum, requiring
51 ;; consing, and thus generally obliterating performance.)
52 (declare (optimize (speed 3) (safety 0)))
53 (declare (type (and fixnum unsigned-byte
) x y
))
55 ;; * Bits diffuse in both directions (shifted left by up to 2 places
56 ;; in the calculation of XY, and shifted right by up to 5 places
58 ;; * The #'+ and #'LOGXOR operations don't commute with each other,
59 ;; so different bit patterns are mixed together as they shift
61 ;; * The arbitrary constant in the #'LOGXOR expression is intended
62 ;; to help break up any weird anomalies we might otherwise get
63 ;; when hashing highly regular patterns.
64 ;; (These are vaguely like the ideas used in many cryptographic
65 ;; algorithms, but we're not pushing them hard enough here for them
66 ;; to be cryptographically strong.)
67 (let* ((xy (+ (* x
3) y
)))
68 (logand most-positive-fixnum
75 ;;;; Note that this operation is used in compiler symbol table
76 ;;;; lookups, so we'd like it to be fast.
78 ;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
79 ;;;; designed by Bob Jenkins (see
80 ;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
83 #!-sb-fluid
(declaim (inline %sxhash-substring
))
84 (defun %sxhash-substring
(string &optional
(count (length string
)))
85 ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
86 ;; cross-compiler were smarter about ASH, but we need it for
87 ;; sbcl-0.5.0m. (probably no longer true? We might need SAFETY 0
88 ;; to elide some type checks, but then again if this is inlined in
89 ;; all the critical places, we might not -- CSR, 2004-03-10)
90 (declare (optimize (speed 3) (safety 0)))
91 (declare (type string string
))
92 (declare (type index count
))
93 (macrolet ((set-result (form)
94 `(setf result
(ldb (byte #.sb
!vm
:n-word-bits
0) ,form
))))
96 (declare (type (unsigned-byte #.sb
!vm
:n-word-bits
) result
))
97 (unless (typep string
'(vector nil
))
99 (declare (type index i
))
100 (set-result (+ result
(char-code (aref string i
))))
101 (set-result (+ result
(ash result
10)))
102 (set-result (logxor result
(ash result -
6)))))
103 (set-result (+ result
(ash result
3)))
104 (set-result (logxor result
(ash result -
11)))
105 (set-result (logxor result
(ash result
15)))
106 (logand result most-positive-fixnum
))))
108 ;;; (let ((ht (make-hash-table :test 'equal)))
109 ;;; (do-all-symbols (symbol)
110 ;;; (let* ((string (symbol-name symbol))
111 ;;; (hash (%sxhash-substring string)))
112 ;;; (if (gethash hash ht)
113 ;;; (unless (string= (gethash hash ht) string)
114 ;;; (format t "collision: ~S ~S~%" string (gethash hash ht)))
115 ;;; (setf (gethash hash ht) string))))
116 ;;; (format t "final count=~W~%" (hash-table-count ht)))
118 (defun %sxhash-simple-string
(x)
119 (declare (optimize speed
))
120 (declare (type simple-string x
))
121 ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence
122 ;; of let conversion in the cross compiler, which otherwise causes
123 ;; strongly suboptimal register allocation.
125 (%sxhash-substring x
)))
126 (declare (notinline trick
))
129 (defun %sxhash-simple-substring
(x count
)
130 (declare (optimize speed
))
131 (declare (type simple-string x
))
132 (declare (type index count
))
133 ;; see comment in %SXHASH-SIMPLE-STRING
134 (flet ((trick (x count
)
135 (%sxhash-substring x count
)))
136 (declare (notinline trick
))
139 ;;;; the SXHASH function
142 (declaim (ftype (sfunction (integer) (integer 0 #.sb
!xc
:most-positive-fixnum
))
144 (declaim (ftype (sfunction (t) (integer 0 #.sb
!xc
:most-positive-fixnum
))
148 ;; profiling SXHASH is hard, but we might as well try to make it go
149 ;; fast, in case it is the bottleneck somewhere. -- CSR, 2003-03-14
150 (declare (optimize speed
))
151 (labels ((sxhash-number (x)
153 (fixnum (sxhash x
)) ; through DEFTRANSFORM
154 (integer (sb!bignum
:sxhash-bignum x
))
155 (single-float (sxhash x
)) ; through DEFTRANSFORM
156 (double-float (sxhash x
)) ; through DEFTRANSFORM
157 #!+long-float
(long-float (error "stub: no LONG-FLOAT"))
158 (ratio (let ((result 127810327))
159 (declare (type fixnum result
))
160 (mixf result
(sxhash-number (numerator x
)))
161 (mixf result
(sxhash-number (denominator x
)))
163 (complex (let ((result 535698211))
164 (declare (type fixnum result
))
165 (mixf result
(sxhash-number (realpart x
)))
166 (mixf result
(sxhash-number (imagpart x
)))
168 (sxhash-recurse (x depthoid
)
169 (declare (type index depthoid
))
171 ;; we test for LIST here, rather than CONS, because the
172 ;; type test for CONS is in fact the test for
173 ;; LIST-POINTER-LOWTAG followed by a negated test for
174 ;; NIL. If we're going to have to test for NIL anyway,
175 ;; we might as well do it explicitly and pick off the
176 ;; answer. -- CSR, 2004-07-14
179 (sxhash x
) ; through DEFTRANSFORM
181 (mix (sxhash-recurse (car x
) (1- depthoid
))
182 (sxhash-recurse (cdr x
) (1- depthoid
)))
185 (if (or (typep x
'structure-object
) (typep x
'condition
))
187 (sxhash ; through DEFTRANSFORM
189 (layout-classoid (%instance-layout x
)))))
190 (sxhash-instance x
)))
191 (symbol (sxhash x
)) ; through DEFTRANSFORM
194 (simple-string (sxhash x
)) ; through DEFTRANSFORM
195 (string (%sxhash-substring x
))
196 (simple-bit-vector (sxhash x
)) ; through DEFTRANSFORM
198 ;; FIXME: It must surely be possible to do better
199 ;; than this. The problem is that a non-SIMPLE
200 ;; BIT-VECTOR could be displaced to another, with a
201 ;; non-zero offset -- so that significantly more
202 ;; work needs to be done using the %RAW-BITS
203 ;; approach. This will probably do for now.
204 (sxhash-recurse (copy-seq x
) depthoid
))
205 (t (logxor 191020317 (sxhash (array-rank x
))))))
208 (sxhash (char-code x
)))) ; through DEFTRANSFORM
209 ;; general, inefficient case of NUMBER
210 (number (sxhash-number x
))
211 (generic-function (sxhash-instance x
))
213 (sxhash-recurse x
+max-hash-depthoid
+)))
215 ;;;; the PSXHASH function
217 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
218 ;;;; more efficient (in both time and space) by rewriting it along the lines
219 ;;;; of the SXHASH code above.
221 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
222 (defun psxhash (key &optional
(depthoid +max-hash-depthoid
+))
223 (declare (optimize speed
))
224 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
225 ;; Note: You might think it would be cleaner to use the ordering given in the
226 ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
227 ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
228 ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
229 ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
230 ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
231 ;; comparison behavior.
233 (array (array-psxhash key depthoid
))
234 (hash-table (hash-table-psxhash key
))
235 (structure-object (structure-object-psxhash key depthoid
))
236 (cons (list-psxhash key depthoid
))
237 (number (number-psxhash key
))
238 (character (char-code (char-upcase key
)))
241 (defun array-psxhash (key depthoid
)
242 (declare (optimize speed
))
243 (declare (type array key
))
244 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
246 ;; VECTORs have to be treated specially because ANSI specifies
247 ;; that we must respect fill pointers.
250 '(let ((result 572539))
251 (declare (type fixnum result
))
252 (mixf result
(length key
))
253 (when (plusp depthoid
)
255 (dotimes (i (length key
))
256 (declare (type fixnum i
))
258 (psxhash (aref key i
) depthoid
))))
260 (make-dispatch (types)
262 ,@(loop for type in types
265 (make-dispatch (simple-base-string
266 (simple-array character
(*))
268 (simple-array (unsigned-byte 8) (*))
269 (simple-array fixnum
(*))
271 ;; Any other array can be hashed by working with its underlying
272 ;; one-dimensional physical representation.
274 (let ((result 60828))
275 (declare (type fixnum result
))
276 (dotimes (i (array-rank key
))
277 (mixf result
(array-dimension key i
)))
278 (when (plusp depthoid
)
280 (dotimes (i (array-total-size key
))
282 (psxhash (row-major-aref key i
) depthoid
))))
285 (defun structure-object-psxhash (key depthoid
)
286 (declare (optimize speed
))
287 (declare (type structure-object key
))
288 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
289 (let* ((layout (%instance-layout key
)) ; i.e. slot #0
290 (length (layout-length layout
))
291 (classoid (layout-classoid layout
))
292 (name (classoid-name classoid
))
293 (result (mix (sxhash name
) (the fixnum
79867))))
294 (declare (type fixnum result
))
295 (dotimes (i (min depthoid
(- length
1 (layout-n-untagged-slots layout
))))
296 (declare (type fixnum i
))
297 (let ((j (1+ i
))) ; skipping slot #0, which is for LAYOUT
298 (declare (type fixnum j
))
300 (psxhash (%instance-ref key j
)
302 ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+
303 ;; is pretty low currently, so they might not make it into the hash
307 (defun list-psxhash (key depthoid
)
308 (declare (optimize speed
))
309 (declare (type list key
))
310 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
316 (mix (psxhash (car key
) (1- depthoid
))
317 (psxhash (cdr key
) (1- depthoid
))))))
319 (defun hash-table-psxhash (key)
320 (declare (optimize speed
))
321 (declare (type hash-table key
))
322 (let ((result 103924836))
323 (declare (type fixnum result
))
324 (mixf result
(hash-table-count key
))
325 (mixf result
(sxhash (hash-table-test key
)))
328 (defun number-psxhash (key)
329 (declare (optimize speed
))
330 (declare (type number key
))
331 (flet ((sxhash-double-float (val)
332 (declare (type double-float val
))
333 ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
334 ;; resulting code works without consing. (In Debian cmucl 2.4.17,
338 (integer (sxhash key
))
339 (float (macrolet ((frob (type)
340 (let ((lo (coerce most-negative-fixnum type
))
341 (hi (coerce most-positive-fixnum type
)))
342 `(cond (;; This clause allows FIXNUM-sized integer
343 ;; values to be handled without consing.
345 (multiple-value-bind (q r
)
346 (floor (the (,type
,lo
,hi
) key
))
347 (if (zerop (the ,type r
))
350 (coerce key
'double-float
)))))
352 (multiple-value-bind (q r
) (floor key
)
353 (if (zerop (the ,type r
))
356 (coerce key
'double-float
)))))))))
358 (single-float (frob single-float
))
359 (double-float (frob double-float
))
361 (long-float (error "LONG-FLOAT not currently supported")))))
362 (rational (if (and (<= most-negative-double-float
364 most-positive-double-float
)
365 (= (coerce key
'double-float
) key
))
366 (sxhash-double-float (coerce key
'double-float
))
368 (complex (if (zerop (imagpart key
))
369 (number-psxhash (realpart key
))
370 (let ((result 330231))
371 (declare (type fixnum result
))
372 (mixf result
(number-psxhash (realpart key
)))
373 (mixf result
(number-psxhash (imagpart key
)))