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

Last change on this file since 10731 was 10731, checked in by gz, 13 years ago

Implemented "nearly-lock-free" hash tables. They are created by
calling MAKE-HASH-TABLE with :LOCK-FREE t, or by setting
CCL::*LOCK-FREE-HASH-TABLE-DEFAULT* to T. There is some documentation
in a big comment in l0-hash.lisp, but basically the idea is to try to
avoid any locking in GETHASH, getting the performance equivalent to
readonly tables, at the cost of rehashing becoming more
expensive. PUTHASH should be roughly equivalent (it avoids getting a
lock, but does sync memory a few times).

So far, I've only tested them on linuxx8664, by building ccl multiple
times with *lock-free-hash-table-default* = T on, so no real
multi-threaded testing. I will now switch to the mac and try to
build and use the IDE that way.

Other changes: moved some slots from the hash table to the hash table
vector so they can all be swapped in/out all at once. Made nhash.find
return -1 when not found, also to avoid some synchronization issues.
%needs-rehashing-p now takes a hash table vector, not the hash table.
Got rid of a bunch of unused slots and constants in hash tables.

Incremented fasl version in case there are any fasdumped hash tables out there.

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