source: release/1.10/source/level-0/l0-hash.lisp @ 16191

Last change on this file since 16191 was 16191, checked in by rme, 7 years ago

Merge from trunk (see ticket:1229)

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