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
)))
74 ;; Return a number that increments by 1 for each word-pair allocation,
75 ;; barring complications such as exhaustion of the current page.
76 ;; The result is guaranteed to be a positive fixnum.
77 (declaim (inline address-based-counter-val
))
78 (defun address-based-counter-val ()
79 #!+(and (not sb-thread
) cheneygc
)
80 (ash (sap-int (dynamic-space-free-pointer)) (- (1+ sb
!vm
:word-shift
)))
81 ;; dynamic-space-free-pointer increments only when a page is full.
82 ;; Using boxed_region directly is finer-grained.
83 #!+(and (not sb-thread
) gencgc
)
84 (ash (extern-alien "boxed_region" unsigned-long
)
85 (- (1+ sb
!vm
:word-shift
)))
86 ;; threads imply gencgc. use the per-thread alloc region pointer
88 (ash (sap-int (sb!vm
::current-thread-offset-sap
89 sb
!vm
::thread-alloc-region-slot
))
90 (- (1+ sb
!vm
:word-shift
))))
92 ;; Return some bits that are dependent on the next address that will be
93 ;; allocated, mixed with the previous state (in case addresses get recycled).
94 ;; This algorithm, used for stuffing a hash-code into instances of CTYPE
95 ;; subtypes, is simpler than RANDOM, and a test of randomness won't
96 ;; measure up as well, but for the intended use, it doesn't matter.
97 ;; CLOS hashes could probably be made to use this.
98 (defun quasi-random-address-based-hash (state mask
)
99 (declare (type (simple-array (and fixnum unsigned-byte
) (1)) state
))
100 ;; Ok with multiple threads - No harm, no foul.
101 (logand (setf (aref state
0) (mix (address-based-counter-val) (aref state
0)))
107 ;;;; Note that this operation is used in compiler symbol table
108 ;;;; lookups, so we'd like it to be fast.
110 ;;;; As of 2004-03-10, we implement the one-at-a-time algorithm
111 ;;;; designed by Bob Jenkins (see
112 ;;;; <http://burtleburtle.net/bob/hash/doobs.html> for some more
115 (declaim (inline %sxhash-substring
))
116 (defun %sxhash-substring
(string &optional
(count (length string
)))
117 ;; FIXME: As in MIX above, we wouldn't need (SAFETY 0) here if the
118 ;; cross-compiler were smarter about ASH, but we need it for
119 ;; sbcl-0.5.0m. (probably no longer true? We might need SAFETY 0
120 ;; to elide some type checks, but then again if this is inlined in
121 ;; all the critical places, we might not -- CSR, 2004-03-10)
122 (declare (optimize (speed 3) (safety 0)))
123 (declare (type string string
))
124 (declare (type index count
))
125 (macrolet ((set-result (form)
126 `(setf result
(ldb (byte #.sb
!vm
:n-word-bits
0) ,form
))))
128 (declare (type (unsigned-byte #.sb
!vm
:n-word-bits
) result
))
129 (unless (typep string
'(vector nil
))
131 (declare (type index i
))
132 (set-result (+ result
(char-code (aref string i
))))
133 (set-result (+ result
(ash result
10)))
134 (set-result (logxor result
(ash result -
6)))))
135 (set-result (+ result
(ash result
3)))
136 (set-result (logxor result
(ash result -
11)))
137 (set-result (logxor result
(ash result
15)))
138 (logand result most-positive-fixnum
))))
140 ;;; (let ((ht (make-hash-table :test 'equal)))
141 ;;; (do-all-symbols (symbol)
142 ;;; (let* ((string (symbol-name symbol))
143 ;;; (hash (%sxhash-substring string)))
144 ;;; (if (gethash hash ht)
145 ;;; (unless (string= (gethash hash ht) string)
146 ;;; (format t "collision: ~S ~S~%" string (gethash hash ht)))
147 ;;; (setf (gethash hash ht) string))))
148 ;;; (format t "final count=~W~%" (hash-table-count ht)))
150 (defun %sxhash-simple-string
(x)
151 (declare (optimize speed
))
152 (declare (type simple-string x
))
153 ;; KLUDGE: this FLET is a workaround (suggested by APD) for presence
154 ;; of let conversion in the cross compiler, which otherwise causes
155 ;; strongly suboptimal register allocation.
157 (%sxhash-substring x
)))
158 (declare (notinline trick
))
161 (defun %sxhash-simple-substring
(x count
)
162 (declare (optimize speed
))
163 (declare (type simple-string x
))
164 (declare (type index count
))
165 ;; see comment in %SXHASH-SIMPLE-STRING
166 (flet ((trick (x count
)
167 (%sxhash-substring x count
)))
168 (declare (notinline trick
))
171 ;;;; the SXHASH function
174 (declaim (ftype (sfunction (integer) hash
) sxhash-bignum
))
175 (declaim (ftype (sfunction (t) hash
) sxhash-instance
))
178 ;; profiling SXHASH is hard, but we might as well try to make it go
179 ;; fast, in case it is the bottleneck somewhere. -- CSR, 2003-03-14
180 (declare (optimize speed
))
181 (labels ((sxhash-number (x)
183 (fixnum (sxhash x
)) ; through DEFTRANSFORM
184 (integer (sb!bignum
:sxhash-bignum x
))
185 (single-float (sxhash x
)) ; through DEFTRANSFORM
186 (double-float (sxhash x
)) ; through DEFTRANSFORM
187 #!+long-float
(long-float (error "stub: no LONG-FLOAT"))
188 (ratio (let ((result 127810327))
189 (declare (type fixnum result
))
190 (mixf result
(sxhash-number (numerator x
)))
191 (mixf result
(sxhash-number (denominator x
)))
193 (complex (let ((result 535698211))
194 (declare (type fixnum result
))
195 (mixf result
(sxhash-number (realpart x
)))
196 (mixf result
(sxhash-number (imagpart x
)))
198 (sxhash-recurse (x depthoid
)
199 (declare (type index depthoid
))
201 ;; we test for LIST here, rather than CONS, because the
202 ;; type test for CONS is in fact the test for
203 ;; LIST-POINTER-LOWTAG followed by a negated test for
204 ;; NIL. If we're going to have to test for NIL anyway,
205 ;; we might as well do it explicitly and pick off the
206 ;; answer. -- CSR, 2004-07-14
209 (sxhash x
) ; through DEFTRANSFORM
211 (mix (sxhash-recurse (car x
) (1- depthoid
))
212 (sxhash-recurse (cdr x
) (1- depthoid
)))
217 ;; Pathnames are EQUAL if all the components are EQUAL, so
218 ;; we hash all of the components of a pathname together.
219 (let ((hash (sxhash-recurse (pathname-host x
) depthoid
)))
220 (mixf hash
(sxhash-recurse (pathname-device x
) depthoid
))
221 (mixf hash
(sxhash-recurse (pathname-directory x
) depthoid
))
222 (mixf hash
(sxhash-recurse (pathname-name x
) depthoid
))
223 (mixf hash
(sxhash-recurse (pathname-type x
) depthoid
))
224 ;; Hash :NEWEST the same as NIL because EQUAL for
225 ;; pathnames assumes that :newest and nil are equal.
226 (let ((version (%pathname-version x
)))
227 (mixf hash
(sxhash-recurse (if (eq version
:newest
)
232 ;; LAYOUTs have an easily-accesible hash value: we
233 ;; might as well use it. It's not actually uniform
234 ;; over the space of hash values (it excludes 0 and
235 ;; some of the larger numbers) but it's better than
236 ;; simply returning the same value for all LAYOUT
237 ;; objects, as the next branch would do.
238 (layout-clos-hash x
))
239 ((or structure-object condition
)
241 (sxhash ; through DEFTRANSFORM
243 (layout-classoid (%instance-layout x
))))))
244 (t (sxhash-instance x
))))
245 (symbol (sxhash x
)) ; through DEFTRANSFORM
248 (simple-string (sxhash x
)) ; through DEFTRANSFORM
249 (string (%sxhash-substring x
))
250 (simple-bit-vector (sxhash x
)) ; through DEFTRANSFORM
252 ;; FIXME: It must surely be possible to do better
253 ;; than this. The problem is that a non-SIMPLE
254 ;; BIT-VECTOR could be displaced to another, with a
255 ;; non-zero offset -- so that significantly more
256 ;; work needs to be done using the %VECTOR-RAW-BITS
257 ;; approach. This will probably do for now.
258 (sxhash-recurse (copy-seq x
) depthoid
))
259 (t (logxor 191020317 (sxhash (array-rank x
))))))
262 (sxhash (char-code x
)))) ; through DEFTRANSFORM
263 ;; general, inefficient case of NUMBER
264 (number (sxhash-number x
))
265 (generic-function (sxhash-instance x
))
267 (sxhash-recurse x
+max-hash-depthoid
+)))
269 ;;;; the PSXHASH function
271 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
272 ;;;; more efficient (in both time and space) by rewriting it along the lines
273 ;;;; of the SXHASH code above.
275 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
276 (defun psxhash (key &optional
(depthoid +max-hash-depthoid
+))
277 (declare (optimize speed
))
278 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
279 ;; Note: You might think it would be cleaner to use the ordering given in the
280 ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
281 ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
282 ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
283 ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
284 ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
285 ;; comparison behavior.
287 (array (array-psxhash key depthoid
))
288 (hash-table (hash-table-psxhash key
))
289 (structure-object (structure-object-psxhash key depthoid
))
290 (cons (list-psxhash key depthoid
))
291 (number (number-psxhash key
))
292 (character (char-code (char-upcase key
)))
295 (defun array-psxhash (key depthoid
)
296 (declare (optimize speed
))
297 (declare (type array key
))
298 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
300 ;; VECTORs have to be treated specially because ANSI specifies
301 ;; that we must respect fill pointers.
304 '(let ((result 572539))
305 (declare (type fixnum result
))
306 (mixf result
(length key
))
307 (when (plusp depthoid
)
309 (dotimes (i (length key
))
310 (declare (type fixnum i
))
312 (psxhash (aref key i
) depthoid
))))
314 (make-dispatch (types)
316 ,@(loop for type in types
319 (make-dispatch (simple-base-string
320 (simple-array character
(*))
322 (simple-array (unsigned-byte 8) (*))
323 (simple-array fixnum
(*))
325 ;; Any other array can be hashed by working with its underlying
326 ;; one-dimensional physical representation.
328 (let ((result 60828))
329 (declare (type fixnum result
))
330 (dotimes (i (array-rank key
))
331 (mixf result
(array-dimension key i
)))
332 (when (plusp depthoid
)
334 (dotimes (i (array-total-size key
))
336 (psxhash (row-major-aref key i
) depthoid
))))
339 (defun structure-object-psxhash (key depthoid
)
340 (declare (optimize speed
))
341 (declare (type structure-object key
))
342 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
343 (let* ((layout (%instance-layout key
)) ; i.e. slot #0
344 ;; Is there some reason the name of the layout's classoid
345 ;; should be preferred as the seed, instead of using the CLOS-HASH
346 ;; just like SXHASH does?
347 (classoid (layout-classoid layout
))
348 (name (classoid-name classoid
))
349 (result (mix (sxhash name
) (the fixnum
79867))))
350 (declare (type fixnum result
))
351 (when (plusp depthoid
)
352 (let ((max-iterations depthoid
)
353 (depthoid (1- depthoid
)))
354 ;; We don't mix in LAYOUT here because it was already done above.
355 (do-instance-tagged-slot (i key
:layout layout
:exclude-padding t
)
356 (mixf result
(psxhash (%instance-ref key i
) depthoid
))
357 (if (zerop (decf max-iterations
)) (return)))))
358 ;; [The following comment blurs some issues: indeed it would take
359 ;; a second loop in the non-interleaved-slots code; that loop might
360 ;; never execute because depthoid "cuts off", although that's an arbitrary
361 ;; choice and could be decided otherwise; and efficiency would likely
362 ;; demand that we store some additional metadata in the LAYOUT indicating
363 ;; how to mix the bits in, because floating-point +/-zeros have to
364 ;; be considered EQUALP]
365 ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+
366 ;; is pretty low currently, so they might not make it into the hash
370 (defun list-psxhash (key depthoid
)
371 (declare (optimize speed
))
372 (declare (type list key
))
373 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
379 (mix (psxhash (car key
) (1- depthoid
))
380 (psxhash (cdr key
) (1- depthoid
))))))
382 (defun hash-table-psxhash (key)
383 (declare (optimize speed
))
384 (declare (type hash-table key
))
385 (let ((result 103924836))
386 (declare (type fixnum result
))
387 (mixf result
(hash-table-count key
))
388 (mixf result
(sxhash (hash-table-test key
)))
391 (defun number-psxhash (key)
392 (declare (optimize speed
))
393 (declare (type number key
))
394 (flet ((sxhash-double-float (val)
395 (declare (type double-float val
))
396 ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
397 ;; resulting code works without consing. (In Debian cmucl 2.4.17,
401 (integer (sxhash key
))
402 (float (macrolet ((frob (type)
403 (let ((lo (coerce sb
!xc
:most-negative-fixnum type
))
404 (hi (coerce sb
!xc
:most-positive-fixnum type
)))
405 `(cond (;; This clause allows FIXNUM-sized integer
406 ;; values to be handled without consing.
408 (multiple-value-bind (q r
)
409 (floor (the (,type
,lo
,hi
) key
))
410 (if (zerop (the ,type r
))
413 (coerce key
'double-float
)))))
415 (multiple-value-bind (q r
) (floor key
)
416 (if (zerop (the ,type r
))
419 (coerce key
'double-float
)))))))))
421 (single-float (frob single-float
))
422 (double-float (frob double-float
))
424 (long-float (error "LONG-FLOAT not currently supported")))))
425 (rational (if (and (<= most-negative-double-float
427 most-positive-double-float
)
428 (= (coerce key
'double-float
) key
))
429 (sxhash-double-float (coerce key
'double-float
))
431 (complex (if (zerop (imagpart key
))
432 (number-psxhash (realpart key
))
433 (let ((result 330231))
434 (declare (type fixnum result
))
435 (mixf result
(number-psxhash (realpart key
)))
436 (mixf result
(number-psxhash (imagpart key
)))