source: branches/working-0711-perf/ccl/level-0/l0-hash.lisp @ 9505

Last change on this file since 9505 was 9505, checked in by gb, 12 years ago

Use (typep x 'hash-table) instead of (hash-table-p x). Mostly because
we can, but may be a little faster.

There's an (unresolved) issue related to the definition of type-predicates
on ISTRUCT classes that have no subclasses: in the TYPEP compiler-macro,
it's generally better to recognize the istruct class and do an inline
ISTRUCT-TYPEP than it is to call a function that does that; at compile-time,
we can certainly afford a FIND-CLASS. At runtime (in #'TYPEP), calling
a predicate if it exists is likely to be much, much cheaper than going
through translation/%typep would be. I started to remove type-predicates
on simple istruct classes before realizing this; it may be better to
keep them around and re-work OPTIMIZE-TYPEP to try the simple istruct
class case first.

In any case, (typep x 'hash-table-p) and (hash-table-p x) should ideally
be equivalent in all respects.

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