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

Last change on this file since 15264 was 15264, checked in by gb, 8 years ago

lib/compile-ccl.lisp: Define some "optional features" for testing
hashing algorithms. :EQ-HASH-MONITOR causes EQ-hashing routines to
record the number of calls/probes involved. (The INCFs here aren't
thread-safe.) :MIXUP-HASH-CODE-NOP makes the function
CCL::MIXUP-HASH-CODE return its argument.

Implement WITH-GLOBAL-OPTIMIZATION-SETTINGS a little differently;
use it in TEST-CCL.

level-0/X86/x86-hash.lisp: in STRIP-TAG-TO-FIXNUM, shift by an
extra bit (so that results aren't always odd/even depending on
tag bits of arg.) This seems to be the right thing and should
likely be implemented on all architectures.

level-0/l0-hash.lisp: conditionally implement the new optional
features.

NEED-USE-EQL: can use EQ if arg is a fixnum or #+64-bit-target
a SINGLE-FLOAT.

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