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

Last change on this file since 10867 was 10867, checked in by gz, 11 years ago

Default to lock-free for shared hash tables

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 83.4 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;; See hash.lisp for documentation
22
23
24(eval-when (:compile-toplevel :execute)
25  (require "HASHENV" "ccl:xdump;hashenv")
26  (require :number-case-macro)
27  (define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker))
28  (define-symbol-macro free-hash-marker (%unbound-marker))
29  (define-symbol-macro rehashing-value-marker (%slot-unbound-marker))
30  (declaim (inline nhash.vector-size))
31  (declaim (inline mixup-hash-code))
32  (declaim (inline hash-table-p))
33  (declaim (inline %%eqhash))
34  (declaim (inline index->vector-index vector-index->index swap))
35  (declaim (inline %already-rehashed-p %set-already-rehashed-p))
36  (declaim (inline need-use-eql))
37  (declaim (inline %needs-rehashing-p))
38  (declaim (inline compute-hash-code))
39  (declaim (inline eq-hash-find eq-hash-find-for-put))
40  (declaim (inline read-lock-hash-table write-lock-hash-table  unlock-hash-table))
41  (declaim (inline %hash-symbol))
42  (declaim (inline hash-mod))
43  (declaim (inline set-hash-key-conditional set-hash-value-conditional))
44  (declaim (inline hash-lock-free-p lock-free-gethash)))
45
46
47
48(defun %cons-hash-table (keytrans-function compare-function vector
49                         threshold rehash-ratio rehash-size find find-new owner &optional lock-free-p)
50  (%istruct
51   'HASH-TABLE                          ; type
52   keytrans-function                    ; nhash.keytransF
53   compare-function                     ; nhash.compareF
54   nil                                  ; nhash.rehash-bits
55   vector                               ; nhash.vector
56   (if lock-free-p $nhash.lock-free 0)  ; nhash.lock
57   owner                                ; nhash.owner
58   threshold                            ; nhash.grow-threshold
59   rehash-ratio                         ; nhash.rehash-ratio
60   rehash-size                          ; nhash.rehash-size
61   0                                    ; nhash.puthash-count
62   (if lock-free-p
63     (make-lock)
64     (unless owner (make-read-write-lock))) ; nhash.exclusion-lock
65   find                                 ; nhash.find
66   find-new                             ; nhash.find-new
67   nil                                  ; nhash.read-only
68   ))
69
70(defun nhash.vector-size (vector)
71  (nhash.vector.size vector))
72
73(defun hash-mod (hash entries vector)
74  (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector)))
75
76;; For lock-free hash tables
77(defun set-hash-key-conditional (index vector old new)
78  (%set-hash-table-vector-key-conditional (%i+ target::misc-data-offset
79                                               (ash (the fixnum index) target::word-shift))
80                                          vector
81                                          old
82                                          new))
83
84(defun set-hash-value-conditional (index vector old new)
85  (store-gvector-conditional (%i+ index 1) vector old new))
86
87(defun hash-lock-free-p (hash)
88  (logtest $nhash.lock-free (the fixnum (nhash.lock hash))))
89 
90;;; Is KEY something which can be EQL to something it's not EQ to ?
91;;; (e.g., is it a number or macptr ?)
92;;; This can be more general than necessary but shouldn't be less so.
93(defun need-use-eql (key)
94  (let* ((typecode (typecode key)))
95    (declare (fixnum typecode))
96    (or (= typecode target::subtag-macptr)
97        #+(or ppc32-target x8632-target)
98        (and (>= typecode target::min-numeric-subtag)
99             (<= typecode target::max-numeric-subtag))
100        #+64-bit-target
101        (or (= typecode target::subtag-bignum)
102            (= typecode target::subtag-double-float)
103            (= typecode target::subtag-ratio)
104            (= typecode target::subtag-complex)))))
105
106;;; Don't rehash at all, unless some key is address-based (directly or
107;;; indirectly.)
108(defun %needs-rehashing-p (vector)
109  (let* ((flags (nhash.vector.flags vector)))
110    (declare (fixnum flags))
111    (if (logbitp $nhash_track_keys_bit flags)
112      ;; GC is tracking key movement
113      (logbitp $nhash_key_moved_bit flags)
114      ;; GC is not tracking key movement
115      (if (logbitp $nhash_component_address_bit flags)
116        (not (eql (the fixnum (%get-gc-count)) (the fixnum (nhash.vector.gc-count vector))))))))
117
118(defun %set-does-not-need-rehashing (hash)
119  (let* ((vector (nhash.vector hash))
120         (flags (nhash.vector.flags vector)))
121    (declare (fixnum flags))
122    (setf (nhash.vector.gc-count vector) (%get-gc-count))
123    (when (logbitp $nhash_track_keys_bit flags)
124      (setf (nhash.vector.flags vector)
125            (logand (lognot (ash 1 $nhash_key_moved_bit)) flags)))))
126
127
128;;; Tempting though it may be to remove this, a hash table loaded from
129;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM
130;;; for hash tables needs to be able to call this or something similar.
131(defun %set-needs-rehashing (hash)
132  (let* ((vector (nhash.vector hash))
133         (flags (nhash.vector.flags vector)))
134    (declare (fixnum flags))
135    (setf (nhash.vector.gc-count vector) (the fixnum (1- (the fixnum (%get-gc-count)))))
136    (when (logbitp $nhash_track_keys_bit flags)
137      (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags)))))
138
139#+32-bit-target
140(defun mixup-hash-code (fixnum)
141  (declare (fixnum fixnum))
142  (the fixnum
143    (+ fixnum
144       (the fixnum (%ilsl (- 32 8)
145                          (logand (1- (ash 1 (- 8 3))) fixnum))))))
146
147#+64-bit-target
148(defun mixup-hash-code (fixnum)
149  (declare (fixnum fixnum))
150  (the fixnum
151    (+ fixnum
152       (the fixnum (%ilsl 50
153                          (logand (1- (ash 1 (- 8 3))) fixnum))))))
154
155
156(defun rotate-hash-code (fixnum)
157  (declare (fixnum fixnum))
158  (let* ((low-3 (logand 7 fixnum))
159         (but-low-3 (%ilsr 3 fixnum))
160         (low-3*64K (%ilsl 13 low-3))
161         (low-3-in-high-3 (%ilsl (- 32 3 3) low-3)))
162    (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3))
163    (the fixnum (+ low-3-in-high-3
164                   (the fixnum (logxor low-3*64K but-low-3))))))
165
166
167
168
169(defconstant $nhash-track-keys-mask
170  #.(- (ash 1 $nhash_track_keys_bit)))
171
172(defconstant $nhash-clear-key-bits-mask #xfffff)
173
174
175(defun %hash-symbol (sym)
176  (if sym   
177    (let* ((vector (%symptr->symvector sym))
178           (cell (%svref vector target::symbol.plist-cell)))
179      (or (car cell)
180          (let* ((pname (%svref vector target::symbol.pname-cell))
181                 (hash (mixup-hash-code (%pname-hash pname (uvsize pname)))))
182            (declare (type (simple-string pname)))
183            (if cell
184              (setf (car cell) hash)
185              (progn
186                (setf (%svref vector target::symbol.plist-cell)
187                      (cons hash nil))
188                hash)))))
189    +nil-hash+))
190             
191;;; Hash on address, or at least on some persistent, immutable
192;;; attribute of the key.  If all keys are fixnums or immediates (or if
193;;; that attribute exists), rehashing won't ever be necessary.
194(defun %%eqhash (key)
195  (let* ((typecode (typecode key)))
196    (if (eq typecode target::tag-fixnum)
197      (values (mixup-hash-code key) nil)
198      (if (eq typecode target::subtag-instance)
199        (values (mixup-hash-code (instance.hash key)) nil)
200        (if (symbolp key)
201          (values (%hash-symbol key) nil)
202          (let ((hash (mixup-hash-code (strip-tag-to-fixnum key))))
203            (if (immediate-p-macro key)
204              (values hash nil)
205              (values hash :key ))))))))
206
207
208#+32-bit-target
209(defun swap (num)
210  (declare (fixnum num))
211  (the fixnum (+ (the fixnum (%ilsl 16 num))(the fixnum (%ilsr 13 num)))))
212
213#+64-bit-target
214(defun swap (num)
215  (declare (fixnum num))
216  (the fixnum (+ (the fixnum (%ilsl 32 num))(the fixnum (%ilsr 29 num)))))
217
218;;; teeny bit faster when nothing to do
219(defun %%eqlhash-internal (key)
220  (number-case key
221    (fixnum (mixup-hash-code key)) ; added this
222    (double-float (%dfloat-hash key))
223    (short-float (%sfloat-hash key))
224    (bignum (%bignum-hash key))
225    (ratio (logxor (swap (%%eqlhash-internal (numerator key)))
226                   (%%eqlhash-internal (denominator key))))
227    (complex
228     (logxor (swap (%%eqlhash-internal (realpart key)))
229             (%%eqlhash-internal (imagpart key))))
230    (t (cond ((macptrp key)
231              (%macptr-hash key))
232             (t key)))))
233
234               
235
236
237;;; new function
238
239(defun %%eqlhash (key)
240  ;; if key is a macptr, float, bignum, ratio, or complex, convert it
241  ;; to a fixnum
242  (if (hashed-by-identity key)
243    (%%eqhash key)
244    (let ((primary  (%%eqlhash-internal key)))
245      (if (eq primary key)
246        (%%eqhash key)
247        (mixup-hash-code (strip-tag-to-fixnum primary))))))
248
249
250(defun %%equalhash (key)
251  (let* ((id-p (hashed-by-identity key))
252         (hash (if (and key (not id-p)) (%%eqlhash-internal key)))
253         addressp)
254    (cond ((null key) (mixup-hash-code 17))
255          #+64-bit-target
256          ((and (typep key 'single-float)
257                (zerop (the single-float key)))
258           0)
259          ((immediate-p-macro key) (mixup-hash-code (strip-tag-to-fixnum key)))
260          ((and hash (neq hash key)) hash)  ; eql stuff
261          (t (typecase key
262                (simple-string (%pname-hash key (length key)))
263                (string
264                 (let ((length (length key)))
265                   (multiple-value-bind (data offset) (array-data-and-offset key)
266                     (%string-hash offset data length))))
267                (bit-vector (bit-vector-hash key))
268                (cons
269                 (let ((hash 0))
270                   (do* ((i 0 (1+ i))
271                         (list key (cdr list)))
272                        ((or (not (consp list)) (> i 11))) ; who figured 11?
273                     (declare (fixnum i))
274                     (multiple-value-bind (h1 a1) (%%equalhash (%car list))
275                       (when a1 (setq addressp t))
276                       ; fix the case of lists of same stuff in different order
277                       ;(setq hash (%ilogxor (fixnum-rotate h1 i) hash))
278                       (setq hash (%i+ (rotate-hash-code hash) h1))
279                       ))
280                   (values hash addressp)))
281                (pathname (%%equalphash key))
282                (t (%%eqlhash key)))))))
283
284(defun update-hash-flags (hash vector addressp)
285  (when addressp
286    (flet ((new-flags (flags addressp)
287             (declare (fixnum flags))
288             (if (eq :key addressp)
289               ;; hash code depended on key's address
290               (if (logbitp $nhash_component_address_bit flags)
291                 flags
292                 (logior $nhash-track-keys-mask
293                         (if (logbitp $nhash_track_keys_bit flags)
294                           flags
295                           (bitclr $nhash_key_moved_bit flags))))
296               ;; hash code depended on component address
297               (bitset $nhash_component_address_bit
298                       (logand (lognot $nhash-track-keys-mask) flags)))))
299      (declare (inline new-flags))
300      (if (hash-lock-free-p hash)
301        (loop
302          (let* ((flags (nhash.vector.flags vector))
303                 (new-flags (new-flags flags addressp)))
304            (when (or (eq flags new-flags)
305                      (store-gvector-conditional nhash.vector.flags vector flags new-flags))
306              (return))))
307        (setf (nhash.vector.flags vector)
308              (new-flags (nhash.vector.flags vector) addressp))))))
309
310(defun compute-hash-code (hash key update-hash-flags &optional
311                               (vector (nhash.vector hash))) ; vectorp))
312  (let ((keytransF (nhash.keytransF hash))
313        primary addressp)
314    (if (not (fixnump keytransF))
315      ;; not EQ or EQL hash table
316      (progn
317        (multiple-value-setq (primary addressp) (funcall keytransF key))
318        (let ((immediate-p (immediate-p-macro primary)))
319          (setq primary (strip-tag-to-fixnum primary))
320          (unless immediate-p
321            (setq primary (mixup-hash-code primary))
322            (setq addressp :key))))
323      ;; EQ or EQL hash table
324      (if (and (not (eql keytransF 0))
325               (need-use-eql key))
326        ;; EQL hash table
327        (setq primary (%%eqlhash-internal key))
328        ;; EQ hash table - or something eql doesn't do
329        (multiple-value-setq (primary addressp) (%%eqhash key))))
330    (when update-hash-flags
331      (when addressp
332        (update-hash-flags hash vector addressp)))
333    (let* ((entries (nhash.vector-size vector)))
334      (declare (fixnum entries))
335      (values primary
336              (hash-mod primary entries vector)
337              entries))))
338
339(defun %already-rehashed-p (primary rehash-bits)
340  (declare (optimize (speed 3)(safety 0)))
341  (declare (type (simple-array bit (*)) rehash-bits))
342  (eql 1 (sbit rehash-bits primary)))
343
344(defun %set-already-rehashed-p (primary rehash-bits)
345  (declare (optimize (speed 3)(safety 0)))
346  (declare (type (simple-array bit (*)) rehash-bits))
347  (setf (sbit rehash-bits primary) 1))
348
349
350(defun hash-table-p (hash)
351  (istruct-typep hash 'hash-table))
352
353(defun %normalize-hash-table-count (hash)
354  (let* ((vector (nhash.vector hash))
355         (weak-deletions-count (nhash.vector.weak-deletions-count vector)))
356    (declare (fixnum weak-deletions-count))
357    (unless (eql 0 weak-deletions-count)
358      (setf (nhash.vector.weak-deletions-count vector) 0)
359      ;; lock-free hash tables don't maintain deleted-count, since would need to
360      ;; lock and it's not worth it.
361      (unless (hash-lock-free-p hash)
362        (let ((deleted-count (the fixnum
363                               (+ (the fixnum (nhash.vector.deleted-count vector))
364                                  weak-deletions-count)))
365              (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count))))
366          (setf (nhash.vector.deleted-count vector) deleted-count
367                (nhash.vector.count vector) count))))))
368
369
370(defparameter *shared-hash-table-default* t
371  "Be sure that you understand the implications of changing this
372before doing so.")
373
374(defparameter *lock-free-hash-table-default* :shared
375  "If NIL, hash tables default to using the standard algorithms, with locks for shared tables.
376   If :SHARED, shared hash tables default to using the \"lock-free\" algorithm,
377   which is faster for typical access but slower for rehashing or growing the table.
378   Otherwise, all hash tables default to the lock-free algorithm")
379
380(defun make-hash-table (&key (test 'eql)
381                             (size 60)
382                             (rehash-size 1.5)
383                             (rehash-threshold .85)
384                             (hash-function nil)
385                             (weak nil)
386                             (finalizeable nil)
387                             (address-based t)  ;; Ignored
388                             (lock-free *lock-free-hash-table-default*)
389                             (shared *shared-hash-table-default*))
390  "Create and return a new hash table. The keywords are as follows:
391     :TEST -- Indicates what kind of test to use.
392     :SIZE -- A hint as to how many elements will be put in this hash
393       table.
394     :REHASH-SIZE -- Indicates how to expand the table when it fills up.
395       If an integer, add space for that many elements. If a floating
396       point number (which must be greater than 1.0), multiply the size
397       by that amount.
398     :REHASH-THRESHOLD -- Indicates how dense the table can become before
399       forcing a rehash. Can be any positive number <=1, with density
400       approaching zero as the threshold approaches 0. Density 1 means an
401       average of one entry per bucket."
402  (declare (ignore address-based)) ;; TODO: could reinterpret as "warn if becomes address-based"
403  (unless (and test (or (functionp test) (symbolp test)))
404    (report-bad-arg test '(and (not null) (or symbol function))))
405  (unless (or (functionp hash-function) (symbolp hash-function))
406    (report-bad-arg hash-function '(or symbol function)))
407  (unless (and (realp rehash-threshold) (<= 0.0 rehash-threshold) (<= rehash-threshold 1.0))
408    (report-bad-arg rehash-threshold '(real 0 1)))
409  (unless (or (fixnump rehash-size) (and (realp rehash-size) (< 1.0 rehash-size)))
410    (report-bad-arg rehash-size '(or fixnum (real 1 *))))
411  (unless (fixnump size) (report-bad-arg size 'fixnum))
412  (when (and (eq lock-free :shared) (not shared))
413    (setq lock-free nil))
414  (setq rehash-threshold (/ 1.0 (max 0.01 rehash-threshold)))
415  (let* ((default-hash-function
416             (cond ((or (eq test 'eq) (eq test #'eq)) 
417                    (setq test 0))
418                   ((or (eq test 'eql) (eq test #'eql)) 
419                    (setq test -1))
420                   ((or (eq test 'equal) (eq test #'equal))
421                    (setq test #'equal) #'%%equalhash)
422                   ((or (eq test 'equalp) (eq test #'equalp))
423                    (setq test #'equalp) #'%%equalphash)
424                   (t (setq test (require-type test 'symbol))
425                      (or hash-function 
426                          (error "non-standard test specified without hash-function")))))
427         (find-function
428          (case test
429            (0 #'eq-hash-find)
430            (-1 #'eql-hash-find)
431            (t #'general-hash-find)))
432         (find-put-function
433          (case test
434            (0 #'eq-hash-find-for-put)
435            (-1 #'eql-hash-find-for-put)
436            (t #'general-hash-find-for-put))))
437    (setq hash-function
438          (if hash-function
439            (require-type hash-function 'symbol)
440            default-hash-function))
441    (when (and weak (neq weak :value) (neq test 0))
442      (error "Only EQ hash tables can be weak."))
443    (when (and finalizeable (not weak))
444      (error "Only weak hash tables can be finalizeable."))
445    (when (and (eq lock-free :shared) (not shared))
446      (setq lock-free nil))
447    (multiple-value-bind (grow-threshold total-size)
448        (compute-hash-size (1- size) 1 rehash-threshold)
449      (let* ((flags (+ (if weak (ash 1 $nhash_weak_bit) 0)
450                       (ecase weak
451                         ((t nil :key) 0)
452                         (:value (ash 1 $nhash_weak_value_bit)))
453                       (if finalizeable (ash 1 $nhash_finalizeable_bit) 0)
454                       (if lock-free (ash 1 $nhash_keys_frozen_bit) 0)))
455             (hash (%cons-hash-table 
456                    hash-function test
457                    (%cons-nhash-vector total-size flags)
458                    grow-threshold rehash-threshold rehash-size
459                    find-function find-put-function
460                    (unless shared *current-process*)
461                    lock-free)))
462        (setf (nhash.vector.hash (nhash.vector hash)) hash)
463        hash))))
464
465(defun compute-hash-size (size rehash-size rehash-ratio)
466  (let* ((new-size size))
467    (declare (fixnum size new-size))
468    (setq new-size (max 30 (if (fixnump rehash-size)
469                             (%i+ size rehash-size)
470                             (ceiling (* size rehash-size)))))
471    (if (<= new-size size)
472      (setq new-size (1+ size)))        ; God save you if you make this happen
473   
474    (let ((vector-size (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio))))))
475      ; TODO: perhaps allow more entries, based on actual size:
476      ;  (values (min (floor vector-size rehash-ratio) (%i- vector-size 2)) vector-size))
477      (values new-size vector-size)
478      )))
479
480;;;  Suggested size is a fixnum: number of pairs.  Return a fixnum >=
481;;;  that size that is relatively prime to all secondary keys.
482(defun %hash-size (suggestion)
483  (declare (fixnum suggestion))
484  (declare (optimize (speed 3)(safety 0)))
485  (if (<= suggestion #.(aref secondary-keys 7))
486    (setq suggestion (+ 2 #.(aref secondary-keys 7)))
487     (setq suggestion (logior 1 suggestion)))
488  (loop
489    (dovector (key secondary-keys (return-from %hash-size suggestion))
490      (when (eql 0 (fast-mod suggestion key))
491        (return)))
492    (incf suggestion 2)))
493
494
495(defvar *continue-from-readonly-hashtable-lock-error* t)
496
497(defun signal-read-only-hash-table-error (hash)
498  (cond (*continue-from-readonly-hashtable-lock-error*
499         (cerror "Make the hash-table writable. DANGEROUS! This could damage your lisp if another thread is acccessing this table. CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
500                 "Hash-table ~s is readonly" hash)
501         (assert-hash-table-writeable hash)
502         (write-lock-hash-table hash))
503        (t (error "Hash-table ~s is readonly" hash))))
504
505(defun read-lock-hash-table (hash)
506  (if (nhash.read-only hash)
507    :readonly
508    (let* ((lock (nhash.exclusion-lock hash)))
509      (if lock
510        (read-lock-rwlock lock)
511        (unless (eq (nhash.owner hash) *current-process*)
512          (error "Not owner of hash table ~s" hash))))))
513
514(defun write-lock-hash-table (hash)
515  (if (nhash.read-only hash)
516    (signal-read-only-hash-table-error hash)
517    (let* ((lock (nhash.exclusion-lock hash)))
518      (if lock
519        (write-lock-rwlock lock)
520        (unless (eq (nhash.owner hash) *current-process*)
521          (error "Not owner of hash table ~s" hash))))))
522
523
524(defun unlock-hash-table (hash was-readonly)
525  (unless was-readonly
526    (let* ((lock (nhash.exclusion-lock hash)))
527      (if lock
528        (unlock-rwlock lock)))))
529
530(defun index->vector-index (index)
531  (declare (fixnum index))
532  (the fixnum (+ $nhash.vector_overhead (the fixnum (+ index index)))))
533
534(defun vector-index->index (index)
535  (declare (fixnum index))
536  (the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1)))
537
538(defun hash-table-count (hash)
539  "Return the number of entries in the given HASH-TABLE."
540  (setq hash (require-type hash 'hash-table))
541  (when (hash-lock-free-p hash)
542    ;; We don't try to maintain a running total, so just count.
543    (return-from hash-table-count (lock-free-count-entries hash)))
544  (%normalize-hash-table-count hash)
545  (the fixnum (nhash.vector.count (nhash.vector hash))))
546
547(defun hash-table-rehash-size (hash)
548  "Return the rehash-size HASH-TABLE was created with."
549  (nhash.rehash-size (require-type hash 'hash-table)))
550
551(defun hash-table-rehash-threshold (hash)
552  "Return the rehash-threshold HASH-TABLE was created with."
553  (/ 1.0 (nhash.rehash-ratio (require-type hash 'hash-table))))
554
555(defun hash-table-size (hash)
556  "Return a size that can be used with MAKE-HASH-TABLE to create a hash
557   table that can hold however many entries HASH-TABLE can hold without
558   having to be grown."
559  (let* ((hash (require-type hash 'hash-table))
560         (vector (nhash.vector hash)))
561    (values (floor (nhash.vector.size vector) (nhash.rehash-ratio hash)))))
562
563(defun hash-table-test (hash)
564  "Return the test HASH-TABLE was created with."
565  (let ((f (nhash.compareF (require-type hash 'hash-table))))
566    (if (fixnump f)
567      (if (eql 0 f) 'eq 'eql)
568      (let ((name (if (symbolp f) f (function-name f))))
569        (if (memq name '(equal equalp)) name f)))))
570
571;;; sometimes you'd rather have the function than the symbol.
572(defun hash-table-test-function (hash)
573  (let ((f (nhash.compareF (require-type hash 'hash-table))))
574    (if (fixnump f)
575      (if (eql 0 f) #'eq #'eql)
576      f)))
577
578;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
579;;
580;; nearly-lock-free hash tables
581;;
582;; A modification of the lock-free hash table algorithm described by Cliff Click Jr.  in
583;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html.
584;;
585;; The modifications have to do with the fact that our goal is just to minimize the
586;; performance impact of thread-safety, by eliminating the need for locking on every
587;; read.  I don't bother with aspects of his algorithm that aren't relevant to that goal.
588;;
589;; The main difference from Click's algorithm is that I don't try to do rehashing
590;; concurrently.  Instead, rehashing grabs a lock, so that only one thread can be
591;; rehashing at any given time, and readers/writers will block waiting for the rehashing
592;; to finish.
593;;
594;; In addition, I don't have a separate state for partially inserted key, I reuse the
595;; DELETED state for that.  So in our implementation the following are the possible states
596;; of a hash table entry (where "object" means any object other than the special markers):
597;;
598;; State      Key               Value
599;; DELETED1   object            free-hash-marker
600;; DELETED2   deleted-marker    free-hash-marker
601;; IN-USE     object            object
602;; FREE       free-hash-marker  free-hash-marker
603;; REHASHING  object            rehashing-value-marker
604;; REHASHING  free-hash-marker  rehashing-value-marker
605;; REHASHING  deleted-marker    rehashing-value-marker
606;;
607;; No other states are allowed - at no point in time can a hash table entry be in any
608;; other state.   In addition, the only transitions allowed on the key slot are
609;; free-hash-marker -> object/deleted-marker -> deleted-marker.  Once a key slot
610;; is claimed, it must never change to free or another key value (even after the hash
611;; vector has been discarded after rehashing, because there some process might still
612;; be looking at it).
613;; In particular, rehashing in place is not an option.  All rehashing creates a new
614;; vector and copies into it.  This means it's kinda risky to use lock-free hash
615;; tables with address-based keys, because they will thrash in low-memory situations,
616;; but we don't disallow it because a particular use might not have this problem.
617;;
618;; The following operations may take place:
619;;
620;; * gethash: find matching key - if no match, return not found.  Else fetch value,
621;;   if value is rehashing-value-marker then maybe-rehash and try again;
622;;   if value is free-hash-marker, return not found, else return found value.
623;;
624;; * puthash: find matching key or FREE slot.
625;;   ** If found key, fetch value.
626;;      if value is rehashing-value-marker then maybe-rehash and try again;
627;;      else store-conditional the value -> new value, if fails try again.
628;;   ** Else have FREE slot, store-key-conditional free-hash-marker -> key,
629;;      and if that succeeds, store-conditional free-hash-marker -> new value,
630;;      if either fails, maybe-rehash and try again.
631;;
632;; * remhash: find matching key - if no match, done.  Else fetch value,
633;;   if value is rehashing-value-marker then maybe-rehash and try again;
634;;   else store-conditional the value -> free-hash-marker, if fails try again.
635;;
636;; * rehash: grab a lock, estimate number of entries, make a new vector.  loop over
637;; old vector, at each entry fetch the old value with atomic swap of
638;; rehashing-value-marker.  This prevents any further state changes involving the
639;; value.  It doesn't prevent state changes involving the key, but the only ones that
640;; can happen is FREE -> DELETED, and DELETED1 <-> DELETED2, all of which are
641;; equivalent from the point of view of rehashing.  Anyway, if the old value was
642;; rehashing-value-marker then bug (because we have a lock).  If the old value is
643;; free-hash-marker then do nothing, else get the entry key and rehash into the new
644;; vector -- if no more room, start over.  When done, store the new vector in the
645;; hash table and release lock.
646;;
647;; * gc: for weak tables, gc may convert IN-USE states to DELETED2 states.
648;;   Even for non-weak tables, gc could convert DELETED1 states to DELETED2.
649
650
651(defun lock-free-rehash (hash)
652  ;;(break "We think we need to rehash ~s" (nhash.vector hash))
653  (with-lock-context
654    (without-interrupts ;; not re-entrant
655      (let ((lock (nhash.exclusion-lock hash)))
656        (%lock-recursive-lock-object lock)
657        ;; TODO: might also want to rehash if deleted entries are a large percentage
658        ;; of all entries, more or less.
659        (when (or (%i<= (nhash.grow-threshold hash) 0) ;; no room
660                  (%needs-rehashing-p (nhash.vector hash))) ;; or keys moved
661          (%lock-free-rehash hash))
662        (%unlock-recursive-lock-object lock)))))
663
664
665;; TODO: This is silly.  We're implementing atomic swap using store-conditional,
666;; but internally store-conditional is probably implemented using some kind of
667;; an atomic swap!!
668(defun atomic-swap-gvector (index gvector value)
669  (loop
670    (let ((old-value (%svref gvector index)))
671      (when (store-gvector-conditional index gvector old-value value)
672        (return old-value)))))
673
674;; Interrupts are disabled and caller has the hash lock on the table, blocking other
675;; threads attempting a rehash.
676;; Other threads might be reading/writing/deleting individual entries, but they
677;; will block if they see a value = rehashing-value-marker.
678;; GC may run, updating the needs-rehashing flags and deleting weak entries in both
679;; old and new vectors.
680(defun %lock-free-rehash (hash)
681  ;; Prevent puthash from adding new entries.  Note this doesn't keep it from undeleting
682  ;; existing entries, so we might still lose, but this makes the odds much smaller.
683  (setf (nhash.grow-threshold hash) 0)
684  (let* ((old-vector (nhash.vector hash))
685         (inherited-flags (logand $nhash_weak_flags_mask (nhash.vector.flags old-vector)))
686         count new-vector grow-threshold vector-size)
687    (tagbody
688     RESTART
689     (setq count (lock-free-count-entries hash))
690     (multiple-value-setq (grow-threshold vector-size)
691       (compute-hash-size count (nhash.rehash-size hash) (nhash.rehash-ratio hash)))
692     (setq new-vector (%cons-nhash-vector vector-size inherited-flags))
693     REHASH
694     (loop for i from $nhash.vector_overhead below (uvsize old-vector) by 2
695       do (let ((value (atomic-swap-gvector (%i+ i 1) old-vector rehashing-value-marker)))
696            (when (eq value rehashing-value-marker) (error "Who else is doing this?"))
697            (unless (eq value free-hash-marker)
698              (let* ((key (%svref old-vector i))
699                     (new-index (%growhash-probe new-vector hash key))
700                     (new-vector-index (index->vector-index new-index)))
701                (setf (%svref new-vector new-vector-index) key)
702                (setf (%svref new-vector (%i+ new-vector-index 1)) value)
703                (when (%i<= (decf grow-threshold) 0)
704                  ;; Too many entries got undeleted while we were rehashing!
705                  (go RESTART))))))
706     (when (%needs-rehashing-p new-vector) ;; keys moved, but at least can use the same new-vector.
707       (%init-misc free-hash-marker new-vector)
708       (%init-nhash-vector new-vector inherited-flags)
709       (go REHASH)))
710    (setf (nhash.vector.hash new-vector) hash)
711    (setf (nhash.grow-threshold hash) grow-threshold)
712    ;; At this point, another thread might decrement the threshold while they're looking at the old
713    ;; vector. That's ok, just means it will be too small and we'll rehash sooner than planned,
714    ;; no big deal.
715    (setf (nhash.vector hash) new-vector)))
716
717
718(defun lock-free-gethash (key hash default)
719  (declare (optimize (speed 3) (safety 0) (debug 0)))
720  (loop
721    (let* ((vector (nhash.vector hash))
722           (vector-index (funcall (the function (nhash.find hash)) hash key)))
723      (declare (fixnum vector-index))
724      ;; Need to punt if vector changed because no way to know whether nhash.find was
725      ;; using old or new vector.
726      (when (eq vector (nhash.vector hash))
727        (cond ((eql vector-index -1)
728               (unless (%needs-rehashing-p vector)
729                 (return-from lock-free-gethash (values default nil))))
730              (t (let ((value (%svref vector (%i+ vector-index 1))))
731                   (unless (eq value rehashing-value-marker)
732                     (if (eq value free-hash-marker)
733                       (return-from lock-free-gethash (values default nil))
734                       (return-from lock-free-gethash (values value t)))))))))
735    ;; We're here because the table needs rehashing or it was getting rehashed while we
736    ;; were searching. Take care of it and try again.
737    (lock-free-rehash hash)))
738
739(defun lock-free-remhash (key hash)
740  (declare (optimize (speed 3) (safety 0) (debug 0)))
741  (loop
742    (let* ((vector (nhash.vector hash))
743           (vector-index (funcall (the function (nhash.find hash)) hash key)))
744      (declare (fixnum vector-index))
745      ;; Need to punt if vector changed because no way to know whether nhash.find was
746      ;; using old or new vector.
747      (when (eq vector (nhash.vector hash))
748        (cond ((eql vector-index -1)
749               (unless (%needs-rehashing-p vector)
750                 (return-from lock-free-remhash nil)))
751              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
752                   (unless (eq old-value rehashing-value-marker)
753                     (when (eq old-value free-hash-marker)
754                       (return-from lock-free-remhash nil))
755                     (when (set-hash-value-conditional vector-index vector old-value free-hash-marker)
756                       ;; We just use this as a flag - tell gc to scan the vector for deleted keys.
757                       ;; It's just a hint, so don't worry about sync'ing
758                       (setf (nhash.vector.deleted-count vector) 1)
759                       (return-from lock-free-remhash t)))))))
760      ;; We're here because the table needs rehashing or it was getting rehashed while we
761      ;; were searching.  Take care of it and try again.
762      (lock-free-rehash hash))))
763
764(defun lock-free-clrhash (hash)
765  (with-lock-context
766    (without-interrupts
767     (let ((lock (nhash.exclusion-lock hash)))
768       (%lock-recursive-lock-object lock) ;; disallow rehashing.
769       (loop
770         with vector = (nhash.vector hash)
771         for i1 fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize vector) by 2
772         do (setf (%svref vector i1) free-hash-marker)
773         ;; We just use this as a flag - tell gc to scan the vector for deleted keys.
774         ;; It's just a hint, so don't worry about sync'ing
775         finally (setf (nhash.vector.deleted-count vector) 1))
776       (%unlock-recursive-lock-object lock))))
777  hash)
778
779(defun lock-free-puthash (key hash value)
780  (declare (optimize (speed 3) (safety 0) (debug 0)))
781  (when (or (eq value rehashing-value-marker)
782            (eq value free-hash-marker))
783    (error "Illegal value ~s for storing in a hash table" value))
784  (loop
785    (let* ((vector (nhash.vector  hash))
786           (vector-index (funcall (nhash.find-new hash) hash key)))
787      ;; Need to punt if vector changed because no way to know whether nhash.find-new was
788      ;; using old or new vector.
789      (when (eq vector (nhash.vector hash))
790        (cond ((or (eql vector-index -1)
791                   (eq (%svref vector vector-index) free-hash-marker))
792               (unless (or (%needs-rehashing-p vector)
793                           (%i<= (nhash.grow-threshold hash) 0))
794                 ;; Note if the puthash fails, grow-threshold will end up too small. This
795                 ;; just means we might rehash sooner than absolutely necessary, no real
796                 ;; harm done (the most likely cause of failing is that somebody is
797                 ;; already rehashing anyway).  DON'T try to incf it back on failure --
798                 ;; that risks grow-threshold ending up too big (e.g. if somebody rehashes
799                 ;; before the incf), which _could_ be harmful.
800                 (atomic-decf (nhash.grow-threshold hash))
801                 (if (set-hash-key-conditional vector-index vector free-hash-marker key)
802                   (when (set-hash-value-conditional vector-index vector free-hash-marker value)
803                     (return-from lock-free-puthash value)))))
804              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
805                   (unless (eq old-value rehashing-value-marker)
806                     (when (set-hash-value-conditional vector-index vector old-value value)
807                       (return-from lock-free-puthash value))))))))
808    ;; We're here because the table needs rehashing or it was getting rehashed while we
809    ;; were searching, or no room for new entry, or somebody else claimed the key from
810    ;; under us (that last case doesn't need to retry, but it's unlikely enough that
811    ;; it's not worth checking for).  Take care of it and try again.
812    (lock-free-rehash hash)))
813
814
815(defun lock-free-count-entries (hash)
816  ;; Other threads could be adding/removing entries while we count, some of
817  ;; which will be included in the count (i.e. will be treated as if they
818  ;; happened after counting) and some won't (i.e. will be treated as if
819  ;; they happened before counting), but not necessarily in correlation
820  ;; with their temporal relationship.
821  (loop
822    with vector = (nhash.vector hash)
823    for i fixnum from $nhash.vector_overhead below (uvsize vector) by 2
824    count (and (neq (%svref vector i) free-hash-marker)
825               (let ((value (%svref vector (%i+ i 1))))
826                 (when (eq value rehashing-value-marker)
827                   ;; This table is being rehashed.  Wait for it to be
828                   ;; done and try again.
829                   (lock-free-rehash hash)
830                   (return-from lock-free-count-entries (lock-free-count-entries hash)))
831                 (neq value free-hash-marker)))))
832
833;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
834
835
836(defun gethash (key hash &optional default)
837  "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
838   value and T as multiple values, or returns DEFAULT and NIL if there is no
839   such entry. Entries can be added using SETF."
840  (unless (typep hash 'hash-table)
841    (report-bad-arg hash 'hash-table))
842  (when (or (eq key free-hash-marker)
843            (eq key deleted-hash-key-marker))
844    (return-from gethash (values default nil)))
845  (when (hash-lock-free-p hash)
846    (return-from gethash (lock-free-gethash key hash default)))
847  (let* ((value nil)
848         (gc-locked nil)
849         (readonly nil)
850         (foundp nil))
851    (with-lock-context
852      (without-interrupts
853        (setq readonly (eq (read-lock-hash-table hash) :readonly))
854        (let* ((vector (nhash.vector hash)))
855          (if (and (eq key (nhash.vector.cache-key vector))
856                   ;; Check twice: the GC might nuke the cached key/value pair
857                   (progn (setq value (nhash.vector.cache-value vector))
858                          (eq key (nhash.vector.cache-key vector))))
859            (setq foundp t)
860            (loop
861              (let* ((vector-index (funcall (nhash.find hash) hash key)))
862                (declare (fixnum vector-index))
863                (cond ((setq foundp (not (eql vector-index -1)))
864                       ;; Referencing both key and value here - and referencing
865                       ;; value first - is an attempt to compensate for the
866                       ;; possibility that the GC deletes a weak-on-key pair.
867                       (setq value (%svref vector (%i+ vector-index 1)))
868                       (when (nhash.owner hash)
869                         (setf (nhash.vector.cache-key vector)
870                               (%svref vector vector-index)
871                               (nhash.vector.cache-value vector)
872                               value
873                               (nhash.vector.cache-idx vector)
874                               (vector-index->index (the fixnum vector-index))))
875                       (return))
876                      ((%needs-rehashing-p vector)
877                       (%lock-gc-lock)
878                       (setq gc-locked t)
879                       (unless readonly
880                         (let* ((lock (nhash.exclusion-lock hash)))
881                           (when lock (%promote-rwlock lock))))
882                       (when (%needs-rehashing-p vector)
883                         (%rehash hash)))
884                      (t (return)))))))
885        (when gc-locked (%unlock-gc-lock))
886        (unlock-hash-table hash readonly)))
887    (if foundp
888      (values value t)
889      (values default nil))))
890
891(defun remhash (key hash)
892  "Remove the entry in HASH-TABLE associated with KEY. Return T if there
893   was such an entry, or NIL if not."
894  (unless (typep hash 'hash-table)
895    (setq hash (require-type hash 'hash-table)))
896  (when (hash-lock-free-p hash)
897    (return-from remhash (lock-free-remhash key hash)))
898  (let* ((foundp nil))
899    (with-lock-context
900      (without-interrupts
901       (write-lock-hash-table hash)
902       (%lock-gc-lock)
903       (let* ((vector (nhash.vector hash)))
904         (when (%needs-rehashing-p vector)
905           (%rehash hash))
906         (if (eq key (nhash.vector.cache-key vector))
907           (progn
908             (setf (nhash.vector.cache-key vector) free-hash-marker
909                   (nhash.vector.cache-value vector) nil)
910             (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
911               (setf (%svref vector vidx) deleted-hash-key-marker)
912               (setf (%svref vector (the fixnum (1+ vidx))) nil))
913             (incf (the fixnum (nhash.vector.deleted-count vector)))
914             (decf (the fixnum (nhash.vector.count vector)))
915             (setq foundp t))
916           (let* ((vector-index (funcall (nhash.find hash) hash key)))
917             (declare (fixnum vector-index))
918             (unless (eql vector-index -1)
919               ;; always clear the cache cause I'm too lazy to call the
920               ;; comparison function and don't want to keep a possibly
921               ;; deleted key from being GC'd
922               (setf (nhash.vector.cache-key vector) free-hash-marker
923                     (nhash.vector.cache-value vector) nil)
924               ;; Update the count
925               (incf (the fixnum (nhash.vector.deleted-count vector)))
926               (decf (the fixnum (nhash.vector.count vector)))
927               ;; Delete the value from the table.
928               (setf (%svref vector vector-index) deleted-hash-key-marker
929                     (%svref vector (the fixnum (1+ vector-index))) nil)
930               (setq foundp t))))
931         (when (and foundp
932                    (zerop (the fixnum (nhash.vector.count vector))))
933           (do* ((i $nhash.vector_overhead (1+ i))
934                 (n (uvsize vector)))
935                ((= i n))
936             (declare (fixnum i n))
937             (setf (%svref vector i) free-hash-marker))
938           (setf (nhash.grow-threshold hash)
939                 (+ (nhash.vector.deleted-count vector)
940                    (nhash.vector.weak-deletions-count vector)
941                    (nhash.grow-threshold hash))
942                 (nhash.vector.deleted-count vector) 0
943                 (nhash.vector.weak-deletions-count vector) 0)))
944       ;; Return T if we deleted something
945       (%unlock-gc-lock)
946       (unlock-hash-table hash nil)))
947    foundp))
948
949;;; what if somebody is mapping, growing, rehashing?
950(defun clrhash (hash)
951  "This removes all the entries from HASH-TABLE and returns the hash table
952   itself."
953  (unless (typep hash 'hash-table)
954    (report-bad-arg hash 'hash-table))
955  (when (hash-lock-free-p hash)
956    (return-from clrhash (lock-free-clrhash hash)))
957  (with-lock-context
958    (without-interrupts
959     (write-lock-hash-table hash)
960     (let* ((vector (nhash.vector hash))
961            (size (nhash.vector-size vector))
962            (count (+ size size))
963            (index $nhash.vector_overhead))
964       (declare (fixnum size count index))
965       (dotimes (i count)
966         (setf (%svref vector index) free-hash-marker)
967         (incf index))
968       (incf (the fixnum (nhash.grow-threshold hash))
969             (the fixnum (+ (the fixnum (nhash.vector.count vector))
970                            (the fixnum (nhash.vector.deleted-count vector)))))
971       (setf (nhash.vector.count vector) 0
972             (nhash.vector.cache-key vector) free-hash-marker
973             (nhash.vector.cache-value vector) nil
974             (nhash.vector.finalization-alist vector) nil
975             (nhash.vector.free-alist vector) nil
976             (nhash.vector.weak-deletions-count vector) 0
977             (nhash.vector.deleted-count vector) 0
978             (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
979                                                 (nhash.vector.flags vector))))
980     (unlock-hash-table hash nil)
981     hash)))
982
983
984(defun puthash (key hash default &optional (value default))
985  (declare (optimize (speed 3) (space 0)))
986  (unless (typep hash 'hash-table)
987    (report-bad-arg hash 'hash-table))
988  (when (or (eq key free-hash-marker)
989            (eq key deleted-hash-key-marker))
990    (error "Can't use ~s as a hash-table key" key))
991  (when (hash-lock-free-p hash)
992    (return-from puthash (lock-free-puthash key hash value)))
993  (with-lock-context
994    (without-interrupts
995     (block protected
996       (tagbody
997          (write-lock-hash-table hash)
998        AGAIN
999          (%lock-gc-lock)
1000          (let ((vector (nhash.vector hash)))
1001            (when (%needs-rehashing-p vector)
1002              (%rehash hash))
1003            (when (eq key (nhash.vector.cache-key vector))
1004              (let* ((idx (nhash.vector.cache-idx vector)))
1005                (declare (fixnum idx))
1006                (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
1007                      value)
1008                (setf (nhash.vector.cache-value vector) value)
1009                (return-from protected)))               
1010            (let* ((vector-index (funcall (nhash.find-new hash) hash key))
1011                   (old-value (%svref vector vector-index)))
1012              (declare (fixnum vector-index))
1013
1014              (cond ((eq old-value deleted-hash-key-marker)
1015                     (%set-hash-table-vector-key vector vector-index key)
1016                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
1017                     (incf (the fixnum (nhash.vector.count vector)))
1018                     ;; Adjust deleted-count
1019                     (when (> 0 (the fixnum
1020                                  (decf (the fixnum
1021                                          (nhash.vector.deleted-count vector)))))
1022                       (%normalize-hash-table-count hash)))
1023                    ((eq old-value free-hash-marker)
1024                     (when (eql 0 (nhash.grow-threshold hash))
1025                       (%unlock-gc-lock)
1026                       (%grow-hash-table hash)
1027                       (go AGAIN))
1028                     (%set-hash-table-vector-key vector vector-index key)
1029                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
1030                     (decf (the fixnum (nhash.grow-threshold hash)))
1031                     (incf (the fixnum (nhash.vector.count vector))))
1032                    (t
1033                     ;; Key was already there, update value.
1034                     (setf (%svref vector (the fixnum (1+ vector-index))) value)))
1035              (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
1036                    (nhash.vector.cache-key vector) key
1037                    (nhash.vector.cache-value vector) value)))))
1038     (%unlock-gc-lock)
1039     (unlock-hash-table hash nil)))
1040  value)
1041
1042
1043(defun count-entries (hash)
1044  (if (hash-lock-free-p hash)
1045    (lock-free-count-entries hash)
1046    (let* ((vector (nhash.vector hash))
1047           (size (uvsize vector))
1048           (idx $nhash.vector_overhead)
1049           (count 0))
1050      (loop
1051        (when (neq (%svref vector idx) free-hash-marker)
1052          (incf count))
1053        (when (>= (setq idx (+ idx 2)) size)
1054          (return count))))))
1055
1056
1057
1058
1059
1060     
1061
1062(defun grow-hash-table (hash)
1063  (unless (typep hash 'hash-table)
1064    (setq hash (require-type hash 'hash-table)))
1065  (%grow-hash-table hash))
1066
1067;;; Interrupts are disabled, and the caller has an exclusive
1068;;; lock on the hash table.
1069(defun %grow-hash-table (hash)
1070  (block grow-hash-table
1071    (%normalize-hash-table-count hash)
1072    (let* ((old-vector (nhash.vector hash))
1073           (old-size (nhash.vector.count old-vector))
1074           (old-total-size (nhash.vector.size old-vector))
1075           (flags 0)
1076           (flags-sans-weak 0)
1077           (weak-flags nil))
1078      (declare (fixnum old-total-size flags flags-sans-weak))
1079      (when (> (nhash.vector.deleted-count old-vector) 0)
1080        ;; There are enough deleted entries. Rehash to get rid of them
1081        (%rehash hash)
1082        (return-from grow-hash-table))
1083      (multiple-value-bind (size total-size)
1084                           (compute-hash-size 
1085                            old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash))
1086        (unless (eql 0 (nhash.grow-threshold hash))       ; maybe it's done already - shouldnt happen               
1087          (return-from grow-hash-table ))
1088        (progn
1089          (unwind-protect
1090            (let ((gc-count (%get-gc-count))
1091                  vector)
1092              (setq flags (nhash.vector.flags old-vector)
1093                    flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask))
1094                    weak-flags (logand flags $nhash_weak_flags_mask))
1095              (setf (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
1096              (%normalize-hash-table-count hash)
1097              (when (> (nhash.vector.deleted-count old-vector) 0)
1098                (setf (nhash.vector.flags old-vector) flags)
1099                (setq weak-flags nil)
1100                (return-from grow-hash-table (%rehash hash)))
1101              (setq vector (%cons-nhash-vector total-size 0))
1102              (do* ((index 0 (1+ index))
1103                    (vector-index (index->vector-index 0) (+ vector-index 2)))
1104                   ((>= index old-total-size))
1105                (declare (fixnum index vector-index))
1106               
1107                 (let ((key (%svref old-vector vector-index)))
1108                   (unless (or (eq key free-hash-marker)
1109                               (eq key deleted-hash-key-marker))
1110                     (let* ((new-index (%growhash-probe vector hash key))
1111                            (new-vector-index (index->vector-index new-index)))
1112                       (setf (%svref vector new-vector-index) key)
1113                       (setf (%svref vector (the fixnum (1+ new-vector-index)))
1114                             (%svref old-vector (the fixnum (1+ vector-index))))))))
1115              (progn
1116               (setf (nhash.vector.finalization-alist vector)
1117                     (nhash.vector.finalization-alist old-vector)
1118                     (nhash.vector.free-alist vector)
1119                     (nhash.vector.free-alist old-vector)
1120                     (nhash.vector.count vector) old-size
1121                     (nhash.vector.flags vector)
1122                     (logior (the fixnum weak-flags)
1123                             (the fixnum (nhash.vector.flags vector))))
1124               (setf (nhash.rehash-bits hash) nil
1125                     (nhash.vector hash) vector
1126                     (nhash.vector.hash vector) hash
1127                     (nhash.vector.cache-key vector) free-hash-marker
1128                     (nhash.vector.cache-value vector) nil
1129                     (nhash.vector.gc-count vector) gc-count
1130                     (nhash.grow-threshold hash) (- size old-size))
1131               (setq weak-flags nil)       ; tell clean-up form we finished the loop
1132               ;; If the old vector's in some static heap, zero it
1133               ;; so that less garbage is retained.
1134               (%init-misc 0 old-vector)))
1135            (when weak-flags
1136              (setf (nhash.vector.flags old-vector)
1137                    (logior (the fixnum weak-flags)
1138                            (the fixnum (nhash.vector.flags old-vector)))))))))))
1139
1140
1141
1142(defun general-hash-find (hash key)
1143  (%hash-probe hash key nil))
1144
1145(defun general-hash-find-for-put (hash key)
1146  (%hash-probe hash key (if (hash-lock-free-p hash) :free :reuse)))
1147
1148;;; returns a single value:
1149;;;   index - the index in the vector for key (where it was or where
1150;;;           to insert if the current key at that index is deleted-hash-key-marker
1151;;;           or free-hash-marker)
1152
1153
1154
1155(defun %hash-probe (hash key for-put-p)
1156  (declare (optimize (speed 3) (space 0)))
1157  (multiple-value-bind (hash-code index entries)
1158                       (compute-hash-code hash key for-put-p)
1159    (locally (declare (fixnum hash-code index entries))
1160      (let* ((compareF (nhash.compareF hash))
1161             (vector (nhash.vector hash))
1162             (vector-index 0)
1163             table-key
1164             (first-deleted-index nil))
1165        (declare (fixnum vector-index))
1166        (macrolet ((return-it (form)
1167                     `(return-from %hash-probe ,form)))
1168          (macrolet ((test-it (predicate)
1169                       (unless (listp predicate) (setq predicate (list predicate)))
1170                       `(progn
1171                          (setq vector-index (index->vector-index index)
1172                                table-key (%svref vector vector-index))
1173                          (cond ((eq table-key free-hash-marker)
1174                                 (return-it (if for-put-p
1175                                              (or first-deleted-index
1176                                                  vector-index)
1177                                              -1)))
1178                                ((eq table-key deleted-hash-key-marker)
1179                                 (when (and (eq for-put-p :reuse)
1180                                            (null first-deleted-index))
1181                                   (setq first-deleted-index vector-index)))
1182                                ((,@predicate key table-key)
1183                                 (return-it vector-index))))))
1184            (macrolet ((do-it (predicate)
1185                         `(progn
1186                            (test-it ,predicate)
1187                            ; First probe failed. Iterate on secondary key
1188                            (let ((initial-index index)
1189                                  (secondary-hash (%svref secondary-keys (logand 7 hash-code))))
1190                              (declare (fixnum secondary-hash initial-index))
1191                              (loop
1192                                (incf index secondary-hash)
1193                                (when (>= index entries)
1194                                  (decf index entries))
1195                                (when (eql index initial-index)
1196                                  (return-it (if for-put-p
1197                                               (or first-deleted-index
1198                                                   (error "Bug: no room in table"))
1199                                               -1)))
1200                                (test-it ,predicate))))))
1201              (if (fixnump comparef)
1202                ;; EQ or EQL hash table
1203                (if (or (eql 0 comparef)
1204                        (immediate-p-macro key)
1205                        (not (need-use-eql key)))
1206                  ;; EQ hash table or EQL == EQ for KEY
1207                  (do-it eq)
1208                  (do-it eql))
1209                ;; general compare function
1210                (do-it (funcall comparef))))))))))
1211
1212(defun eq-hash-find (hash key)
1213  (declare (optimize (speed 3) (safety 0)))
1214  (let* ((vector (nhash.vector hash))
1215         (hash-code
1216          (let* ((typecode (typecode key)))
1217            (if (eq typecode target::tag-fixnum)
1218              (mixup-hash-code key)
1219              (if (eq typecode target::subtag-instance)
1220                (mixup-hash-code (instance.hash key))
1221                (if (symbolp key)
1222                  (%hash-symbol key)
1223                  (mixup-hash-code (strip-tag-to-fixnum key)))))))
1224         (entries (nhash.vector-size vector))
1225         (vector-index (index->vector-index (hash-mod hash-code entries vector)))
1226         (table-key (%svref vector vector-index)))
1227    (declare (fixnum hash-code  entries vector-index))
1228    (if (eq table-key key)
1229      vector-index
1230      (if (eq table-key free-hash-marker)
1231        -1
1232        (let* ((secondary-hash (%svref secondary-keys-*-2
1233                                       (logand 7 hash-code)))
1234               (initial-index vector-index)             
1235               (count (+ entries entries))
1236               (length (+ count $nhash.vector_overhead)))
1237          (declare (fixnum secondary-hash initial-index count length))
1238          (loop
1239            (incf vector-index secondary-hash)
1240            (when (>= vector-index length)
1241              (decf vector-index count))
1242            (setq table-key (%svref vector vector-index))
1243            (when (= vector-index initial-index)
1244              (return -1))
1245            (if (eq table-key key)
1246              (return vector-index)
1247              (when (eq table-key free-hash-marker)
1248                (return -1)))))))))
1249
1250;;; As above, but note whether the key is in some way address-based
1251;;; and update the hash-vector's flags word if so.
1252;;; This only needs to be done by PUTHASH, and it only really needs
1253;;; to be done if we're adding a new key.
1254(defun eq-hash-find-for-put (hash key)
1255  (declare (optimize (speed 3) (safety 0)))
1256  (let* ((vector (nhash.vector hash))
1257         (hash-code
1258          (let* ((typecode (typecode key)))
1259            (if (eq typecode target::tag-fixnum)
1260              (mixup-hash-code key)
1261              (if (eq typecode target::subtag-instance)
1262                (mixup-hash-code (instance.hash key))
1263                (if (symbolp key)
1264                  (%hash-symbol key)
1265                  (progn
1266                    (unless (immediate-p-macro key)
1267                      (update-hash-flags hash vector :key))
1268                    (mixup-hash-code (strip-tag-to-fixnum key))))))))
1269         (entries (nhash.vector-size vector))
1270         (vector-index (index->vector-index (hash-mod hash-code entries vector)))
1271         (table-key (%svref vector vector-index))
1272         (reuse (not (hash-lock-free-p hash))))
1273    (declare (fixnum hash-code vector-index))
1274    (if (or (eq key table-key)
1275            (eq table-key free-hash-marker))
1276      vector-index
1277      (let* ((secondary-hash (%svref secondary-keys-*-2
1278                                     (logand 7 hash-code)))
1279             (initial-index vector-index)             
1280             (first-deleted-index (and reuse
1281                                       (eq table-key deleted-hash-key-marker)
1282                                       vector-index))
1283             (count (+ entries entries))
1284             (length (+ count $nhash.vector_overhead)))
1285        (declare (fixnum secondary-hash initial-index count length))
1286        (loop
1287          (incf vector-index secondary-hash)
1288          (when (>= vector-index length)
1289            (decf vector-index count))
1290          (setq table-key (%svref vector vector-index))
1291          (when (= vector-index initial-index)
1292            (return (or first-deleted-index
1293                        (error "Bug: no room in table"))))
1294          (if (eq table-key key)
1295            (return vector-index)
1296            (if (eq table-key free-hash-marker)
1297              (return (or first-deleted-index vector-index))
1298              (if (and reuse
1299                       (null first-deleted-index)
1300                       (eq table-key deleted-hash-key-marker))
1301                (setq first-deleted-index vector-index)))))))))
1302
1303(defun eql-hash-find (hash key)
1304  (declare (optimize (speed 3) (safety 0)))
1305  (if (need-use-eql key)
1306    (let* ((vector (nhash.vector hash))
1307           (hash-code (%%eqlhash-internal key))
1308           (entries (nhash.vector-size vector))
1309           (vector-index (index->vector-index (hash-mod hash-code entries vector)))
1310           (table-key (%svref vector vector-index)))
1311      (declare (fixnum hash-code entries vector-index))
1312      (if (eql key table-key)
1313        vector-index
1314        (if (eq table-key free-hash-marker)
1315          -1
1316          (let* ((secondary-hash (%svref secondary-keys-*-2
1317                                         (logand 7 hash-code)))
1318                 (initial-index vector-index)
1319                 (count (+ entries entries))
1320                 (length (+ count $nhash.vector_overhead)))
1321            (declare (fixnum secondary-hash initial-index count length))
1322            (loop
1323              (incf vector-index secondary-hash)
1324              (when (>= vector-index length)
1325                (decf vector-index count))
1326              (setq table-key (%svref vector vector-index))
1327              (when (= vector-index initial-index)
1328                (return -1))
1329              (if (eql table-key key)
1330                (return vector-index)
1331                (when (eq table-key free-hash-marker)
1332                  (return -1))))))))
1333    (eq-hash-find hash key)))
1334
1335(defun eql-hash-find-for-put (hash key)
1336  (declare (optimize (speed 3) (safety 0)))
1337  (if (need-use-eql key)
1338    (let* ((vector (nhash.vector hash))
1339           (hash-code (%%eqlhash-internal key))
1340           (entries (nhash.vector-size vector))
1341           (vector-index (index->vector-index (hash-mod hash-code entries vector)))
1342           (table-key (%svref vector vector-index))
1343           (reuse (not (hash-lock-free-p hash))))
1344      (declare (fixnum hash-code entries vector-index))
1345      (if (or (eql key table-key)
1346              (eq table-key free-hash-marker))
1347        vector-index
1348        (let* ((secondary-hash (%svref secondary-keys-*-2
1349                                       (logand 7 hash-code)))
1350               (initial-index vector-index)
1351               (first-deleted-index (and reuse
1352                                         (eq table-key deleted-hash-key-marker)
1353                                         vector-index))
1354               (count (+ entries entries))
1355               (length (+ count $nhash.vector_overhead)))
1356          (declare (fixnum secondary-hash initial-index count length))
1357          (loop
1358            (incf vector-index secondary-hash)
1359            (when (>= vector-index length)
1360              (decf vector-index count))
1361            (setq table-key (%svref vector vector-index))
1362            (when (= vector-index initial-index)
1363              (return (or first-deleted-index
1364                          (error "Bug: no room in table"))))
1365            (if (eql table-key key)
1366              (return vector-index)
1367              (if (eq table-key free-hash-marker)
1368                (return (or first-deleted-index vector-index))
1369                (if (and reuse
1370                         (null first-deleted-index)
1371                         (eq table-key deleted-hash-key-marker))
1372                  (setq first-deleted-index vector-index))))))))
1373    (eq-hash-find-for-put hash key)))
1374
1375(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash))))
1376  (declare (fixnum size))
1377  (let ((rehash-bits (nhash.rehash-bits hash)))
1378    (unless (and rehash-bits
1379                 (>= (uvsize rehash-bits) size))
1380      (return-from %make-rehash-bits
1381        (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0))))
1382    (fill (the simple-bit-vector rehash-bits) 0)))
1383
1384;;; Rehash.  Caller should have exclusive access to the hash table
1385;;; and have disabled interrupts.
1386(defun %rehash (hash)
1387  (when (hash-lock-free-p hash)
1388    (error "How did we get here?"))
1389  (let* ((vector (nhash.vector hash))
1390         (flags (nhash.vector.flags vector))
1391         (vector-index (- $nhash.vector_overhead 2))
1392         (size (nhash.vector-size vector))
1393         (rehash-bits (%make-rehash-bits hash size))
1394         (index -1))
1395    (declare (fixnum size index vector-index))
1396    (setf (nhash.vector.flags vector)
1397          (logand flags $nhash-clear-key-bits-mask))
1398    (setf (nhash.vector.cache-key vector) free-hash-marker
1399          (nhash.vector.cache-value vector) nil)
1400    (%set-does-not-need-rehashing hash)
1401    (loop
1402      (when (>= (incf index) size) (return))
1403      (setq vector-index (+ vector-index 2))
1404      (unless (%already-rehashed-p index rehash-bits)
1405        (let* ((key (%svref vector vector-index))
1406               (deleted (eq key deleted-hash-key-marker)))
1407          (unless
1408            (when (or deleted (eq key free-hash-marker))
1409              (if deleted  ; one less deleted entry
1410                (let ((count (1- (nhash.vector.deleted-count vector))))
1411                  (declare (fixnum count))
1412                  (setf (nhash.vector.deleted-count vector) count)
1413                  (if (< count 0)
1414                    (let ((wdc (nhash.vector.weak-deletions-count vector)))
1415                      (setf (nhash.vector.weak-deletions-count vector) 0)
1416                      (incf (nhash.vector.deleted-count vector) wdc)
1417                      (decf (nhash.vector.count vector) wdc)))
1418                  (incf (nhash.grow-threshold hash))
1419                  ;; Change deleted to free
1420                  (setf (%svref vector vector-index) free-hash-marker)))
1421              t)
1422            (let* ((last-index index)
1423                   (value (%svref vector (the fixnum (1+ vector-index))))
1424                   (first t))
1425                (loop
1426                  (let ((vector (nhash.vector hash))
1427                        (found-index (%rehash-probe rehash-bits hash key)))
1428                    (%set-already-rehashed-p found-index rehash-bits)
1429                    (if (eq last-index found-index)
1430                      (return)
1431                      (let* ((found-vector-index (index->vector-index found-index))
1432                             (newkey (%svref vector found-vector-index))
1433                             (newvalue (%svref vector (the fixnum (1+ found-vector-index)))))
1434                        (declare (fixnum found-vector-index))
1435                        (when first ; or (eq last-index index) ?
1436                          (setq first nil)
1437                          (setf (%svref vector vector-index) free-hash-marker)
1438                          (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker))
1439                        (%set-hash-table-vector-key vector found-vector-index key)
1440                        (setf (%svref vector (the fixnum (1+ found-vector-index))) value)                       
1441                        (when (or (eq newkey free-hash-marker)
1442                                  (setq deleted (eq newkey deleted-hash-key-marker)))
1443                          (when deleted
1444                            (let ((count (1- (nhash.vector.deleted-count vector))))
1445                              (declare (fixnum count))
1446                              (setf (nhash.vector.deleted-count vector) count)
1447                              (if (< count 0)
1448                                (let ((wdc (nhash.vector.weak-deletions-count vector)))
1449                                  (setf (nhash.vector.weak-deletions-count vector) 0)
1450                                  (incf (nhash.vector.deleted-count vector) wdc)
1451                                  (decf (nhash.vector.count vector) wdc)))
1452                              (incf (nhash.grow-threshold hash))))
1453                          (return))
1454                        (when (eq key newkey)
1455                          (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
1456                                  key hash value newvalue index found-index)                       
1457                          (decf (nhash.vector.count vector))
1458                          (incf (nhash.grow-threshold hash))
1459                          (return))
1460                        (setq key newkey
1461                              value newvalue
1462                              last-index found-index)))))))))))
1463    t )
1464
1465;;; Hash to an index that is not set in rehash-bits
1466 
1467(defun %rehash-probe (rehash-bits hash key)
1468  (declare (optimize (speed 3)(safety 0))) 
1469  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t)
1470    (declare (fixnum hash-code index entries))
1471    (when (null hash-code)(cerror "nuts" "Nuts"))
1472    (let* ((vector (nhash.vector hash))
1473           (vector-index (index->vector-index  index)))
1474      (if (or (not (%already-rehashed-p index rehash-bits))
1475              (eq key (%svref vector vector-index)))
1476        (return-from %rehash-probe index)
1477        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1478          (declare (fixnum second))
1479          (loop
1480            (setq index (+ index second))
1481            (when (>= index entries)
1482              (setq index (- index entries)))
1483            (when (or (not (%already-rehashed-p index rehash-bits))
1484                      (eq key (%svref vector (index->vector-index index))))
1485              (return-from %rehash-probe index))))))))
1486
1487;;; Returns one value: the index of the entry in the vector
1488;;; Since we're growing, we don't need to compare and can't find a key that's
1489;;; already there.
1490(defun %growhash-probe (vector hash key)
1491  (declare (optimize (speed 3)(safety 0)))
1492  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector)
1493    (declare (fixnum hash-code index entries))
1494    (let* ((vector-index (index->vector-index  index))
1495           (vector-key nil))
1496      (declare (fixnum vector-index))
1497      (if (or (eq free-hash-marker
1498                  (setq vector-key (%svref vector vector-index)))
1499              (eq deleted-hash-key-marker vector-key))
1500        (return-from %growhash-probe index)
1501        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1502          (declare (fixnum second))
1503          (loop
1504            (setq index (+ index second))
1505            (when (>= index entries)
1506              (setq index (- index entries)))
1507            (when (or (eq free-hash-marker
1508                          (setq vector-key (%svref vector (index->vector-index index))))
1509                      (eq deleted-hash-key-marker vector-key))
1510              (return-from %growhash-probe index))))))))
1511
1512;;;;;;;;;;;;;
1513;;
1514;; Mapping functions are in "ccl:lib;hash"
1515;;
1516
1517
1518
1519;;;;;;;;;;;;;
1520;;
1521;; Hashing functions
1522;; EQ & the EQ part of EQL are done in-line.
1523;;
1524
1525
1526
1527
1528
1529
1530
1531
1532
1533;;; so whats so special about bit vectors as opposed to any other vectors of bytes
1534;;; For starters, it's guaranteed that they exist in the implementation; that may
1535;;; not be true of other immediate vector types.
1536(defun bit-vector-hash (bv)
1537  (declare (optimize (speed 3)(safety 0)))
1538  (let ((length (length bv)))
1539    (declare (fixnum length)) ;will this always be true? it's true of all vectors.
1540    (multiple-value-bind (data offset) (array-data-and-offset bv)
1541      (declare (type simple-bit-vector data) (fixnum offset))
1542      (let* ((hash 0)
1543             (limit (+ length offset))
1544             (nbytes (ash (the fixnum (+ length 7)) -3)))
1545        (declare (fixnum hash limit nbytes))
1546        (dotimes (i nbytes (mixup-hash-code hash))
1547          (let* ((w 0))
1548            (declare (fixnum w))
1549            (dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3))  w)))
1550              (setq w (the fixnum
1551                        (logxor
1552                         (the fixnum
1553                           (ash (if (< offset limit) 
1554                                  (the fixnum (sbit data offset))
1555                                  0)
1556                                (the fixnum j)))
1557                         w)))
1558              (incf offset))))))))
1559
1560#|
1561(defun bit-vector-hash (bv)
1562  (declare (optimize (speed 3)(safety 0)))
1563  (let ((length (length bv)))
1564    (declare (fixnum length))
1565    (let* ((all (+ length 15))
1566           (nwds (ash all -4))
1567           (rem (logand all 15))
1568           (hash 0)
1569           (mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem)))))
1570      (declare (fixnum all nwds rem hash mask))
1571      (multiple-value-bind (data offset)
1572                           (array-data-and-offset bv)
1573        (declare (fixnum offset))
1574        (locally (declare (type (simple-array (unsigned-byte 16) (*)) data))
1575          (dotimes (i nwds)
1576            (setq hash (%i+ hash (aref data (the fixnum (+ i offset))))))
1577          (when (neq 0 mask)           
1578            (setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds)))))))
1579          (mixup-hash-code hash))))))
1580|#
1581
1582
1583;;; Same as %%equalhash, but different:
1584;;;  1) Real numbers are hashed as if they were double-floats.  The real components of complex numbers
1585;;;     are hashed as double-floats and XORed together.
1586;;;  2) Characters and strings are hashed in a case-insensitive manner.
1587;;;  3) Hash tables are hashed based on their size and type.
1588;;;  4) Structures and CL array types are hashed based on their content.
1589
1590
1591;;; check fixnum befor immediate-p. call %%eqlhash
1592
1593(defun %%equalphash (key)
1594  (cond ((or (fixnump key)(short-float-p key))
1595         (%dfloat-hash (float key 1.0d0))) 
1596        ((immediate-p-macro key)
1597         (mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key))))
1598        ((bignump key)
1599         (if (<= most-negative-double-float key most-positive-double-float)
1600           (%dfloat-hash (float key 1.0d0))  ; with-stack-double-floats
1601           (%%eqlhash-internal key)))
1602        ((double-float-p key)
1603         (%dfloat-hash key))
1604        ((ratiop key)
1605         (%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key))))
1606        ((complexp key)
1607         (%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key))))
1608        ((hash-table-p key)
1609         (equalphash-hash-table key))
1610        ((or (istructp key)
1611             (structurep key))  ; was (gvectorp key)
1612         (%%equalphash-structure 11 key))
1613        ((or (arrayp key)) ;(uvectorp key)) ;??
1614         (%%equalphash-array 11 key))
1615        ((consp key)
1616         (%%equalphash-aux 11 key))
1617        (t (%%eqlhash key))))
1618
1619
1620(defun equalphash-hash-table (hash-table)
1621  (let ((hash (%%equalhash "HASH-TABLE"))
1622        addressp)
1623    (declare (fixnum hash))
1624    (incf hash (the fixnum (%%eqhash (hash-table-count hash-table))))
1625    (multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table))
1626      (declare (fixnum h))
1627      (incf hash h)
1628      (if ap (setq addressp t)))
1629    (multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table))
1630      (declare (fixnum h))
1631      (incf hash h)
1632      (if ap (setq addressp t)))
1633    (values hash addressp)))
1634
1635(defun %%equalphash-structure (limit key)
1636  (let* ((size (uvsize key))
1637         (hash (mixup-hash-code size))
1638         addressp)
1639    (declare (fixnum limit size hash))
1640    (dotimes (i size)
1641      (multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i))
1642        (declare (fixnum h))
1643        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1644        (if ap (setq addressp t)))
1645      (when (<= (decf limit) 0)
1646        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1647                                  (the fixnum (mixup-hash-code 11)))))
1648        (return)))
1649    (values hash addressp)))
1650
1651(defun %%equalphash-array (limit key)
1652  (multiple-value-bind (array offset) (array-data-and-offset key)
1653    (let* ((rank (array-rank key))
1654           (vectorp (eql rank 1))
1655           (size (if vectorp (length key) (array-total-size key)))
1656           (hash (mixup-hash-code rank))
1657           addressp)
1658      (declare (fixnum size hash limit rank))
1659      (if vectorp
1660        (setq hash
1661              (the fixnum
1662                   (+ (the fixnum (rotate-hash-code hash))
1663                      (the fixnum (mixup-hash-code size)))))
1664        (dotimes (i rank)
1665          (declare (fixnum i))
1666          (setq hash
1667                (the fixnum 
1668                     (+ (the fixnum (rotate-hash-code hash))
1669                        (the fixnum
1670                             (mixup-hash-code (array-dimension key i))))))))     
1671      (dotimes (i size)
1672        (declare (fixnum i))
1673        (multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset))
1674          (declare (fixnum h))
1675          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1676          (if ap (setq addressp t)))
1677        (when (<= (decf limit) 0)
1678          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1679                                    (the fixnum (mixup-hash-code 11)))))
1680          (return))
1681        (incf offset))
1682      (values hash addressp))))
1683
1684(defun %%equalphash-aux (limit key)
1685  (if (<= limit 0) 
1686    (mixup-hash-code 11)
1687    (if (null key) (mixup-hash-code 17)
1688        (cond ((consp key)
1689               (let ((hash 0)
1690                     address-p)
1691                 (do ((l limit (1- l)))
1692                     ((eq l 0)(values hash address-p))
1693                   (multiple-value-bind (ahash ap)
1694                                        (%%equalphash-aux l (if (consp key)(car key) key))
1695                     (setq hash (mixup-hash-code (logxor ahash hash)))
1696                     (if ap (setq address-p t)))
1697                   (when (not (consp key))
1698                     (return (values hash address-p)))
1699                   (setq key (cdr key)))))
1700              ((typep key 'hash-table)
1701               (equalphash-hash-table key))
1702              ; what are the dudes called that contain bits? they are uvectors but not gvectors?
1703              ; ivectors.
1704              ((or (istructp key)
1705                   (structurep key))    ;was (gvectorp key)
1706               (%%equalphash-structure limit key))
1707              ((or (arrayp key))  ; (uvectorp key))
1708               (%%equalphash-array limit key))
1709              (t (%%equalphash key))))))
1710
1711(defun alist-hash-table (alist &rest hash-table-args)
1712  (declare (dynamic-extent hash-table-args))
1713  (if (typep alist 'hash-table)
1714    alist
1715    (let ((hash-table (apply #'make-hash-table hash-table-args)))
1716      (dolist (cons alist) (puthash (car cons) hash-table (cdr cons)))
1717      hash-table)))
1718
1719(defun %hash-table-equalp (x y)
1720  ;; X and Y are both hash tables
1721  (and (eq (hash-table-test x)
1722           (hash-table-test y))
1723       (eql (hash-table-count x)
1724            (hash-table-count y))
1725       (block nil
1726         (let* ((default (cons nil nil))
1727                (foo #'(lambda (k v)
1728                         (let ((y-value (gethash k y default)))
1729                           (unless (and (neq default y-value)
1730                                        (equalp v y-value))
1731                             (return nil))))))
1732           (declare (dynamic-extent foo default))
1733           (maphash foo x))
1734         t)))
1735
1736(defun sxhash (s-expr)
1737  "Computes a hash code for S-EXPR and returns it as an integer."
1738  (logand (sxhash-aux s-expr 7 17) target::target-most-positive-fixnum))
1739
1740(defun sxhash-aux (expr counter key)
1741  (declare (fixnum counter))
1742  (if (> counter 0)
1743    (typecase expr
1744      ((or string bit-vector number character)  (+ key (%%equalhash expr)))
1745      ((or pathname logical-pathname)
1746       (dotimes (i (uvsize expr) key)
1747         (declare (fixnum i))
1748         (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))
1749      (symbol (+ key (%%equalhash (symbol-name expr))))
1750      (cons (sxhash-aux
1751             (cdr expr)
1752             (the fixnum (1- counter))             
1753             (+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key))))
1754      (t (+  key (%%equalhash (symbol-name (%type-of expr))))))
1755    key))
1756
1757
1758
1759#+(or ppc32-target x8632-target)
1760(defun immediate-p (thing)
1761  (let* ((tag (lisptag thing)))
1762    (declare (fixnum tag))
1763    (or (= tag target::tag-fixnum)
1764        (= tag target::tag-imm))))
1765
1766#+ppc64-target
1767(defun immediate-p (thing)
1768  (let* ((tag (lisptag thing)))
1769    (declare (fixnum tag))
1770    (or (= tag ppc64::tag-fixnum)
1771        (= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm))))
1772
1773#+x8664-target
1774(defun immediate-p (thing)
1775  (let* ((tag (lisptag thing)))
1776    (declare (type (unsigned-byte 3) tag))
1777    (logbitp tag
1778             (logior (ash 1 x8664::tag-fixnum)
1779                     (ash 1 x8664::tag-imm-0)
1780                     (ash 1 x8664::tag-imm-1)))))
1781
1782
1783
1784(defun %cons-nhash-vector (size &optional (flags 0))
1785  (declare (fixnum size))
1786  (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector free-hash-marker)))
1787    (%init-nhash-vector vector flags)
1788    vector))
1789
1790(defun %init-nhash-vector (vector flags)
1791  (let ((size (vector-index->index (uvsize vector))))
1792    (declare (fixnum size))
1793    (setf (nhash.vector.link vector) 0
1794          (nhash.vector.flags vector) flags
1795          (nhash.vector.gc-count vector) (%get-gc-count)
1796          (nhash.vector.free-alist vector) nil
1797          (nhash.vector.finalization-alist vector) nil
1798          (nhash.vector.weak-deletions-count vector) 0
1799          (nhash.vector.hash vector) nil
1800          (nhash.vector.deleted-count vector) 0
1801          (nhash.vector.count vector) 0
1802          (nhash.vector.cache-key vector) free-hash-marker
1803          (nhash.vector.cache-value vector) nil
1804          (nhash.vector.cache-idx vector) nil
1805          (nhash.vector.size vector) size
1806          (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size))))
1807
1808(defun assert-hash-table-readonly (hash)
1809  (unless (typep hash 'hash-table)
1810    (report-bad-arg hash 'hash-table))
1811  (or (nhash.read-only hash)
1812      (when (nhash.owner hash)
1813        (error "Hash~table ~s is thread-private and can't be made read-only for that reason" hash))
1814      (with-lock-context
1815        (without-interrupts
1816         (write-lock-hash-table hash)
1817         (let* ((flags (nhash.vector.flags (nhash.vector hash))))
1818           (declare (fixnum flags))
1819           (when (or (logbitp $nhash_track_keys_bit flags)
1820                     (logbitp $nhash_component_address_bit flags))
1821             (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
1822             (unlock-hash-table hash nil)
1823             (return-from assert-hash-table-readonly nil))
1824           (setf (nhash.read-only hash) t)
1825           (unlock-hash-table hash nil)
1826           t)))))
1827
1828;; This is dangerous, if multiple threads are accessing a read-only
1829;; hash table. Use it responsibly.
1830(defun assert-hash-table-writeable (hash)
1831  (unless (typep hash 'hash-table)
1832    (report-bad-arg hash 'hash-table))
1833  (when (nhash.read-only hash)
1834    (setf (nhash.read-only hash) nil)
1835    t))
1836
1837(defun readonly-hash-table-p (hash)
1838  (unless (typep hash 'hash-table)
1839    (report-bad-arg hash 'hash-table))
1840  (nhash.read-only hash))
1841
1842(defun hash-table-owner (hash)
1843  (unless (typep hash 'hash-table)
1844    (report-bad-arg hash 'hash-table))
1845  (nhash.owner hash))
1846
1847(defun claim-hash-table (hash &optional steal)
1848  (unless (typep hash 'hash-table)
1849    (report-bad-arg hash 'hash-table))
1850  (let* ((owner (nhash.owner hash)))
1851    (if owner
1852      (or (eq owner *current-process*)
1853          (when steal
1854            (setf (nhash.owner hash) *current-process*)))
1855      (progn
1856        (unless (hash-lock-free-p hash)
1857          (write-lock-hash-table hash)
1858          (setf (nhash.exclusion-lock hash) nil))
1859        (setf (nhash.owner hash) *current-process*)
1860        t))))
1861
1862 
1863;; ** TODO: for lock-free hash tables, we don't need to copy,
1864;; we could map over the actual hash table vector, because it's
1865;; always valid.
1866(defun lock-free-enumerate-hash-keys-and-values (hash keys values)
1867  (do* ((in (nhash.vector hash))
1868        (in-idx $nhash.vector_overhead (+ in-idx 2))
1869        (insize (uvsize in))
1870        (outsize (length (or keys values)))
1871        (out-idx 0))
1872       ((or (= in-idx insize)
1873            (= out-idx outsize))
1874        out-idx)
1875    (declare (fixnum in-idx insize out-idx outsize))
1876    (let* ((key (%svref in in-idx)))
1877      (unless (eq key free-hash-marker)
1878        (let ((val (%svref in (%i+ in-idx 1))))
1879          (when (eq val rehashing-value-marker)
1880            ;; This table is being rehashed.  Wait to finish and try again
1881            (lock-free-rehash hash)
1882            (return-from lock-free-enumerate-hash-keys-and-values
1883                         (lock-free-enumerate-hash-keys-and-values hash keys values)))
1884          (unless (eq val free-hash-marker)
1885            (when (eql key deleted-hash-key-marker)
1886              (error "Bug: deleted key but not value?"))
1887            (when keys (setf (%svref keys out-idx) key))
1888            (when values (setf (%svref values out-idx) val))
1889            (incf out-idx)))))))
1890
1891(defun enumerate-hash-keys-and-values (hash keys values)
1892  (unless (typep hash 'hash-table)
1893    (report-bad-arg hash 'hash-table))
1894  (when (hash-lock-free-p hash)
1895    (return-from enumerate-hash-keys-and-values
1896                 (lock-free-enumerate-hash-keys-and-values hash keys values)))
1897  (with-lock-context
1898    (without-interrupts
1899     (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
1900       (do* ((in (nhash.vector hash))
1901             (in-idx $nhash.vector_overhead (+ in-idx 2))
1902             (insize (uvsize in))
1903             (outsize (length (or keys values)))
1904             (out-idx 0))
1905           ((or (= in-idx insize)
1906                (= out-idx outsize))
1907              (unlock-hash-table hash readonly)
1908              out-idx)
1909         (declare (fixnum in-idx insize out-idx outsize))
1910         (let* ((key (%svref in in-idx)))
1911           (unless (or (eq key free-hash-marker)
1912                       (eq key deleted-hash-key-marker))
1913             (when keys
1914               (setf (%svref keys out-idx) key))
1915             (when values
1916               (setf (%svref values out-idx) (%svref in (%i+ in-idx 1))))
1917             (incf out-idx))))))))
1918
1919(defun enumerate-hash-keys (hash out)
1920  (enumerate-hash-keys-and-values hash out nil))
Note: See TracBrowser for help on using the repository browser.