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

Last change on this file since 15601 was 15601, checked in by gb, 7 years ago

Logical host names aren't case-sensitive in CCL; don't hash logical
pathnames (or compare them with EQUAL) as if they were.

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