Context Navigation

source: trunk/ccl/level-0/l0-hash.lisp @ 6918

Visit:

Last change on this file since 6918 was 6918, checked in by gb, 14 years ago
Try to defer GC locking in GETHASH. Some 64-bit key-scrambling stuff.
Property svn:eol-style set to `native` Property svn:keywords set to `Author Date Id Revision`
File size: 70.3 KB

Line
1	;;;-- Mode: Lisp; Package: CCL --
2	;;;
3	;;; Copyright (C) 1994-2001 Digitool, Inc
4	;;; This file is part of OpenMCL.
5	;;;
6	;;; OpenMCL is licensed under the terms of the Lisp Lesser GNU Public
7	;;; License , known as the LLGPL and distributed with OpenMCL as the
8	;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL,
9	;;; which is distributed with OpenMCL as the file "LGPL". Where these
10	;;; conflict, the preamble takes precedence.
11	;;;
12	;;; OpenMCL is referenced in the preamble as the "LIBRARY."
13	;;;
14	;;; The LLGPL is also available online at
15	;;; http://opensource.franz.com/preamble.html
16
17	(in-package "CCL")
18
19	;;;;;;;;;;;;;
20	;;
21	;; hash.lisp
22	;; New hash table implementation
23
24	;;;;;;;;;;;;;
25	;;
26	;; Things I didn't do
27	;;
28	;; Save the 32-bit hash code along with the key so that growing the table can
29	;; avoid calling the hashing function (at least until a GC happens during growing).
30	;;
31	;; Maybe use Knuth's better method for hashing:
32	;; find two primes N-2, N. N is the table size.
33	;; First probe is at primary = (mod (funcall (nhash.keytransF h) key) N)
34	;; Secondary probes are spaced by (mod (funcall (nhash.keytransF h) key) N-2)
35	;; This does a bit better scrambling of the secondary probes, but costs another divide.
36	;;
37	;; Rethink how finalization is reported to the user. Maybe have a finalization function which
38	;; is called with the hash table and the deleted key & value.
39
40
41	;;;;;;;;;;;;;
42	;;
43	;; Documentation
44	;;
45	;; MAKE-HASH-TABLE is extended to accept a :HASH-FUNCTION keyword arg which
46	;; defaults for the 4 Common Lisp defined :TEST's. Also, any fbound symbol can
47	;; be used for the :TEST argument. The HASH-FUNCTION is a function of one
48	;; argument, the key, which returns two values:
49	;;
50	;; 1) HASH-CODE
51	;; 2) ADDRESSP
52	;;
53	;; The HASH-CODE can be any object. If it is a relocateable object (not a
54	;; fixnum, short float, or immediate) then ADDRESSP will default to :KEY
55	;; and it is an error if NIL is returned for ADDRESSP.
56	;;
57	;; If ADDRESSP is NIL, the hashing code assumes that no addresses were used
58	;; in computing the HASH-CODE. If ADDRESSP is :KEY (which is the default
59	;; if the hash function returns only one value and it is relocateable) then
60	;; the hashing code assumes that only the KEY's address was used to compute
61	;; the HASH-CODE. Otherwise, it is assumed that the address of a
62	;; component of the key was used to compute the HASH-CODE.
63	;;
64	;;
65	;;
66	;; Some (proposed) functions for using in user hashing functions:
67	;;
68	;; (HASH-CODE object)
69	;;
70	;; returns two values:
71	;;
72	;; 1) HASH-CODE
73	;; 2) ADDRESSP
74	;;
75	;; HASH-CODE is the object transformed into a fixnum by changing its tag
76	;; bits to a fixnum's tag. ADDRESSP is true if the object was
77	;; relocateable.
78	;;
79	;;
80	;; (FIXNUM-ADD o1 o2)
81	;; Combines two objects additively and returns a fixnum.
82	;; If the two objects are fixnums, will be the same as (+ o1 o2) except
83	;; that the result can not be a bignum.
84	;;
85	;; (FIXNUM-MULTIPLY o1 o2)
86	;; Combines two objects multiplicatively and returns a fixnum.
87	;;
88	;; (FIXNUM-FLOOR dividend &optional divisor)
89	;; Same as Common Lisp's FLOOR function, but converts the objects into
90	;; fixnums before doing the divide and returns two fixnums: quotient &
91	;; remainder.
92	;;
93	;;;;;;;;;;;;;
94	;;
95	;; Implementation details.
96	;;
97	;; Hash table vectors have a header that the garbage collector knows about
98	;; followed by alternating keys and values. Empty or deleted slots are
99	;; denoted by a key of $undefined. Empty slots have a value of $undefined.
100	;; Deleted slots have a value of NIL.
101	;;
102	;;
103	;; Five bits in the nhash.vector.flags fixnum interact with the garbage
104	;; collector. This description uses the symbols that represent bit numbers
105	;; in a fixnum. $nhash_xxx_bit has a corresponding $nhash_lap_xxx_bit which
106	;; gives the byte offset of the bit for LAP code. The two bytes in
107	;; question are at offsets $nhash.vector-weak-byte and
108	;; $nhash.vector-track-keys-byte offsets from the tagged vector.
109	;; The 32 bits of the fixnum at nhash.vector.flags look like:
110	;;
111	;; TK0C0000 00000000 WVF00000 00000000
112	;;
113	;;
114	;; $nhash_track_keys_bit "T" in the diagram above
115	;; Sign bit of the longword at $nhash.vector.flags
116	;; or the byte at $nhash.vector-track-keys-byte.
117	;; If set, GC tracks relocation of keys in the
118	;; vector.
119	;; $nhash_key_moved_bit "K" in the diagram above
120	;; Set by GC to indicate that a key moved.
121	;; If $nhash_track_keys_bit is clear, this bit is set to
122	;; indicate that any GC will require a rehash.
123	;; GC never clears this bit, but may set it if
124	;; $nhash_track_keys_bit is set.
125	;; $nhash_component_address_bit "C" in the diagram above.
126	;; Ignored by GC. Set to indicate that the
127	;; address of a component of a key was used.
128	;; Means that $nhash_track_keys_bit will
129	;; never be set until all such keys are
130	;; removed.
131	;; $nhash_weak_bit "W" in the diagram above
132	;; Sign bit of the byte at $nhash.vector-weak-byte
133	;; Set to indicate a weak hash table
134	;; $nhash_weak_value_bit "V" in the diagram above
135	;; If clear, the table is weak on key
136	;; If set, the table is weak on value
137	;; $nhash_finalizeable_bit "F" in the diagram above
138	;; If set the table is finalizeable:
139	;; If any key/value pairs are removed, they will be added to
140	;; the nhash.vector.finalization-alist using cons cells
141	;; from nhash.vector.free-alist
142
143
144
145
146
147	(eval-when (:compile-toplevel :execute)
148	(require "HASHENV" "ccl:xdump;hashenv")
149	(require :number-case-macro)
150	(define-symbol-macro free-hash-key-marker (%unbound-marker))
151	(define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker))
152	(declaim (inline nhash.vector-size))
153	(declaim (inline mixup-hash-code))
154	(declaim (inline hash-table-p))
155	(declaim (inline %%eqhash))
156	(declaim (inline index->vector-index vector-index->index swap))
157	(declaim (inline %already-rehashed-p %set-already-rehashed-p))
158	(declaim (inline need-use-eql))
159	(declaim (inline %needs-rehashing-p))
160	(declaim (inline compute-hash-code))
161	(declaim (inline eq-hash-find eq-hash-find-for-put))
162	(declaim (inline lock-hash-table unlock-hash-table)))
163
164	(defun %cons-hash-table (rehash-function keytrans-function compare-function vector
165	threshold rehash-ratio rehash-size address-based find find-new owner)
166	(%istruct
167	'HASH-TABLE ; type
168	rehash-function ; nhash.rehashF
169	keytrans-function ; nhash.keytransF
170	compare-function ; nhash.compareF
171	nil ; nhash.rehash-bits
172	vector ; nhash.vector
173	0 ; nhash.lock
174	0 ; nhash.count
175	owner ; nhash.owner
176	(get-fwdnum) ; nhash.fixnum
177	(gc-count) ; nhash.gc-count
178	threshold ; nhash.grow-threshold
179	rehash-ratio ; nhash.rehash-ratio
180	rehash-size ; nhash.rehash-size
181	0 ; nhash.puthash-count
182	(unless owner
183	(make-read-write-lock)) ; nhash.exclusion-lock
184	nil ;;(make-lock) ; nhash.rehash-lock
185	nil ; nhash.iterator
186	address-based ; nhash.address-based
187	find ; nhash.find
188	find-new ; nhash.find-new
189	))
190
191
192
193	(defun nhash.vector-size (vector)
194	(ash (the fixnum (- (the fixnum (uvsize vector)) $nhash.vector_overhead)) -1))
195
196	;;; Is KEY something which can be EQL to something it's not EQ to ?
197	;;; (e.g., is it a number or macptr ?)
198	;;; This can be more general than necessary but shouldn't be less so.
199	(defun need-use-eql (key)
200	(let* ((typecode (typecode key)))
201	(declare (fixnum typecode))
202	(or (= typecode target::subtag-macptr)
203	#+ppc32-target
204	(and (>= typecode ppc32::min-numeric-subtag)
205	(<= typecode ppc32::max-numeric-subtag))
206	#+64-bit-target
207	(or (= typecode target::subtag-bignum)
208	(= typecode target::subtag-double-float)
209	(= typecode target::subtag-ratio)
210	(= typecode target::subtag-complex)))))
211
212	;;; Don't rehash at all, unless some key is address-based (directly or
213	;;; indirectly.)
214	(defun %needs-rehashing-p (hash)
215	(let ((flags (nhash.vector.flags (nhash.vector hash))))
216	(declare (fixnum flags))
217	(if (logbitp $nhash_track_keys_bit flags)
218	;; GC is tracking key movement
219	(logbitp $nhash_key_moved_bit flags)
220	;; GC is not tracking key movement
221	(if (logbitp $nhash_component_address_bit flags)
222	(not (eql (the fixnum (gc-count)) (the fixnum (nhash.gc-count hash))))))))
223
224	(defun %set-does-not-need-rehashing (hash)
225	(get-fwdnum hash)
226	(gc-count hash)
227	(let* ((vector (nhash.vector hash))
228	(flags (nhash.vector.flags vector)))
229	(declare (fixnum flags))
230	(when (logbitp $nhash_track_keys_bit flags)
231	(setf (nhash.vector.flags vector)
232	(logand (lognot (ash 1 $nhash_key_moved_bit)) flags)))))
233
234
235	;;; Tempting though it may be to remove this, a hash table loaded from
236	;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM
237	;;; for hash tables needs to be able to call this or something similar.
238	(defun %set-needs-rehashing (hash)
239	(setf (nhash.fixnum hash) (the fixnum (1- (the fixnum (get-fwdnum))))
240	(nhash.gc-count hash) (the fixnum (1- (the fixnum (gc-count)))))
241	(let* ((vector (nhash.vector hash))
242	(flags (nhash.vector.flags vector)))
243	(declare (fixnum flags))
244	(when (logbitp $nhash_track_keys_bit flags)
245	(setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags)))))
246
247	#+32-bit-target
248	(defun mixup-hash-code (fixnum)
249	(declare (fixnum fixnum))
250	(the fixnum
251	(+ fixnum
252	(the fixnum (%ilsl (- 32 8)
253	(logand (1- (ash 1 (- 8 3))) fixnum))))))
254
255	#+64-bit-target
256	(defun mixup-hash-code (fixnum)
257	(declare (fixnum fixnum))
258	(the fixnum
259	(+ fixnum
260	(the fixnum (%ilsl 50
261	(logand (1- (ash 1 (- 8 3))) fixnum))))))
262
263
264	(defun rotate-hash-code (fixnum)
265	(declare (fixnum fixnum))
266	(let* ((low-3 (logand 7 fixnum))
267	(but-low-3 (%ilsr 3 fixnum))
268	(low-3*64K (%ilsl 13 low-3))
269	(low-3-in-high-3 (%ilsl (- 32 3 3) low-3)))
270	(declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3))
271	(the fixnum (+ low-3-in-high-3
272	(the fixnum (logxor low-3*64K but-low-3))))))
273
274
275
276
277	(defconstant $nhash-track-keys-mask
278	#.(- (ash 1 $nhash_track_keys_bit)))
279
280	(defconstant $nhash-clear-key-bits-mask #xfffff)
281
282
283	;;; Hash on address, or at least on some persistent, immutable
284	;;; attribute of the key. If all keys are fixnums or immediates (or if
285	;;; that attribute exists), rehashing won't ever be necessary.
286	(defun %%eqhash (key)
287	(let* ((typecode (typecode key)))
288	(if (eq typecode target::tag-fixnum)
289	(values (mixup-hash-code key) nil)
290	(if (eq typecode target::subtag-instance)
291	(values (mixup-hash-code (instance.hash key)) nil)
292	(if (symbolp key)
293	(let* ((name (if key (%svref (symptr->symvector key) target::symbol.pname-cell) "NIL")))
294	(values (mixup-hash-code (%pname-hash name (length name))) nil))
295	(let ((hash (mixup-hash-code (strip-tag-to-fixnum key))))
296	(if (immediate-p-macro key)
297	(values hash nil)
298	(values hash :key ))))))))
299
300
301	#+32-bit-target
302	(defun swap (num)
303	(declare (fixnum num))
304	(the fixnum (+ (the fixnum (%ilsl 16 num))(the fixnum (%ilsr 13 num)))))
305
306	#+64-bit-target
307	(defun swap (num)
308	(declare (fixnum num))
309	(the fixnum (+ (the fixnum (%ilsl 32 num))(the fixnum (%ilsr 29 num)))))
310
311	;;; teeny bit faster when nothing to do
312	(defun %%eqlhash-internal (key)
313	(number-case key
314	(fixnum (mixup-hash-code key)) ; added this
315	(double-float (%dfloat-hash key))
316	(short-float (%sfloat-hash key))
317	(bignum (%bignum-hash key))
318	(ratio (logxor (swap (%%eqlhash-internal (numerator key)))
319	(%%eqlhash-internal (denominator key))))
320	(complex
321	(logxor (swap (%%eqlhash-internal (realpart key)))
322	(%%eqlhash-internal (imagpart key))))
323	(t (cond ((macptrp key)
324	(%macptr-hash key))
325	(t key)))))
326
327
328
329
330	;;; new function
331
332	(defun %%eqlhash (key)
333	;; if key is a macptr, float, bignum, ratio, or complex, convert it
334	;; to a fixnum
335	(if (hashed-by-identity key)
336	(%%eqhash key)
337	(let ((primary (%%eqlhash-internal key)))
338	(if (eq primary key)
339	(%%eqhash key)
340	(mixup-hash-code (strip-tag-to-fixnum primary))))))
341
342	;; call %%eqlhash
343
344	(defun string-hash (key start len)
345	(declare (fixnum start len))
346	(let* ((res len))
347	(dotimes (i len)
348	(let ((code (%scharcode key (%i+ i start))))
349	(setq code (mixup-hash-code code))
350	(setq res (%i+ (rotate-hash-code res) code))))
351	res))
352
353
354
355	(defun %%equalhash (key)
356	(let* ((id-p (hashed-by-identity key))
357	(hash (if (and key (not id-p)) (%%eqlhash-internal key)))
358	addressp)
359	(cond ((null key) (mixup-hash-code 17))
360	#+64-bit-target
361	((and (typep key 'single-float)
362	(zerop (the single-float key)))
363	0)
364	((immediate-p-macro key) (mixup-hash-code (strip-tag-to-fixnum key)))
365	((and hash (neq hash key)) hash) ; eql stuff
366	(t (typecase key
367	(simple-string (string-hash key 0 (length key)))
368	(string
369	(let ((length (length key)))
370	(multiple-value-bind (data offset) (array-data-and-offset key)
371	(string-hash data offset length))))
372	(bit-vector (bit-vector-hash key))
373	(cons
374	(let ((hash 0))
375	(do* ((i 0 (1+ i))
376	(list key (cdr list)))
377	((or (not (consp list)) (> i 11))) ; who figured 11?
378	(declare (fixnum i))
379	(multiple-value-bind (h1 a1) (%%equalhash (%car list))
380	(when a1 (setq addressp t))
381	; fix the case of lists of same stuff in different order
382	;(setq hash (%ilogxor (fixnum-rotate h1 i) hash))
383	(setq hash (%i+ (rotate-hash-code hash) h1))
384	))
385	(values hash addressp)))
386	(pathname (%%equalphash key))
387	(t (%%eqlhash key)))))))
388
389	(defun compute-hash-code (hash key update-hash-flags &optional
390	(vector (nhash.vector hash))) ; vectorp))
391	(let ((keytransF (nhash.keytransF hash))
392	primary addressp)
393	(if (not (fixnump keytransF))
394	;; not EQ or EQL hash table
395	(progn
396	(multiple-value-setq (primary addressp) (funcall keytransF key))
397	(let ((immediate-p (immediate-p-macro primary)))
398	(setq primary (strip-tag-to-fixnum primary))
399	(unless immediate-p
400	(setq primary (mixup-hash-code primary))
401	(setq addressp :key))))
402	;; EQ or EQL hash table
403	(if (and (not (eql keytransF 0))
404	(need-use-eql key))
405	;; EQL hash table
406	(setq primary (%%eqlhash-internal key))
407	;; EQ hash table - or something eql doesn't do
408	(multiple-value-setq (primary addressp) (%%eqhash key))))
409	(when addressp
410	(when update-hash-flags
411	(let ((flags (nhash.vector.flags vector)))
412	(declare (fixnum flags))
413	(if (eq :key addressp)
414	;; hash code depended on key's address
415	(unless (logbitp $nhash_component_address_bit flags)
416	(when (not (logbitp $nhash_track_keys_bit flags))
417	(setq flags (bitclr $nhash_key_moved_bit flags)))
418	(setq flags (logior $nhash-track-keys-mask flags)))
419	;; hash code depended on component address
420	(progn
421	(setq flags (logand (lognot $nhash-track-keys-mask) flags))
422	(setq flags (bitset $nhash_component_address_bit flags))))
423	(setf (nhash.vector.flags vector) flags))))
424	(let* ((length (- (the fixnum (uvsize vector)) $nhash.vector_overhead))
425	(entries (ash length -1)))
426	(declare (fixnum length entries))
427	(values primary
428	(fast-mod primary entries)
429	entries))))
430
431	(defun %already-rehashed-p (primary rehash-bits)
432	(declare (optimize (speed 3)(safety 0)))
433	(declare (type (simple-array bit (*)) rehash-bits))
434	(eql 1 (sbit rehash-bits primary)))
435
436	(defun %set-already-rehashed-p (primary rehash-bits)
437	(declare (optimize (speed 3)(safety 0)))
438	(declare (type (simple-array bit (*)) rehash-bits))
439	(setf (sbit rehash-bits primary) 1))
440
441
442	(defun hash-table-p (hash)
443	(istruct-typep hash 'hash-table))
444
445	(defun %normalize-hash-table-count (hash)
446	(let* ((vector (nhash.vector hash))
447	(weak-deletions-count (nhash.vector.weak-deletions-count vector)))
448	(declare (fixnum weak-deletions-count))
449	(unless (eql 0 weak-deletions-count)
450	(setf (nhash.vector.weak-deletions-count vector) 0)
451	(let ((deleted-count (the fixnum
452	(+ (the fixnum (nhash.vector.deleted-count vector))
453	weak-deletions-count)))
454	(count (the fixnum (- (the fixnum (nhash.count hash)) weak-deletions-count))))
455	(setf (nhash.vector.deleted-count vector) deleted-count
456	(nhash.count hash) count)))))
457
458
459	(defparameter shared-hash-table-default t
460	"Be sure that you understand the implications of changing this
461	before doing so.")
462
463	(defun make-hash-table (&key (test 'eql)
464	(size 60)
465	(rehash-size 1.5)
466	(rehash-threshold .85)
467	(hash-function nil)
468	(weak nil)
469	(finalizeable nil)
470	(address-based t)
471	(shared shared-hash-table-default))
472	"Create and return a new hash table. The keywords are as follows:
473	:TEST -- Indicates what kind of test to use.
474	:SIZE -- A hint as to how many elements will be put in this hash
475	table.
476	:REHASH-SIZE -- Indicates how to expand the table when it fills up.
477	If an integer, add space for that many elements. If a floating
478	point number (which must be greater than 1.0), multiply the size
479	by that amount.
480	:REHASH-THRESHOLD -- Indicates how dense the table can become before
481	forcing a rehash. Can be any positive number <=1, with density
482	approaching zero as the threshold approaches 0. Density 1 means an
483	average of one entry per bucket."
484	(unless (and test (or (functionp test) (symbolp test)))
485	(report-bad-arg test '(and (not null) (or symbol function))))
486	(unless (or (functionp hash-function) (symbolp hash-function))
487	(report-bad-arg hash-function '(or symbol function)))
488	(unless (and (realp rehash-threshold) (<= 0.0 rehash-threshold) (<= rehash-threshold 1.0))
489	(report-bad-arg rehash-threshold '(real 0 1)))
490	(unless (or (fixnump rehash-size) (and (realp rehash-size) (< 1.0 rehash-size)))
491	(report-bad-arg rehash-size '(or fixnum (real 1 *))))
492	(unless (fixnump size) (report-bad-arg size 'fixnum))
493	(setq rehash-threshold (/ 1.0 (max 0.01 rehash-threshold)))
494	(let* ((default-hash-function
495	(cond ((or (eq test 'eq) (eq test #'eq))
496	(setq test 0))
497	((or (eq test 'eql) (eq test #'eql))
498	(setq test -1))
499	((or (eq test 'equal) (eq test #'equal))
500	(setq test #'equal) #'%%equalhash)
501	((or (eq test 'equalp) (eq test #'equalp))
502	(setq test #'equalp) #'%%equalphash)
503	(t (setq test (require-type test 'symbol))
504	(or hash-function
505	(error "non-standard test specified without hash-function")))))
506	(find-function
507	(case test
508	(0 #'eq-hash-find)
509	(-1 #'eql-hash-find)
510	(t #'general-hash-find)))
511	(find-put-function
512	(case test
513	(0 #'eq-hash-find-for-put)
514	(-1 #'eql-hash-find-for-put)
515	(t #'general-hash-find-for-put))))
516	(setq hash-function
517	(if hash-function
518	(require-type hash-function 'symbol)
519	default-hash-function))
520	(when (and weak (neq weak :value) (neq test 0))
521	(error "Only EQ hash tables can be weak."))
522	(when (and finalizeable (not weak))
523	(error "Only weak hash tables can be finalizeable."))
524	(multiple-value-bind (size total-size)
525	(compute-hash-size (1- size) 1 rehash-threshold)
526	(let* ((flags (if weak
527	(+ (+
528	(ash 1 $nhash_weak_bit)
529	(ecase weak
530	((t :key) 0)
531	(:value (ash 1 $nhash_weak_value_bit))))
532	(if finalizeable (ash 1 $nhash_finalizeable_bit) 0))
533	0))
534	(hash (%cons-hash-table
535	#'%no-rehash hash-function test
536	(%cons-nhash-vector total-size flags)
537	size rehash-threshold rehash-size address-based
538	find-function find-put-function
539	(unless shared current-process))))
540	(setf (nhash.vector.hash (nhash.vector hash)) hash)
541	hash))))
542
543	(defun compute-hash-size (size rehash-size rehash-ratio)
544	(let* ((new-size size))
545	(setq new-size (max 30 (if (fixnump rehash-size)
546	(+ size rehash-size)
547	(ceiling (* size rehash-size)))))
548	(if (<= new-size size)
549	(setq new-size (1+ size))) ; God save you if you make this happen
550
551	(values new-size
552	(%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio)))))))
553
554	;;; Suggested size is a fixnum: number of pairs. Return a fixnum >=
555	;;; that size that is relatively prime to all secondary keys.
556	(defun %hash-size (suggestion)
557	(declare (fixnum suggestion))
558	(declare (optimize (speed 3)(safety 0)))
559	(if (<= suggestion #.(aref secondary-keys 7))
560	(setq suggestion (+ 2 #.(aref secondary-keys 7)))
561	(setq suggestion (logior 1 suggestion)))
562	(loop
563	(dovector (key secondary-keys (return-from %hash-size suggestion))
564	(when (eql 0 (fast-mod suggestion key))
565	(return)))
566	(incf suggestion 2)))
567
568
569
570
571
572
573
574	;;; what if somebody is mapping, growing, rehashing?
575	(defun clrhash (hash)
576	"This removes all the entries from HASH-TABLE and returns the hash table
577	itself."
578	(unless (hash-table-p hash)
579	(report-bad-arg hash 'hash-table))
580	(without-interrupts
581	(lock-hash-table hash)
582	(let* ((vector (nhash.vector hash))
583	(size (nhash.vector-size vector))
584	(count (+ size size))
585	(index $nhash.vector_overhead))
586	(declare (fixnum size count index))
587	(dotimes (i count)
588	(setf (%svref vector index) (%unbound-marker))
589	(incf index))
590	(incf (the fixnum (nhash.grow-threshold hash))
591	(the fixnum (+ (the fixnum (nhash.count hash))
592	(the fixnum (nhash.vector.deleted-count vector)))))
593	(setf (nhash.count hash) 0
594	(nhash.vector.cache-key vector) (%unbound-marker)
595	(nhash.vector.cache-value vector) nil
596	(nhash.vector.finalization-alist vector) nil
597	(nhash.vector.free-alist vector) nil
598	(nhash.vector.weak-deletions-count vector) 0
599	(nhash.vector.deleted-count vector) 0
600	(nhash.vector.flags vector) (logand $nhash_weak_flags_mask
601	(nhash.vector.flags vector))))
602	(unlock-hash-table hash)
603	hash))
604
605	(defun index->vector-index (index)
606	(declare (fixnum index))
607	(the fixnum (+ $nhash.vector_overhead (the fixnum (+ index index)))))
608
609	(defun vector-index->index (index)
610	(declare (fixnum index))
611	(the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1)))
612
613
614	(defun hash-table-count (hash)
615	"Return the number of entries in the given HASH-TABLE."
616	(require-type hash 'hash-table)
617	(%normalize-hash-table-count hash)
618	(the fixnum (nhash.count hash)))
619
620	(defun hash-table-rehash-size (hash)
621	"Return the rehash-size HASH-TABLE was created with."
622	(nhash.rehash-size (require-type hash 'hash-table)))
623
624	(defun hash-table-rehash-threshold (hash)
625	"Return the rehash-threshold HASH-TABLE was created with."
626	(/ 1.0 (nhash.rehash-ratio (require-type hash 'hash-table))))
627
628	(defun hash-table-size (hash)
629	"Return a size that can be used with MAKE-HASH-TABLE to create a hash
630	table that can hold however many entries HASH-TABLE can hold without
631	having to be grown."
632	(%i+ (the fixnum (hash-table-count hash))
633	(the fixnum (nhash.grow-threshold hash))
634	(the fixnum (nhash.vector.deleted-count (nhash.vector hash)))))
635
636	(defun hash-table-test (hash)
637	"Return the test HASH-TABLE was created with."
638	(let ((f (nhash.compareF (require-type hash 'hash-table))))
639	(if (fixnump f)
640	(if (eql 0 f) 'eq 'eql)
641	(let ((name (if (symbolp f) f (function-name f))))
642	(if (memq name '(equal equalp)) name f)))))
643
644	;;; sometimes you'd rather have the function than the symbol.
645	(defun hash-table-test-function (hash)
646	(let ((f (nhash.compareF (require-type hash 'hash-table))))
647	(if (fixnump f)
648	(if (eql 0 f) #'eq #'eql)
649	f)))
650
651	;; Finalization-list accessors are in "ccl:lib;hash" because SETF functions
652	;; don't get dumped as "simple" %defuns.
653	;;
654
655
656	(defun lock-hash-table (hash)
657	(let* ((lock (nhash.exclusion-lock hash)))
658	(if lock
659	(write-lock-rwlock lock)
660	(progn (unless (eq (nhash.owner hash) current-process)
661	(error "Not owner of hash table ~s" hash))))))
662
663	(defun unlock-hash-table (hash)
664	(let* ((lock (nhash.exclusion-lock hash)))
665	(if lock
666	(unlock-rwlock lock))))
667
668	(defun gethash (key hash &optional default)
669	"Finds the entry in HASH-TABLE whose key is KEY and returns the associated
670	value and T as multiple values, or returns DEFAULT and NIL if there is no
671	such entry. Entries can be added using SETF."
672	(unless (hash-table-p hash)
673	(report-bad-arg hash 'hash-table))
674	(let* ((value nil)
675	(vector-key nil)
676	(gc-locked nil)
677	(foundp nil))
678	(without-interrupts
679	(lock-hash-table hash)
680	(let* ((vector (nhash.vector hash)))
681	(if (and (eq key (nhash.vector.cache-key vector))
682	;; Check twice: the GC might nuke the cached key/value pair
683	(progn (setq value (nhash.vector.cache-value vector))
684	(eq key (nhash.vector.cache-key vector))))
685	(setq foundp t)
686	(loop
687	(let* ((vector-index (funcall (nhash.find hash) hash key)))
688	(declare (fixnum vector-index))
689	;; Referencing both key and value here - and referencing
690	;; value first - is an attempt to compensate for the
691	;; possibility that the GC deletes a weak-on-key pair.
692	(setq value (%svref vector (the fixnum (1+ vector-index)))
693	vector-key (%svref vector vector-index))
694	(cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
695	(not (eq vector-key deleted-hash-key-marker))))
696	(setf (nhash.vector.cache-key vector) vector-key
697	(nhash.vector.cache-value vector) value
698	(nhash.vector.cache-idx vector) (vector-index->index
699	vector-index))
700	(return))
701	((%needs-rehashing-p hash)
702	(setq gc-locked t)
703	(%lock-gc-lock)
704	(%rehash hash))
705	(t (return)))))))
706	(when gc-locked (%unlock-gc-lock))
707	(unlock-hash-table hash))
708	(if foundp
709	(values value t)
710	(values default nil))))
711
712	(defun remhash (key hash)
713	"Remove the entry in HASH-TABLE associated with KEY. Return T if there
714	was such an entry, or NIL if not."
715	(unless (hash-table-p hash)
716	(setq hash (require-type hash 'hash-table)))
717	(let* ((foundp nil))
718	(without-interrupts
719	(lock-hash-table hash)
720	(%lock-gc-lock)
721	(when (%needs-rehashing-p hash)
722	(%rehash hash))
723	(let* ((vector (nhash.vector hash)))
724	(if (eq key (nhash.vector.cache-key vector))
725	(progn
726	(do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
727	((null iterator))
728	(unless (= (the fixnum (hti.index iterator))
729	(the fixnum (nhash.vector.cache-idx vector)))
730	(unlock-hash-table hash)
731	(%unlock-gc-lock)
732	(error "Can't remove key ~s during iteration on hash-table ~s"
733	key hash)))
734	(setf (nhash.vector.cache-key vector) free-hash-key-marker
735	(nhash.vector.cache-value vector) nil)
736	(let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
737	(setf (%svref vector vidx) deleted-hash-key-marker)
738	(setf (%svref vector (the fixnum (1+ vidx))) nil))
739	(incf (the fixnum (nhash.vector.deleted-count vector)))
740	(decf (the fixnum (nhash.count hash)))
741	(setq foundp t))
742	(let* ((vector-index (funcall (nhash.find hash) hash key))
743	(vector-key (%svref vector vector-index)))
744	(declare (fixnum vector-index))
745	(when (setq foundp (and (not (eq vector-key free-hash-key-marker))
746	(not (eq vector-key deleted-hash-key-marker))))
747	(do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
748	((null iterator))
749	(unless (= (the fixnum (hti.index iterator))
750	(the fixnum (vector-index->index vector-index)))
751	(unlock-hash-table hash)
752	(%unlock-gc-lock)
753	(error "Can't remove key ~s during iteration on hash-table ~s"
754	key hash)))
755	;; always clear the cache cause I'm too lazy to call the
756	;; comparison function and don't want to keep a possibly
757	;; deleted key from being GC'd
758	(setf (nhash.vector.cache-key vector) free-hash-key-marker
759	(nhash.vector.cache-value vector) nil)
760	;; Update the count
761	(incf (the fixnum (nhash.vector.deleted-count vector)))
762	(decf (the fixnum (nhash.count hash)))
763	;; Remove a cons from the free-alist if the table is finalizeable
764	(when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector))
765	(pop (the list (svref nhash.vector.free-alist vector))))
766	;; Delete the value from the table.
767	(setf (%svref vector vector-index) deleted-hash-key-marker
768	(%svref vector (the fixnum (1+ vector-index))) nil))))
769	(when (and foundp
770	(zerop (the fixnum (nhash.count hash))))
771	(do* ((i $nhash.vector_overhead (1+ i))
772	(n (uvsize vector)))
773	((= i n))
774	(declare (fixnum i n))
775	(setf (%svref vector i) free-hash-key-marker))
776	(setf (nhash.grow-threshold hash)
777	(+ (nhash.vector.deleted-count vector)
778	(nhash.vector.weak-deletions-count vector)
779	(nhash.grow-threshold hash))
780	(nhash.vector.deleted-count vector) 0
781	(nhash.vector.weak-deletions-count vector) 0)))
782	;; Return T if we deleted something
783	(%unlock-gc-lock)
784	(unlock-hash-table hash))
785	foundp))
786
787	(defun puthash (key hash default &optional (value default))
788	(declare (optimize (speed 3) (space 0)))
789	(unless (hash-table-p hash)
790	(report-bad-arg hash 'hash-table))
791	(without-interrupts
792	(block protected
793	(tagbody
794	(lock-hash-table hash)
795	AGAIN
796	(%lock-gc-lock)
797	(when (%needs-rehashing-p hash)
798	(%rehash hash))
799	(do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
800	((null iterator))
801	(let* ((vector (hti.vector iterator))
802	(index (index->vector-index (hti.index iterator)))
803	(test (hash-table-test hash)))
804	(declare (fixnum index))
805	(when (and (< index (the fixnum (uvsize vector)))
806	(not (funcall test (%svref vector index) key)))
807	(unlock-hash-table hash)
808	(%unlock-gc-lock)
809	(error "Can't add key ~s during iteration on hash-table ~s"
810	key hash))))
811	(let ((vector (nhash.vector hash)))
812	(when (eq key (nhash.vector.cache-key vector))
813	(let* ((idx (nhash.vector.cache-idx vector)))
814	(declare (fixnum idx))
815	(setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
816	value)
817	(setf (nhash.vector.cache-value vector) value)
818	(return-from protected)))
819	(let* ((vector-index (funcall (nhash.find-new hash) hash key))
820	(old-value (%svref vector vector-index)))
821	(declare (fixnum vector-index))
822
823	(cond ((eq old-value deleted-hash-key-marker)
824	(%set-hash-table-vector-key vector vector-index key)
825	(setf (%svref vector (the fixnum (1+ vector-index))) value)
826	(setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
827	;; Adjust deleted-count
828	(when (> 0 (the fixnum
829	(decf (the fixnum
830	(nhash.vector.deleted-count vector)))))
831	(let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
832	(declare (fixnum weak-deletions))
833	(setf (nhash.vector.weak-deletions-count vector) 0)
834	(incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
835	(decf (the fixnum (nhash.count hash)) weak-deletions))))
836	((eq old-value free-hash-key-marker)
837	(when (eql 0 (nhash.grow-threshold hash))
838	(%unlock-gc-lock)
839	(grow-hash-table hash)
840	(go AGAIN))
841	(%set-hash-table-vector-key vector vector-index key)
842	(setf (%svref vector (the fixnum (1+ vector-index))) value)
843	(decf (the fixnum (nhash.grow-threshold hash)))
844	(incf (the fixnum (nhash.count hash))))
845	(t
846	;; Key was already there, update value.
847	(setf (%svref vector (the fixnum (1+ vector-index))) value)))
848	(setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
849	(nhash.vector.cache-key vector) key
850	(nhash.vector.cache-value vector) value)))))
851	(%unlock-gc-lock)
852	(unlock-hash-table hash))
853	value)
854
855
856	(defun count-entries (hash)
857	(let* ((vector (nhash.vector hash))
858	(size (uvsize vector))
859	(idx $nhash.vector_overhead)
860	(count 0))
861	(loop
862	(when (neq (%svref vector idx) (%unbound-marker))
863	(incf count))
864	(when (>= (setq idx (+ idx 2)) size)
865	(return count)))))
866
867
868
869
870
871
872
873	(defun grow-hash-table (hash)
874	(unless (hash-table-p hash)
875	(setq hash (require-type hash 'hash-table)))
876	(%grow-hash-table hash))
877
878	;;; Interrupts are disabled, and the caller has an exclusive
879	;;; lock on the hash table.
880	(defun %grow-hash-table (hash)
881	(block grow-hash-table
882	(%normalize-hash-table-count hash)
883	(let* ((old-vector (nhash.vector hash))
884	(old-size (nhash.count hash))
885	(old-total-size (nhash.vector-size old-vector))
886	(flags 0)
887	(flags-sans-weak 0)
888	(weak-flags)
889	rehashF)
890	(declare (fixnum old-total-size flags flags-sans-weak weak-flags))
891	; well we knew lock was 0 when we called this - is it still 0?
892	(when (> (nhash.vector.deleted-count old-vector) 0)
893	;; There are enough deleted entries. Rehash to get rid of them
894	(%rehash hash)
895	(return-from grow-hash-table))
896	(multiple-value-bind (size total-size)
897	(compute-hash-size
898	old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash))
899	(unless (eql 0 (nhash.grow-threshold hash)) ; maybe it's done already - shouldnt happen
900	(return-from grow-hash-table ))
901	(progn
902	(unwind-protect
903	(let ((fwdnum (get-fwdnum))
904	(gc-count (gc-count))
905	vector)
906	(setq flags (nhash.vector.flags old-vector)
907	flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask))
908	weak-flags (logand flags $nhash_weak_flags_mask)
909	rehashF (nhash.rehashF hash))
910	(setf (nhash.lock hash) (%ilogior (nhash.lock hash) $nhash.lock-while-growing) ; dont need
911	(nhash.rehashF hash) #'%am-growing
912	(nhash.vector.flags old-vector) flags-sans-weak) ; disable GC weak stuff
913	(%normalize-hash-table-count hash)
914	(setq vector (%cons-nhash-vector total-size 0))
915	(do* ((index 0 (1+ index))
916	(vector-index (index->vector-index 0) (+ vector-index 2)))
917	((>= index old-total-size))
918	(declare (fixnum index vector-index))
919
920	(let ((key (%svref old-vector vector-index)))
921	(unless (or (eq key free-hash-key-marker)
922	(eq key deleted-hash-key-marker))
923	(let* ((new-index (%growhash-probe vector hash key))
924	(new-vector-index (index->vector-index new-index)))
925	(setf (%svref vector new-vector-index) key)
926	(setf (%svref vector (the fixnum (1+ new-vector-index)))
927	(%svref old-vector (the fixnum (1+ vector-index))))))))
928	(progn
929	(setf (nhash.vector.finalization-alist vector)
930	(nhash.vector.finalization-alist old-vector)
931	(nhash.vector.free-alist vector)
932	(nhash.vector.free-alist old-vector)
933	(nhash.vector.flags vector)
934	(logior weak-flags (the fixnum (nhash.vector.flags vector))))
935	(setf (nhash.rehash-bits hash) nil
936	(nhash.vector hash) vector
937	(nhash.vector.hash vector) hash
938	(nhash.vector.cache-key vector) (%unbound-marker)
939	(nhash.vector.cache-value vector) nil
940	(nhash.fixnum hash) fwdnum
941	(nhash.gc-count hash) gc-count
942	(nhash.grow-threshold hash) (- size (nhash.count hash)))
943	(when (eq #'%am-growing (nhash.rehashF hash))
944	;; if not changed to %maybe-rehash then contains no address based keys
945	(setf (nhash.rehashf hash) #'%no-rehash))
946	(setq rehashF nil) ; tell clean-up form we finished the loop
947	(when (neq old-size (nhash.count hash))
948	(cerror "xx" "Somebody messed with count while growing")
949	(return-from grow-hash-table (grow-hash-table hash )))
950	(when (minusp (nhash.grow-threshold hash))
951	(cerror "nn" "negative grow-threshold ~S ~s ~s ~s"
952	(nhash.grow-threshold hash) size total-size old-size))
953	;; If the old vector's in some static heap, zero it
954	;; so that less garbage is retained.
955	(%init-misc 0 old-vector)))
956	(when rehashF
957	(setf (nhash.rehashF hash) rehashF
958	(nhash.vector.flags old-vector)
959	(logior weak-flags (the fixnum (nhash.vector.flags old-vector)))))))))))
960
961
962
963	;;; values of nhash.rehashF
964	;;; %no-rehash - do nothing
965	;;; %maybe-rehash - if doesnt need rehashing - if is rehashing 0 else nil
966	; if locked 0
967	; else rehash, return t
968	;;; %am-rehashing - 0
969	;;; %am-growing - calls %maybe-rehash
970
971	;;; compute-hash-code funcalls it if addressp and maybe-rehash-p
972	;;; sets to maybe-rehash if addressp and update-maybe-rehash (ie from puthash)
973	;;; grow-hash-table sets to %am-growing when doing so, resets to original value when done
974	;;; rehash sets to %am-rehashing, then to original when done
975
976	(defun %no-rehash (hash)
977	(declare (%noforcestk)
978	(optimize (speed 3) (safety 0))
979	(ignore hash))
980	nil)
981
982	(defun %maybe-rehash (hash)
983	(declare (optimize (speed 3) (safety 0)))
984	(cond ((not (%needs-rehashing-p hash))
985	nil)
986	(t (loop
987	(%rehash hash)
988	(unless (%needs-rehashing-p hash)
989	(return))
990	;(incf n3)
991	)
992	t)))
993
994	(defun %am-rehashing (hash)
995	(declare (optimize (speed 3) (safety 0))
996	(ignore hash))
997	0)
998
999	(defun %am-growing (hash)
1000	(declare (optimize (speed 3) (safety 0)))
1001	(%maybe-rehash hash))
1002
1003	(defun general-hash-find (hash key)
1004	(%hash-probe hash key nil))
1005
1006	(defun general-hash-find-for-put (hash key)
1007	(%hash-probe hash key t))
1008
1009	;;; returns a single value:
1010	;;; index - the index in the vector for key (where it was or where
1011	;;; to insert if the current key at that index is deleted-hash-key-marker
1012	;;; or free-hash-key-marker)
1013
1014
1015	(defun %hash-probe (hash key update-hash-flags)
1016	(declare (optimize (speed 3) (space 0)))
1017	(multiple-value-bind (hash-code index entries)
1018	(compute-hash-code hash key update-hash-flags)
1019	(locally (declare (fixnum hash-code index entries))
1020	(let* ((compareF (nhash.compareF hash))
1021	(vector (nhash.vector hash))
1022	(vector-index 0)
1023	table-key
1024	(first-deleted-index nil))
1025	(declare (fixnum vector-index))
1026	(macrolet ((return-it (form)
1027	`(return-from %hash-probe ,form)))
1028	(macrolet ((test-it (predicate)
1029	(unless (listp predicate) (setq predicate (list predicate)))
1030	`(progn
1031	(setq vector-index (index->vector-index index)
1032	table-key (%svref vector vector-index))
1033	(cond ((eq table-key free-hash-key-marker)
1034	(return-it (or first-deleted-index
1035	vector-index)))
1036	((eq table-key deleted-hash-key-marker)
1037	(when (null first-deleted-index)
1038	(setq first-deleted-index vector-index)))
1039	((,@predicate key table-key)
1040	(return-it vector-index))))))
1041	(macrolet ((do-it (predicate)
1042	`(progn
1043	(test-it ,predicate)
1044	; First probe failed. Iterate on secondary key
1045	(let ((initial-index index)
1046	(secondary-hash (%svref secondary-keys (logand 7 hash-code))))
1047	(declare (fixnum secondary-hash initial-index))
1048	(loop
1049	(incf index secondary-hash)
1050	(when (>= index entries)
1051	(decf index entries))
1052	(when (eql index initial-index)
1053	(unless first-deleted-index
1054	(error "No deleted entries in table"))
1055	(return-it first-deleted-index))
1056	(test-it ,predicate))))))
1057	(if (fixnump comparef)
1058	;; EQ or EQL hash table
1059	(if (or (eql 0 comparef)
1060	(immediate-p-macro key)
1061	(not (need-use-eql key)))
1062	;; EQ hash table or EQL == EQ for KEY
1063	(do-it eq)
1064	(do-it eql))
1065	;; general compare function
1066	(do-it (funcall comparef))))))))))
1067
1068	(defun eq-hash-find (hash key)
1069	(declare (optimize (speed 3) (safety 0)))
1070	(let* ((vector (nhash.vector hash))
1071	(hash-code
1072	(let* ((typecode (typecode key)))
1073	(if (eq typecode target::tag-fixnum)
1074	(mixup-hash-code key)
1075	(if (eq typecode target::subtag-instance)
1076	(mixup-hash-code (instance.hash key))
1077	(if (symbolp key)
1078	(let* ((name (if key (%svref
1079	(symptr->symvector key)
1080	target::symbol.pname-cell) "NIL")))
1081	(mixup-hash-code (%pname-hash name (length name))))
1082	(mixup-hash-code (strip-tag-to-fixnum key)))))))
1083	(length (uvsize vector))
1084	(count (- length $nhash.vector_overhead))
1085	(entries (ash count -1))
1086	(vector-index (index->vector-index (fast-mod hash-code entries)))
1087	(table-key (%svref vector vector-index)))
1088	(declare (fixnum hash-code entries vector-index count length))
1089	(if (or (eq key table-key)
1090	(eq table-key free-hash-key-marker))
1091	vector-index
1092	(let* ((secondary-hash (%svref secondary-keys-*-2
1093	(logand 7 hash-code)))
1094	(initial-index vector-index)
1095	(first-deleted-index (if (eq table-key deleted-hash-key-marker)
1096	vector-index)))
1097	(declare (fixnum secondary-hash initial-index))
1098	(loop
1099	(incf vector-index secondary-hash)
1100	(when (>= vector-index length)
1101	(decf vector-index count))
1102	(setq table-key (%svref vector vector-index))
1103	(when (= vector-index initial-index)
1104	(return first-deleted-index))
1105	(if (eq table-key key)
1106	(return vector-index)
1107	(if (eq table-key free-hash-key-marker)
1108	(return (or first-deleted-index vector-index))
1109	(if (and (null first-deleted-index)
1110	(eq table-key deleted-hash-key-marker))
1111	(setq first-deleted-index vector-index)))))))))
1112
1113	;;; As above, but note whether the key is in some way address-based
1114	;;; and update the hash-vector's flags word if so.
1115	;;; This only needs to be done by PUTHASH, and it only really needs
1116	;;; to be done if we're adding a new key.
1117	(defun eq-hash-find-for-put (hash key)
1118	(declare (optimize (speed 3) (safety 0)))
1119	(let* ((vector (nhash.vector hash))
1120	(hash-code
1121	(let* ((typecode (typecode key)))
1122	(if (eq typecode target::tag-fixnum)
1123	(mixup-hash-code key)
1124	(if (eq typecode target::subtag-instance)
1125	(mixup-hash-code (instance.hash key))
1126	(if (symbolp key)
1127	(let* ((name (if key (%svref
1128	(symptr->symvector key)
1129	target::symbol.pname-cell) "NIL")))
1130	(mixup-hash-code (%pname-hash name (length name))))
1131	(progn
1132	(unless (immediate-p-macro key)
1133	(let* ((flags (nhash.vector.flags vector)))
1134	(declare (fixum flags))
1135	(unless (logbitp $nhash_track_keys_bit flags)
1136	(setq flags (bitclr $nhash_key_moved_bit flags)))
1137	(setf (nhash.vector.flags vector)
1138	(logior $nhash-track-keys-mask flags))))
1139	(mixup-hash-code (strip-tag-to-fixnum key))))))))
1140	(length (uvsize vector))
1141	(count (- length $nhash.vector_overhead))
1142	(vector-index (index->vector-index (fast-mod hash-code (ash count -1))))
1143	(table-key (%svref vector vector-index)))
1144	(declare (fixnum hash-code length count entries vector-index))
1145	(if (or (eq key table-key)
1146	(eq table-key free-hash-key-marker))
1147	vector-index
1148	(let* ((secondary-hash (%svref secondary-keys-*-2
1149	(logand 7 hash-code)))
1150	(initial-index vector-index)
1151	(first-deleted-index (if (eq table-key deleted-hash-key-marker)
1152	vector-index)))
1153	(declare (fixnum secondary-hash initial-index))
1154	(loop
1155	(incf vector-index secondary-hash)
1156	(when (>= vector-index length)
1157	(decf vector-index count))
1158	(setq table-key (%svref vector vector-index))
1159	(when (= vector-index initial-index)
1160	(return first-deleted-index))
1161	(if (eq table-key key)
1162	(return vector-index)
1163	(if (eq table-key free-hash-key-marker)
1164	(return (or first-deleted-index vector-index))
1165	(if (and (null first-deleted-index)
1166	(eq table-key deleted-hash-key-marker))
1167	(setq first-deleted-index vector-index)))))))))
1168
1169	(defun eql-hash-find (hash key)
1170	(declare (optimize (speed 3) (safety 0)))
1171	(if (need-use-eql key)
1172	(let* ((vector (nhash.vector hash))
1173	(hash-code (%%eqlhash-internal key))
1174	(length (uvsize vector))
1175	(count (- length $nhash.vector_overhead))
1176	(entries (ash count -1))
1177	(vector-index (index->vector-index (fast-mod hash-code entries)))
1178	(table-key (%svref vector vector-index)))
1179	(declare (fixnum hash-code length entries count vector-index))
1180	(if (or (eql key table-key)
1181	(eq table-key free-hash-key-marker))
1182	vector-index
1183	(let* ((secondary-hash (%svref secondary-keys-*-2
1184	(logand 7 hash-code)))
1185	(initial-index vector-index)
1186	(first-deleted-index (if (eq table-key deleted-hash-key-marker)
1187	vector-index)))
1188	(declare (fixnum secondary-hash initial-index))
1189	(loop
1190	(incf vector-index secondary-hash)
1191	(when (>= vector-index length)
1192	(decf vector-index count))
1193	(setq table-key (%svref vector vector-index))
1194	(when (= vector-index initial-index)
1195	(return first-deleted-index))
1196	(if (eql table-key key)
1197	(return vector-index)
1198	(if (eq table-key free-hash-key-marker)
1199	(return (or first-deleted-index vector-index))
1200	(if (and (null first-deleted-index)
1201	(eq table-key deleted-hash-key-marker))
1202	(setq first-deleted-index vector-index))))))))
1203	(eq-hash-find hash key)))
1204
1205	(defun eql-hash-find-for-put (hash key)
1206	(declare (optimize (speed 3) (safety 0)))
1207	(if (need-use-eql key)
1208	(let* ((vector (nhash.vector hash))
1209	(hash-code (%%eqlhash-internal key))
1210	(length (uvsize vector))
1211	(count (- length $nhash.vector_overhead))
1212	(entries (ash count -1))
1213	(vector-index (index->vector-index (fast-mod hash-code entries)))
1214	(table-key (%svref vector vector-index)))
1215	(declare (fixnum hash-code length entries vector-index))
1216	(if (or (eql key table-key)
1217	(eq table-key free-hash-key-marker))
1218	vector-index
1219	(let* ((secondary-hash (%svref secondary-keys-*-2
1220	(logand 7 hash-code)))
1221	(initial-index vector-index)
1222	(first-deleted-index (if (eq table-key deleted-hash-key-marker)
1223	vector-index)))
1224	(declare (fixnum secondary-hash initial-index))
1225	(loop
1226	(incf vector-index secondary-hash)
1227	(when (>= vector-index length)
1228	(decf vector-index count))
1229	(setq table-key (%svref vector vector-index))
1230	(when (= vector-index initial-index)
1231	(return (or first-deleted-index
1232	(error "Bug: no deleted entries in table"))))
1233	(if (eql table-key key)
1234	(return vector-index)
1235	(if (eq table-key free-hash-key-marker)
1236	(return (or first-deleted-index vector-index))
1237	(if (and (null first-deleted-index)
1238	(eq table-key deleted-hash-key-marker))
1239	(setq first-deleted-index vector-index))))))))
1240	(eq-hash-find-for-put hash key)))
1241
1242	;;; Rehash. Caller should have exclusive access to the hash table
1243	;;; and have disabled interrupts.
1244	(defun %rehash (hash)
1245	(let* ((vector (nhash.vector hash))
1246	(flags (nhash.vector.flags vector)) )
1247	(setf (nhash.vector.flags vector)
1248	(logand flags $nhash-clear-key-bits-mask))
1249	(do-rehash hash)))
1250
1251
1252	(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash))))
1253	(declare (fixnum size))
1254	(let ((rehash-bits (nhash.rehash-bits hash)))
1255	(unless (and rehash-bits
1256	(>= (uvsize rehash-bits) size))
1257	(return-from %make-rehash-bits
1258	(setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0))))
1259	(fill (the simple-bit-vector rehash-bits) 0)))
1260
1261	(defun do-rehash (hash)
1262	(let* ((vector (nhash.vector hash))
1263	(vector-index (- $nhash.vector_overhead 2))
1264	(size (nhash.vector-size vector))
1265	(rehash-bits (%make-rehash-bits hash size))
1266	(index -1))
1267	(declare (fixnum size index vector-index))
1268	(setf (nhash.vector.cache-key vector) (%unbound-marker)
1269	(nhash.vector.cache-value vector) nil)
1270	(%set-does-not-need-rehashing hash)
1271	(loop
1272	(when (>= (incf index) size) (return))
1273	(setq vector-index (+ vector-index 2))
1274	(unless (%already-rehashed-p index rehash-bits)
1275	(let* ((key (%svref vector vector-index))
1276	(deleted (eq key deleted-hash-key-marker)))
1277	(unless
1278	(when (or deleted (eq key free-hash-key-marker))
1279	(if deleted ; one less deleted entry
1280	(let ((count (1- (nhash.vector.deleted-count vector))))
1281	(declare (fixnum count))
1282	(setf (nhash.vector.deleted-count vector) count)
1283	(if (< count 0)
1284	(let ((wdc (nhash.vector.weak-deletions-count vector)))
1285	(setf (nhash.vector.weak-deletions-count vector) 0)
1286	(incf (nhash.vector.deleted-count vector) wdc)
1287	(decf (nhash.count hash) wdc)))
1288	(incf (nhash.grow-threshold hash))
1289	;; Change deleted to free
1290	(setf (%svref vector vector-index) free-hash-key-marker)))
1291	t)
1292	(let* ((last-index index)
1293	(value (%svref vector (the fixnum (1+ vector-index))))
1294	(first t))
1295	(loop
1296	(let ((vector (nhash.vector hash))
1297	(found-index (%rehash-probe rehash-bits hash key)))
1298	(%set-already-rehashed-p found-index rehash-bits)
1299	(if (eq last-index found-index)
1300	(return)
1301	(let* ((found-vector-index (index->vector-index found-index))
1302	(newkey (%svref vector found-vector-index))
1303	(newvalue (%svref vector (the fixnum (1+ found-vector-index)))))
1304	(declare (fixnum found-vector-index))
1305	(when first ; or (eq last-index index) ?
1306	(setq first nil)
1307	(setf (%svref vector vector-index) free-hash-key-marker)
1308	(setf (%svref vector (the fixnum (1+ vector-index))) free-hash-key-marker))
1309	(%set-hash-table-vector-key vector found-vector-index key)
1310	(setf (%svref vector (the fixnum (1+ found-vector-index))) value)
1311	(when (or (eq newkey free-hash-key-marker)
1312	(setq deleted (eq newkey deleted-hash-key-marker)))
1313	(when deleted
1314	(let ((count (1- (nhash.vector.deleted-count vector))))
1315	(declare (fixnum count))
1316	(setf (nhash.vector.deleted-count vector) count)
1317	(if (< count 0)
1318	(let ((wdc (nhash.vector.weak-deletions-count vector)))
1319	(setf (nhash.vector.weak-deletions-count vector) 0)
1320	(incf (nhash.vector.deleted-count vector) wdc)
1321	(decf (nhash.count hash) wdc)))
1322	(incf (nhash.grow-threshold hash))))
1323	(return))
1324	(when (eq key newkey)
1325	(cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
1326	key hash value newvalue index found-index)
1327	(decf (nhash.count hash))
1328	(incf (nhash.grow-threshold hash))
1329	(return))
1330	(setq key newkey
1331	value newvalue
1332	last-index found-index)))))))))))
1333	t )
1334
1335	;;; Hash to an index that is not set in rehash-bits
1336
1337	(defun %rehash-probe (rehash-bits hash key)
1338	(declare (optimize (speed 3)(safety 0)))
1339	(multiple-value-bind (hash-code index entries)(compute-hash-code hash key t)
1340	(declare (fixnum hash-code index entries))
1341	(when (null hash-code)(cerror "nuts" "Nuts"))
1342	(let* ((vector (nhash.vector hash))
1343	(vector-index (index->vector-index index)))
1344	(if (or (not (%already-rehashed-p index rehash-bits))
1345	(eq key (%svref vector vector-index)))
1346	(return-from %rehash-probe index)
1347	(let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1348	(declare (fixnum second))
1349	(loop
1350	(setq index (+ index second))
1351	(when (>= index entries)
1352	(setq index (- index entries)))
1353	(when (or (not (%already-rehashed-p index rehash-bits))
1354	(eq key (%svref vector (index->vector-index index))))
1355	(return-from %rehash-probe index))))))))
1356
1357	;;; Returns one value: the index of the entry in the vector
1358	;;; Since we're growing, we don't need to compare and can't find a key that's
1359	;;; already there.
1360	(defun %growhash-probe (vector hash key)
1361	(declare (optimize (speed 3)(safety 0)))
1362	(multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector)
1363	(declare (fixnum hash-code index entries))
1364	(let* ((vector-index (index->vector-index index))
1365	(vector-key nil))
1366	(declare (fixnum vector-index))
1367	(if (or (eq free-hash-key-marker
1368	(setq vector-key (%svref vector vector-index)))
1369	(eq deleted-hash-key-marker vector-key))
1370	(return-from %growhash-probe index)
1371	(let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1372	(declare (fixnum second))
1373	(loop
1374	(setq index (+ index second))
1375	(when (>= index entries)
1376	(setq index (- index entries)))
1377	(when (or (eq free-hash-key-marker
1378	(setq vector-key (%svref vector (index->vector-index index))))
1379	(eq deleted-hash-key-marker vector-key))
1380	(return-from %growhash-probe index))))))))
1381
1382	;;;;;;;;;;;;;
1383	;;
1384	;; Mapping functions are in "ccl:lib;hash"
1385	;;
1386
1387
1388
1389	;;;;;;;;;;;;;
1390	;;
1391	;; Hashing functions
1392	;; EQ & the EQ part of EQL are done in-line.
1393	;;
1394
1395
1396
1397
1398
1399
1400
1401
1402
1403	;;; so whats so special about bit vectors as opposed to any other vectors of bytes
1404	;;; For starters, it's guaranteed that they exist in the implementation; that may
1405	;;; not be true of other immediate vector types.
1406	(defun bit-vector-hash (bv)
1407	(declare (optimize (speed 3)(safety 0)))
1408	(let ((length (length bv)))
1409	(declare (fixnum length)) ;will this always be true? it's true of all vectors.
1410	(multiple-value-bind (data offset) (array-data-and-offset bv)
1411	(declare (type simple-bit-vector data) (fixnum offset))
1412	(let* ((hash 0)
1413	(limit (+ length offset))
1414	(nbytes (ash (the fixnum (+ length 7)) -3)))
1415	(declare (fixnum hash limit nbytes))
1416	(dotimes (i nbytes (mixup-hash-code hash))
1417	(let* ((w 0))
1418	(declare (fixnum w))
1419	(dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3)) w)))
1420	(setq w (the fixnum
1421	(logxor
1422	(the fixnum
1423	(ash (if (< offset limit)
1424	(the fixnum (sbit data offset))
1425	0)
1426	(the fixnum j)))
1427	w)))
1428	(incf offset))))))))
1429
1430	#\|
1431	(defun bit-vector-hash (bv)
1432	(declare (optimize (speed 3)(safety 0)))
1433	(let ((length (length bv)))
1434	(declare (fixnum length))
1435	(let* ((all (+ length 15))
1436	(nwds (ash all -4))
1437	(rem (logand all 15))
1438	(hash 0)
1439	(mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem)))))
1440	(declare (fixnum all nwds rem hash mask))
1441	(multiple-value-bind (data offset)
1442	(array-data-and-offset bv)
1443	(declare (fixnum offset))
1444	(locally (declare (type (simple-array (unsigned-byte 16) (*)) data))
1445	(dotimes (i nwds)
1446	(setq hash (%i+ hash (aref data (the fixnum (+ i offset))))))
1447	(when (neq 0 mask)
1448	(setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds)))))))
1449	(mixup-hash-code hash))))))
1450	\|#
1451
1452
1453	;;; Same as %%equalhash, but different:
1454	;;; 1) Real numbers are hashed as if they were double-floats. The real components of complex numbers
1455	;;; are hashed as double-floats and XORed together.
1456	;;; 2) Characters and strings are hashed in a case-insensitive manner.
1457	;;; 3) Hash tables are hashed based on their size and type.
1458	;;; 4) Structures and CL array types are hashed based on their content.
1459
1460
1461	;;; check fixnum befor immediate-p. call %%eqlhash
1462
1463	(defun %%equalphash (key)
1464	(cond ((or (fixnump key)(short-float-p key))
1465	(%dfloat-hash (float key 1.0d0)))
1466	((immediate-p-macro key)
1467	(mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key))))
1468	((bignump key)
1469	(if (<= most-negative-double-float key most-positive-double-float)
1470	(%dfloat-hash (float key 1.0d0)) ; with-stack-double-floats
1471	(%%eqlhash-internal key)))
1472	((double-float-p key)
1473	(%dfloat-hash key))
1474	((ratiop key)
1475	(%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key))))
1476	((complexp key)
1477	(%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key))))
1478	((hash-table-p key)
1479	(equalphash-hash-table key))
1480	((or (istructp key)
1481	(structurep key)) ; was (gvectorp key)
1482	(%%equalphash-structure 11 key))
1483	((or (arrayp key)) ;(uvectorp key)) ;??
1484	(%%equalphash-array 11 key))
1485	((consp key)
1486	(%%equalphash-aux 11 key))
1487	(t (%%eqlhash key))))
1488
1489
1490	(defun equalphash-hash-table (hash-table)
1491	(let ((hash (%%equalhash "HASH-TABLE"))
1492	addressp)
1493	(declare (fixnum hash))
1494	(incf hash (the fixnum (%%eqhash (hash-table-count hash-table))))
1495	(multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table))
1496	(declare (fixnum h))
1497	(incf hash h)
1498	(if ap (setq addressp t)))
1499	(multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table))
1500	(declare (fixnum h))
1501	(incf hash h)
1502	(if ap (setq addressp t)))
1503	(values hash addressp)))
1504
1505	(defun %%equalphash-structure (limit key)
1506	(let* ((size (uvsize key))
1507	(hash (mixup-hash-code size))
1508	addressp)
1509	(declare (fixnum limit size hash))
1510	(dotimes (i size)
1511	(multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i))
1512	(declare (fixnum h))
1513	(setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1514	(if ap (setq addressp t)))
1515	(when (<= (decf limit) 0)
1516	(setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1517	#.(mixup-hash-code 11))))
1518	(return)))
1519	(values hash addressp)))
1520
1521	(defun %%equalphash-array (limit key)
1522	(multiple-value-bind (array offset) (array-data-and-offset key)
1523	(let* ((rank (array-rank key))
1524	(vectorp (eql rank 1))
1525	(size (if vectorp (length key) (array-total-size key)))
1526	(hash (mixup-hash-code rank))
1527	addressp)
1528	(declare (fixnum size hash limit rank))
1529	(if vectorp
1530	(setq hash
1531	(the fixnum
1532	(+ (the fixnum (rotate-hash-code hash))
1533	(the fixnum (mixup-hash-code size)))))
1534	(dotimes (i rank)
1535	(declare (fixnum i))
1536	(setq hash
1537	(the fixnum
1538	(+ (the fixnum (rotate-hash-code hash))
1539	(the fixnum
1540	(mixup-hash-code (array-dimension key i))))))))
1541	(dotimes (i size)
1542	(declare (fixnum i))
1543	(multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset))
1544	(declare (fixnum h))
1545	(setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1546	(if ap (setq addressp t)))
1547	(when (<= (decf limit) 0)
1548	(setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1549	#.(mixup-hash-code 11))))
1550	(return))
1551	(incf offset))
1552	(values hash addressp))))
1553
1554	(defun %%equalphash-aux (limit key)
1555	(if (<= limit 0)
1556	#.(mixup-hash-code 11)
1557	(if (null key) #.(mixup-hash-code 17)
1558	(cond ((consp key)
1559	(let ((hash 0)
1560	address-p)
1561	(do ((l limit (1- l)))
1562	((eq l 0)(values hash address-p))
1563	(multiple-value-bind (ahash ap)
1564	(%%equalphash-aux l (if (consp key)(car key) key))
1565	(setq hash (mixup-hash-code (logxor ahash hash)))
1566	(if ap (setq address-p t)))
1567	(when (not (consp key))
1568	(return (values hash address-p)))
1569	(setq key (cdr key)))))
1570	((hash-table-p key)
1571	(equalphash-hash-table key))
1572	; what are the dudes called that contain bits? they are uvectors but not gvectors?
1573	; ivectors.
1574	((or (istructp key)
1575	(structurep key)) ;was (gvectorp key)
1576	(%%equalphash-structure limit key))
1577	((or (arrayp key)) ; (uvectorp key))
1578	(%%equalphash-array limit key))
1579	(t (%%equalphash key))))))
1580
1581	(defun alist-hash-table (alist &rest hash-table-args)
1582	(declare (dynamic-extent hash-table-args))
1583	(if (typep alist 'hash-table)
1584	alist
1585	(let ((hash-table (apply #'make-hash-table hash-table-args)))
1586	(dolist (cons alist) (puthash (car cons) hash-table (cdr cons)))
1587	hash-table)))
1588
1589	(defun %hash-table-equalp (x y)
1590	;; X and Y are both hash tables
1591	(and (eq (hash-table-test x)
1592	(hash-table-test y))
1593	(eql (hash-table-count x)
1594	(hash-table-count y))
1595	(block nil
1596	(let* ((default (cons nil nil))
1597	(foo #'(lambda (k v)
1598	(let ((y-value (gethash k y default)))
1599	(unless (and (neq default y-value)
1600	(equalp v y-value))
1601	(return nil))))))
1602	(declare (dynamic-extent foo default))
1603	(maphash foo x))
1604	t)))
1605
1606	(defun sxhash (s-expr)
1607	"Computes a hash code for S-EXPR and returns it as an integer."
1608	(logand (sxhash-aux s-expr 7 17) most-positive-fixnum))
1609
1610	(defun sxhash-aux (expr counter key)
1611	(declare (fixnum counter))
1612	(if (> counter 0)
1613	(typecase expr
1614	((or string bit-vector number character) (+ key (%%equalhash expr)))
1615	((or pathname logical-pathname)
1616	(dotimes (i (uvsize expr) key)
1617	(declare (fixnum i))
1618	(setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))
1619	(symbol (+ key (%%equalhash (symbol-name expr))))
1620	(cons (sxhash-aux
1621	(cdr expr)
1622	(the fixnum (1- counter))
1623	(+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key))))
1624	(t (+ key (%%equalhash (symbol-name (%type-of expr))))))
1625	key))
1626
1627
1628
1629	#+ppc32-target
1630	(defun immediate-p (thing)
1631	(let* ((tag (lisptag thing)))
1632	(declare (fixnum tag))
1633	(or (= tag ppc32::tag-fixnum)
1634	(= tag ppc32::tag-imm))))
1635
1636	#+ppc64-target
1637	(defun immediate-p (thing)
1638	(let* ((tag (lisptag thing)))
1639	(declare (fixnum tag))
1640	(or (= tag ppc64::tag-fixnum)
1641	(= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm))))
1642
1643	#+x8664-target
1644	(defun immediate-p (thing)
1645	(let* ((tag (lisptag thing)))
1646	(declare (type (unsigned-byte 3) tag))
1647	(logbitp tag
1648	(logior (ash 1 x8664::tag-fixnum)
1649	(ash 1 x8664::tag-imm-0)
1650	(ash 1 x8664::tag-imm-1)))))
1651
1652
1653
1654	(defun get-fwdnum (&optional hash)
1655	(let* ((res (%get-fwdnum)))
1656	(if hash
1657	(setf (nhash.fixnum hash) res))
1658	res))
1659
1660	(defun gc-count (&optional hash)
1661	(let ((res (%get-gc-count)))
1662	(if hash
1663	(setf (nhash.gc-count hash) res)
1664	res)))
1665
1666
1667	(defun %cons-nhash-vector (size &optional (flags 0))
1668	(declare (fixnum size))
1669	(let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector (%unbound-marker))))
1670	(setf (nhash.vector.link vector) 0
1671	(nhash.vector.flags vector) flags
1672	(nhash.vector.free-alist vector) nil
1673	(nhash.vector.finalization-alist vector) nil
1674	(nhash.vector.weak-deletions-count vector) 0
1675	(nhash.vector.hash vector) nil
1676	(nhash.vector.deleted-count vector) 0
1677	(nhash.vector.cache-key vector) (%unbound-marker)
1678	(nhash.vector.cache-value vector) nil
1679	(nhash.vector.cache-idx vector) nil)
1680	vector))
1681

Note: See TracBrowser for help on using the repository browser.

Download in other formats: