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
))
176 (defun new-instance-hash-code ()
177 ;; ANSI SXHASH wants us to make a good-faith effort to produce
178 ;; hash-codes that are well distributed within the range of
179 ;; non-negative fixnums, and this address-based operation does that.
180 ;; This is faster than calling RANDOM, and is random enough.
184 (quasi-random-address-based-hash
185 (load-time-value (make-array 1 :element-type
'(and fixnum unsigned-byte
))
187 most-positive-fixnum
))))
189 ;; Make sure we never return 0 (almost no chance of that anyway).
192 (declaim (inline std-instance-hash
))
193 (defun std-instance-hash (instance)
194 (let ((hash (%instance-ref instance sb
!pcl
::std-instance-hash-slot-index
)))
195 (if (not (eql hash
0))
197 (let ((new (new-instance-hash-code)))
198 ;; At most one thread will compute a random hash.
199 ;; %INSTANCE-CAS is a full call if there is no vop for it.
200 (let ((old (%instance-cas instance sb
!pcl
::std-instance-hash-slot-index
202 (if (eql old
0) new old
))))))
204 ;; These are also random numbers, but not lazily computed.
205 (declaim (inline fsc-instance-hash
))
206 (defun fsc-instance-hash (fin)
207 (%funcallable-instance-info fin sb
!pcl
::fsc-instance-hash-slot-index
))
210 ;; profiling SXHASH is hard, but we might as well try to make it go
211 ;; fast, in case it is the bottleneck somewhere. -- CSR, 2003-03-14
212 (declare (optimize speed
))
213 (labels ((sxhash-number (x)
214 (macrolet ((hash-complex-float ()
215 `(let ((result 535698211))
216 (declare (type fixnum result
))
217 (mixf result
(sxhash (realpart x
)))
218 (mixf result
(sxhash (imagpart x
)))
221 (fixnum (sxhash x
)) ; through DEFTRANSFORM
222 (integer (sb!bignum
:sxhash-bignum x
))
223 (single-float (sxhash x
)) ; through DEFTRANSFORM
224 (double-float (sxhash x
)) ; through DEFTRANSFORM
225 #!+long-float
(long-float (error "stub: no LONG-FLOAT"))
226 (ratio (let ((result 127810327))
227 (declare (type fixnum result
))
228 (mixf result
(sxhash-number (numerator x
)))
229 (mixf result
(sxhash-number (denominator x
)))
232 ((complex long-float
)
233 (hash-complex-float))
234 ((complex double-float
)
235 (hash-complex-float))
236 ((complex single-float
)
237 (hash-complex-float))
239 (let ((result 535698211)
240 (realpart (realpart x
))
241 (imagpart (imagpart x
)))
242 (declare (type fixnum result
))
243 (mixf result
(if (fixnump imagpart
)
245 (sxhash-number imagpart
)))
246 (mixf result
(if (fixnump realpart
)
248 (sxhash-number realpart
)))
250 (sxhash-recurse (x depthoid
)
251 (declare (type index depthoid
))
253 ;; we test for LIST here, rather than CONS, because the
254 ;; type test for CONS is in fact the test for
255 ;; LIST-POINTER-LOWTAG followed by a negated test for
256 ;; NIL. If we're going to have to test for NIL anyway,
257 ;; we might as well do it explicitly and pick off the
258 ;; answer. -- CSR, 2004-07-14
261 (sxhash x
) ; through DEFTRANSFORM
263 (mix (sxhash-recurse (car x
) (1- depthoid
))
264 (sxhash-recurse (cdr x
) (1- depthoid
)))
269 ;; Pathnames are EQUAL if all the components are EQUAL, so
270 ;; we hash all of the components of a pathname together.
271 (let ((hash (sxhash-recurse (pathname-host x
) depthoid
)))
272 (mixf hash
(sxhash-recurse (pathname-device x
) depthoid
))
273 (mixf hash
(sxhash-recurse (pathname-directory x
) depthoid
))
274 (mixf hash
(sxhash-recurse (pathname-name x
) depthoid
))
275 (mixf hash
(sxhash-recurse (pathname-type x
) depthoid
))
276 ;; Hash :NEWEST the same as NIL because EQUAL for
277 ;; pathnames assumes that :newest and nil are equal.
278 (let ((version (%pathname-version x
)))
279 (mixf hash
(sxhash-recurse (if (eq version
:newest
)
284 ;; LAYOUTs have an easily-accesible hash value: we
285 ;; might as well use it. It's not actually uniform
286 ;; over the space of hash values (it excludes 0 and
287 ;; some of the larger numbers) but it's better than
288 ;; simply returning the same value for all LAYOUT
289 ;; objects, as the next branch would do.
290 (layout-clos-hash x
))
291 ((or structure-object condition
)
293 ;; FIXME: why not (LAYOUT-CLOS-HASH ...) ?
294 (sxhash ; through DEFTRANSFORM
296 (layout-classoid (%instance-layout x
))))))
297 (t (std-instance-hash x
))))
298 (symbol (sxhash x
)) ; through DEFTRANSFORM
301 (simple-string (sxhash x
)) ; through DEFTRANSFORM
302 (string (%sxhash-substring x
))
303 (simple-bit-vector (sxhash x
)) ; through DEFTRANSFORM
305 ;; FIXME: It must surely be possible to do better
306 ;; than this. The problem is that a non-SIMPLE
307 ;; BIT-VECTOR could be displaced to another, with a
308 ;; non-zero offset -- so that significantly more
309 ;; work needs to be done using the %VECTOR-RAW-BITS
310 ;; approach. This will probably do for now.
311 (sxhash-recurse (copy-seq x
) depthoid
))
312 (t (logxor 191020317 (sxhash (array-rank x
))))))
315 (sxhash (char-code x
)))) ; through DEFTRANSFORM
316 ;; general, inefficient case of NUMBER
317 (number (sxhash-number x
))
318 (generic-function (fsc-instance-hash x
))
320 (sxhash-recurse x
+max-hash-depthoid
+)))
322 ;;;; the PSXHASH function
324 ;;;; FIXME: This code does a lot of unnecessary full calls. It could be made
325 ;;;; more efficient (in both time and space) by rewriting it along the lines
326 ;;;; of the SXHASH code above.
328 ;;; like SXHASH, but for EQUALP hashing instead of EQUAL hashing
329 (defun psxhash (key &optional
(depthoid +max-hash-depthoid
+))
330 (declare (optimize speed
))
331 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
332 ;; Note: You might think it would be cleaner to use the ordering given in the
333 ;; table from Figure 5-13 in the EQUALP section of the ANSI specification
334 ;; here. So did I, but that is a snare for the unwary! Nothing in the ANSI
335 ;; spec says that HASH-TABLE can't be a STRUCTURE-OBJECT, and in fact our
336 ;; HASH-TABLEs *are* STRUCTURE-OBJECTs, so we need to pick off the special
337 ;; HASH-TABLE behavior before we fall through to the generic STRUCTURE-OBJECT
338 ;; comparison behavior.
340 (array (array-psxhash key depthoid
))
341 (hash-table (hash-table-psxhash key
))
342 (structure-object (structure-object-psxhash key depthoid
))
343 (cons (list-psxhash key depthoid
))
344 (number (number-psxhash key
))
345 (character (char-code (char-upcase key
)))
348 (defun array-psxhash (key depthoid
)
349 (declare (optimize speed
))
350 (declare (type array key
))
351 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
353 ;; VECTORs have to be treated specially because ANSI specifies
354 ;; that we must respect fill pointers.
357 '(let ((result 572539))
358 (declare (type fixnum result
))
359 (mixf result
(length key
))
360 (when (plusp depthoid
)
362 (dotimes (i (length key
))
363 (declare (type fixnum i
))
365 (psxhash (aref key i
) depthoid
))))
367 (make-dispatch (types)
369 ,@(loop for type in types
372 (make-dispatch (simple-base-string
373 (simple-array character
(*))
375 (simple-array (unsigned-byte 8) (*))
376 (simple-array fixnum
(*))
378 ;; Any other array can be hashed by working with its underlying
379 ;; one-dimensional physical representation.
381 (let ((result 60828))
382 (declare (type fixnum result
))
383 (dotimes (i (array-rank key
))
384 (mixf result
(array-dimension key i
)))
385 (when (plusp depthoid
)
387 (dotimes (i (array-total-size key
))
389 (psxhash (row-major-aref key i
) depthoid
))))
392 (defun structure-object-psxhash (key depthoid
)
393 (declare (optimize speed
))
394 (declare (type structure-object key
))
395 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
396 (let* ((layout (%instance-layout key
)) ; i.e. slot #0
397 ;; Is there some reason the name of the layout's classoid
398 ;; should be preferred as the seed, instead of using the CLOS-HASH
399 ;; just like SXHASH does?
400 (classoid (layout-classoid layout
))
401 (name (classoid-name classoid
))
402 (result (mix (sxhash name
) (the fixnum
79867))))
403 (declare (type fixnum result
))
404 (when (plusp depthoid
)
405 (let ((max-iterations depthoid
)
406 (depthoid (1- depthoid
)))
407 ;; We don't mix in LAYOUT here because it was already done above.
408 (do-instance-tagged-slot (i key
:layout layout
:pad nil
)
409 (mixf result
(psxhash (%instance-ref key i
) depthoid
))
410 (if (zerop (decf max-iterations
)) (return)))))
411 ;; [The following comment blurs some issues: indeed it would take
412 ;; a second loop in the non-interleaved-slots code; that loop might
413 ;; never execute because depthoid "cuts off", although that's an arbitrary
414 ;; choice and could be decided otherwise; and efficiency would likely
415 ;; demand that we store some additional metadata in the LAYOUT indicating
416 ;; how to mix the bits in, because floating-point +/-zeros have to
417 ;; be considered EQUALP]
418 ;; KLUDGE: Should hash untagged slots, too. (Although +max-hash-depthoid+
419 ;; is pretty low currently, so they might not make it into the hash
423 (defun list-psxhash (key depthoid
)
424 (declare (optimize speed
))
425 (declare (type list key
))
426 (declare (type (integer 0 #.
+max-hash-depthoid
+) depthoid
))
432 (mix (psxhash (car key
) (1- depthoid
))
433 (psxhash (cdr key
) (1- depthoid
))))))
435 (defun hash-table-psxhash (key)
436 (declare (optimize speed
))
437 (declare (type hash-table key
))
438 (let ((result 103924836))
439 (declare (type fixnum result
))
440 (mixf result
(hash-table-count key
))
441 (mixf result
(sxhash (hash-table-test key
)))
444 (defun number-psxhash (key)
445 (declare (type number key
)
447 (flet ((sxhash-double-float (val)
448 (declare (type double-float val
))
449 ;; FIXME: Check to make sure that the DEFTRANSFORM kicks in and the
450 ;; resulting code works without consing. (In Debian cmucl 2.4.17,
453 (macrolet ((hash-float (type key
)
454 (let ((lo (coerce sb
!xc
:most-negative-fixnum type
))
455 (hi (coerce sb
!xc
:most-positive-fixnum type
)))
457 (cond ( ;; This clause allows FIXNUM-sized integer
458 ;; values to be handled without consing.
460 (multiple-value-bind (q r
)
461 (floor (the (,type
,lo
,hi
) key
))
462 (if (zerop (the ,type r
))
465 (coerce key
'double-float
)))))
467 (multiple-value-bind (q r
) (floor key
)
468 (if (zerop (the ,type r
))
471 (coerce key
'double-float
)))))))))
472 (hash-complex (&optional
(hasher '(number-psxhash)))
473 `(if (zerop (imagpart key
))
474 (,@hasher
(realpart key
))
475 (let ((result 330231))
476 (declare (type fixnum result
))
477 (mixf result
(,@hasher
(realpart key
)))
478 (mixf result
(,@hasher
(imagpart key
)))
481 (integer (sxhash key
))
484 (single-float (hash-float single-float key
))
485 (double-float (hash-float double-float key
))
487 (long-float (error "LONG-FLOAT not currently supported")))))
488 (rational (if (and (<= most-negative-double-float
490 most-positive-double-float
)
491 (= (coerce key
'double-float
) key
))
492 (sxhash-double-float (coerce key
'double-float
))
494 ((complex double-float
)
495 (hash-complex (hash-float double-float
)))
496 ((complex single-float
)
497 (hash-complex (hash-float single-float
)))
501 ;;; Semantic equivalent of SXHASH, but better-behaved for function names.
502 ;;; It performs more work by not cutting off as soon in the CDR direction.
503 ;;; More work here equates to less work in the global hashtable.
504 ;;; To wit: (eq (sxhash '(foo a b c bar)) (sxhash '(foo a b c d))) => T
505 ;;; but the corresponding globaldb-sxhashoids differ.
506 (defun sb!c
::globaldb-sxhashoid
(name)
508 (declare (optimize (safety 0))) ; after the argc check
509 ;; TRAVERSE will walk across more cons cells than RECURSE will descend.
510 ;; That's why this isn't just one self-recursive function.
511 (labels ((traverse (accumulator x length-limit
)
512 (declare (fixnum length-limit
))
513 (cond ((atom x
) (mix (sxhash x
) accumulator
))
514 ((zerop length-limit
) accumulator
)
515 (t (traverse (mix (recurse (car x
) 4) accumulator
)
516 (cdr x
) (1- length-limit
)))))
517 (recurse (x depthoid
) ; depthoid = a blend of level and length
518 (declare (fixnum depthoid
))
519 (cond ((atom x
) (sxhash x
))
521 #.
(logand sb
!xc
:most-positive-fixnum
#36Rglobaldbsxhashoid
))
522 (t (mix (recurse (car x
) (1- depthoid
))
523 (recurse (cdr x
) (1- depthoid
)))))))
524 (traverse 0 name
10))))