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

Last change on this file since 10751 was 10751, checked in by gz, 11 years ago

Allow :lock-free arg to make-hash-table to be :shared, meaning use the lock-free algorithm for shared tables and the regular algorithm for unshared tables. FWIW, when that is the default, (compile-file ccl:compiler

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