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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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