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

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

A few small changes; there may be bad bugs in EQUAL/EQUALP hashing.
Get keys/values for new maphash.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 73.8 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 (hash-table-p hash)
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 (hash-table-p hash)
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                      #+no
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 (hash-table-p hash)
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 (hash-table-p hash)
811    (report-bad-arg hash 'hash-table))
812  (with-lock-context
813    (without-interrupts
814     (block protected
815       (tagbody
816          (write-lock-hash-table hash)
817        AGAIN
818          (%lock-gc-lock)
819          (when (%needs-rehashing-p hash)
820            (%rehash hash))
821          (let ((vector (nhash.vector  hash)))     
822            (when (eq key (nhash.vector.cache-key vector))
823              (let* ((idx (nhash.vector.cache-idx vector)))
824                (declare (fixnum idx))
825                (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
826                      value)
827                (setf (nhash.vector.cache-value vector) value)
828                (return-from protected)))               
829            (let* ((vector-index (funcall (nhash.find-new hash) hash key))
830                   (old-value (%svref vector vector-index)))
831              (declare (fixnum vector-index))
832
833              (cond ((eq old-value deleted-hash-key-marker)
834                     (%set-hash-table-vector-key vector vector-index key)
835                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
836                     (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
837                     ;; Adjust deleted-count
838                     (when (> 0 (the fixnum
839                                  (decf (the fixnum
840                                          (nhash.vector.deleted-count vector)))))
841                       (let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
842                         (declare (fixnum weak-deletions))
843                         (setf (nhash.vector.weak-deletions-count vector) 0)
844                         (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
845                         (decf (the fixnum (nhash.count hash)) weak-deletions))))
846                    ((eq old-value free-hash-key-marker)
847                     (when (eql 0 (nhash.grow-threshold hash))
848                       (%unlock-gc-lock)
849                       (grow-hash-table hash)
850                       (go AGAIN))
851                     (%set-hash-table-vector-key vector vector-index key)
852                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
853                     (decf (the fixnum (nhash.grow-threshold hash)))
854                     (incf (the fixnum (nhash.count hash))))
855                    (t
856                     ;; Key was already there, update value.
857                     (setf (%svref vector (the fixnum (1+ vector-index))) value)))
858              (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
859                    (nhash.vector.cache-key vector) key
860                    (nhash.vector.cache-value vector) value)))))
861     (%unlock-gc-lock)
862     (unlock-hash-table hash nil)))
863  value)
864
865
866(defun count-entries (hash)
867  (let* ((vector (nhash.vector hash))
868         (size (uvsize vector))
869         (idx $nhash.vector_overhead)
870         (count 0))
871    (loop
872      (when (neq (%svref vector idx) (%unbound-marker))
873        (incf count))
874      (when (>= (setq idx (+ idx 2)) size)
875        (return count)))))
876
877
878
879
880
881     
882
883(defun grow-hash-table (hash)
884  (unless (hash-table-p hash)
885    (setq hash (require-type hash 'hash-table)))
886  (%grow-hash-table hash))
887
888;;; Interrupts are disabled, and the caller has an exclusive
889;;; lock on the hash table.
890(defun %grow-hash-table (hash)
891  (block grow-hash-table
892    (%normalize-hash-table-count hash)
893    (let* ((old-vector (nhash.vector hash))
894           (old-size (nhash.count hash))
895           (old-total-size (nhash.vector-size old-vector))
896           (flags 0)
897           (flags-sans-weak 0)
898           (weak-flags)
899           rehashF)
900      (declare (fixnum old-total-size flags flags-sans-weak weak-flags))   
901      ; well we knew lock was 0 when we called this - is it still 0?
902      (when (> (nhash.vector.deleted-count old-vector) 0)
903        ;; There are enough deleted entries. Rehash to get rid of them
904        (%rehash hash)
905        (return-from grow-hash-table))
906      (multiple-value-bind (size total-size)
907                           (compute-hash-size 
908                            old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash))
909        (unless (eql 0 (nhash.grow-threshold hash))       ; maybe it's done already - shouldnt happen               
910          (return-from grow-hash-table ))
911        (progn
912          (unwind-protect
913            (let ((fwdnum (get-fwdnum))
914                  (gc-count (gc-count))
915                  vector)
916              (setq flags (nhash.vector.flags old-vector)
917                    flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask))
918                    weak-flags (logand flags $nhash_weak_flags_mask)
919                    rehashF (nhash.rehashF hash))         
920              (setf (nhash.lock hash) (%ilogior (nhash.lock hash) $nhash.lock-while-growing) ; dont need
921                    (nhash.rehashF hash) #'%am-growing
922                    (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
923              (%normalize-hash-table-count hash)
924              (setq vector (%cons-nhash-vector total-size 0))
925              (do* ((index 0 (1+ index))
926                    (vector-index (index->vector-index 0) (+ vector-index 2)))
927                   ((>= index old-total-size))
928                (declare (fixnum index vector-index))
929               
930                 (let ((key (%svref old-vector vector-index)))
931                   (unless (or (eq key free-hash-key-marker)
932                               (eq key deleted-hash-key-marker))
933                     (let* ((new-index (%growhash-probe vector hash key))
934                            (new-vector-index (index->vector-index new-index)))
935                       (setf (%svref vector new-vector-index) key)
936                       (setf (%svref vector (the fixnum (1+ new-vector-index)))
937                             (%svref old-vector (the fixnum (1+ vector-index))))))))
938              (progn
939               (setf (nhash.vector.finalization-alist vector)
940                     (nhash.vector.finalization-alist old-vector)
941                     (nhash.vector.free-alist vector)
942                     (nhash.vector.free-alist old-vector)
943                     (nhash.vector.flags vector)
944                     (logior weak-flags (the fixnum (nhash.vector.flags vector))))
945               (setf (nhash.rehash-bits hash) nil
946                     (nhash.vector hash) vector
947                     (nhash.vector.hash vector) hash
948                     (nhash.vector.cache-key vector) (%unbound-marker)
949                     (nhash.vector.cache-value vector) nil
950                     (nhash.fixnum hash) fwdnum
951                     (nhash.gc-count hash) gc-count
952                     (nhash.grow-threshold hash) (- size (nhash.count hash)))
953               (when (eq #'%am-growing (nhash.rehashF hash))
954                 ;; if not changed to %maybe-rehash then contains no address based keys
955                 (setf (nhash.rehashf hash) #'%no-rehash))
956               (setq rehashF nil)       ; tell clean-up form we finished the loop
957               (when (neq old-size (nhash.count hash))
958                 (cerror "xx" "Somebody messed with count while growing")
959                 (return-from grow-hash-table (grow-hash-table hash )))
960               (when (minusp (nhash.grow-threshold hash))
961                 (cerror "nn" "negative grow-threshold ~S ~s ~s ~s" 
962                         (nhash.grow-threshold hash) size total-size old-size))
963               ;; If the old vector's in some static heap, zero it
964               ;; so that less garbage is retained.
965               (%init-misc 0 old-vector)))           
966            (when rehashF
967              (setf (nhash.rehashF hash) rehashF
968                    (nhash.vector.flags old-vector)
969                    (logior weak-flags (the fixnum (nhash.vector.flags old-vector)))))))))))
970
971
972
973;;; values of nhash.rehashF
974;;; %no-rehash - do nothing
975;;; %maybe-rehash - if doesnt need rehashing - if is rehashing 0 else nil
976;                 if locked 0
977;                 else rehash, return t
978;;; %am-rehashing - 0
979;;; %am-growing   - calls %maybe-rehash
980
981;;; compute-hash-code funcalls it if addressp and maybe-rehash-p
982;;;                  sets to maybe-rehash if addressp and update-maybe-rehash (ie from puthash)
983;;; grow-hash-table sets to %am-growing when doing so, resets to original value when done
984;;; rehash sets to %am-rehashing, then to original when done
985
986(defun %no-rehash (hash)
987  (declare (%noforcestk)
988           (optimize (speed 3) (safety 0))
989           (ignore hash))
990  nil)
991
992(defun %maybe-rehash (hash)
993  (declare (optimize (speed 3) (safety 0)))
994  (cond ((not (%needs-rehashing-p hash))
995         nil)
996        (t (loop
997             (%rehash hash)
998             (unless (%needs-rehashing-p hash)
999               (return))
1000             ;(incf n3)
1001             )
1002           t)))
1003
1004(defun %am-rehashing (hash)
1005  (declare (optimize (speed 3) (safety 0))
1006           (ignore hash))
1007  0)
1008
1009(defun %am-growing (hash)
1010  (declare (optimize (speed 3) (safety 0)))
1011  (%maybe-rehash hash))
1012
1013(defun general-hash-find (hash key)
1014  (%hash-probe hash key nil))
1015
1016(defun general-hash-find-for-put (hash key)
1017  (%hash-probe hash key t))
1018
1019;;; returns a single value:
1020;;;   index - the index in the vector for key (where it was or where
1021;;;           to insert if the current key at that index is deleted-hash-key-marker
1022;;;           or free-hash-key-marker)
1023
1024
1025
1026(defun %hash-probe (hash key update-hash-flags)
1027  (declare (optimize (speed 3) (space 0)))
1028  (multiple-value-bind (hash-code index entries)
1029                       (compute-hash-code hash key update-hash-flags)
1030    (locally (declare (fixnum hash-code index entries))
1031      (let* ((compareF (nhash.compareF hash))
1032             (vector (nhash.vector hash))
1033             (vector-index 0)
1034             table-key
1035             (first-deleted-index nil))
1036        (declare (fixnum vector-index))
1037        (macrolet ((return-it (form)
1038                     `(return-from %hash-probe ,form)))
1039          (macrolet ((test-it (predicate)
1040                       (unless (listp predicate) (setq predicate (list predicate)))
1041                       `(progn
1042                          (setq vector-index (index->vector-index index)
1043                                table-key (%svref vector vector-index))
1044                          (cond ((eq table-key free-hash-key-marker)
1045                                 (return-it (or first-deleted-index
1046                                                vector-index)))
1047                                ((eq table-key deleted-hash-key-marker)
1048                                 (when (null first-deleted-index)
1049                                   (setq first-deleted-index vector-index)))
1050                                ((,@predicate key table-key)
1051                                 (return-it vector-index))))))
1052            (macrolet ((do-it (predicate)
1053                         `(progn
1054                            (test-it ,predicate)
1055                            ; First probe failed. Iterate on secondary key
1056                            (let ((initial-index index)
1057                                  (secondary-hash (%svref secondary-keys (logand 7 hash-code))))
1058                              (declare (fixnum secondary-hash initial-index))
1059                              (loop
1060                                (incf index secondary-hash)
1061                                (when (>= index entries)
1062                                  (decf index entries))
1063                                (when (eql index initial-index)
1064                                  (unless first-deleted-index
1065                                    (error "No deleted entries in table"))
1066                                  (return-it first-deleted-index))
1067                                (test-it ,predicate))))))
1068              (if (fixnump comparef)
1069                ;; EQ or EQL hash table
1070                (if (or (eql 0 comparef)
1071                        (immediate-p-macro key)
1072                        (not (need-use-eql key)))
1073                  ;; EQ hash table or EQL == EQ for KEY
1074                  (do-it eq)
1075                  (do-it eql))
1076                ;; general compare function
1077                (do-it (funcall comparef))))))))))
1078
1079(defun eq-hash-find (hash key)
1080  (declare (optimize (speed 3) (safety 0)))
1081  (let* ((vector (nhash.vector hash))
1082         (hash-code
1083          (let* ((typecode (typecode key)))
1084            (if (eq typecode target::tag-fixnum)
1085              (mixup-hash-code key)
1086              (if (eq typecode target::subtag-instance)
1087                (mixup-hash-code (instance.hash key))
1088                (if (symbolp key)
1089                  (%hash-symbol key)
1090                  (mixup-hash-code (strip-tag-to-fixnum key)))))))
1091         (length (uvsize vector))
1092         (count (- length $nhash.vector_overhead))
1093         (entries (ash count -1))
1094         (vector-index (index->vector-index (fast-mod hash-code entries)))
1095         (table-key (%svref vector vector-index)))
1096    (declare (fixnum hash-code  entries vector-index count length))
1097    (if (or (eq key table-key)
1098            (eq table-key free-hash-key-marker))
1099      vector-index
1100      (let* ((secondary-hash (%svref secondary-keys-*-2
1101                                     (logand 7 hash-code)))
1102             (initial-index vector-index)             
1103             (first-deleted-index (if (eq table-key deleted-hash-key-marker)
1104                                    vector-index)))
1105        (declare (fixnum secondary-hash initial-index))
1106        (loop
1107          (incf vector-index secondary-hash)
1108          (when (>= vector-index length)
1109            (decf vector-index count))
1110          (setq table-key (%svref vector vector-index))
1111          (when (= vector-index initial-index)
1112            (return first-deleted-index))
1113          (if (eq table-key key)
1114            (return vector-index)
1115            (if (eq table-key free-hash-key-marker)
1116              (return (or first-deleted-index vector-index))
1117              (if (and (null first-deleted-index)
1118                       (eq table-key deleted-hash-key-marker))
1119                (setq first-deleted-index vector-index)))))))))
1120
1121;;; As above, but note whether the key is in some way address-based
1122;;; and update the hash-vector's flags word if so.
1123;;; This only needs to be done by PUTHASH, and it only really needs
1124;;; to be done if we're adding a new key.
1125(defun eq-hash-find-for-put (hash key)
1126  (declare (optimize (speed 3) (safety 0)))
1127  (let* ((vector (nhash.vector hash))
1128         (hash-code
1129          (let* ((typecode (typecode key)))
1130            (if (eq typecode target::tag-fixnum)
1131              (mixup-hash-code key)
1132              (if (eq typecode target::subtag-instance)
1133                (mixup-hash-code (instance.hash key))
1134                (if (symbolp key)
1135                  (%hash-symbol key)
1136                  (progn
1137                    (unless (immediate-p-macro key)
1138                      (let* ((flags (nhash.vector.flags vector)))
1139                        (declare (fixum flags))
1140                        (unless (logbitp $nhash_track_keys_bit flags)
1141                          (setq flags (bitclr $nhash_key_moved_bit flags)))
1142                        (setf (nhash.vector.flags vector)
1143                              (logior $nhash-track-keys-mask flags))))
1144                    (mixup-hash-code (strip-tag-to-fixnum key))))))))
1145         (length (uvsize  vector))
1146         (count (- length $nhash.vector_overhead))
1147         (vector-index (index->vector-index (fast-mod hash-code (ash count -1))))
1148         (table-key (%svref vector vector-index)))
1149    (declare (fixnum hash-code length count entries vector-index))
1150    (if (or (eq key table-key)
1151            (eq table-key free-hash-key-marker))
1152      vector-index
1153      (let* ((secondary-hash (%svref secondary-keys-*-2
1154                                     (logand 7 hash-code)))
1155             (initial-index vector-index)             
1156             (first-deleted-index (if (eq table-key deleted-hash-key-marker)
1157                                    vector-index)))
1158        (declare (fixnum secondary-hash initial-index))
1159        (loop
1160          (incf vector-index secondary-hash)
1161          (when (>= vector-index length)
1162            (decf vector-index count))
1163          (setq table-key (%svref vector vector-index))
1164          (when (= vector-index initial-index)
1165            (return first-deleted-index))
1166          (if (eq table-key key)
1167            (return vector-index)
1168            (if (eq table-key free-hash-key-marker)
1169              (return (or first-deleted-index vector-index))
1170              (if (and (null first-deleted-index)
1171                       (eq table-key deleted-hash-key-marker))
1172                (setq first-deleted-index vector-index)))))))))
1173
1174(defun eql-hash-find (hash key)
1175  (declare (optimize (speed 3) (safety 0)))
1176  (if (need-use-eql key)
1177    (let* ((vector (nhash.vector hash))
1178           (hash-code (%%eqlhash-internal key))
1179           (length (uvsize  vector))
1180           (count (- length $nhash.vector_overhead))
1181           (entries (ash count -1))
1182           (vector-index (index->vector-index (fast-mod hash-code entries)))
1183           (table-key (%svref vector vector-index)))
1184      (declare (fixnum hash-code length entries count vector-index))
1185      (if (or (eql key table-key)
1186              (eq table-key free-hash-key-marker))
1187        vector-index
1188        (let* ((secondary-hash (%svref secondary-keys-*-2
1189                                       (logand 7 hash-code)))
1190               (initial-index vector-index)
1191               (first-deleted-index (if (eq table-key deleted-hash-key-marker)
1192                                      vector-index)))
1193          (declare (fixnum secondary-hash initial-index))
1194          (loop
1195            (incf vector-index secondary-hash)
1196            (when (>= vector-index length)
1197              (decf vector-index count))
1198            (setq table-key (%svref vector vector-index))
1199            (when (= vector-index initial-index)
1200              (return first-deleted-index))
1201          (if (eql table-key key)
1202            (return vector-index)
1203            (if (eq table-key free-hash-key-marker)
1204              (return (or first-deleted-index vector-index))
1205              (if (and (null first-deleted-index)
1206                       (eq table-key deleted-hash-key-marker))
1207                (setq first-deleted-index vector-index))))))))
1208    (eq-hash-find hash key)))
1209
1210(defun eql-hash-find-for-put (hash key)
1211  (declare (optimize (speed 3) (safety 0)))
1212  (if (need-use-eql key)
1213    (let* ((vector (nhash.vector hash))
1214           (hash-code (%%eqlhash-internal key))
1215           (length (uvsize  vector))
1216           (count (- length $nhash.vector_overhead))
1217           (entries (ash count -1))
1218           (vector-index (index->vector-index (fast-mod hash-code entries)))
1219           (table-key (%svref vector vector-index)))
1220      (declare (fixnum hash-code length entries vector-index))
1221      (if (or (eql key table-key)
1222              (eq table-key free-hash-key-marker))
1223        vector-index
1224        (let* ((secondary-hash (%svref secondary-keys-*-2
1225                                       (logand 7 hash-code)))
1226               (initial-index vector-index)
1227               (first-deleted-index (if (eq table-key deleted-hash-key-marker)
1228                                      vector-index)))
1229          (declare (fixnum secondary-hash initial-index))
1230          (loop
1231            (incf vector-index secondary-hash)
1232            (when (>= vector-index length)
1233              (decf vector-index count))
1234            (setq table-key (%svref vector vector-index))
1235            (when (= vector-index initial-index)
1236              (return (or first-deleted-index
1237                          (error "Bug: no deleted entries in table"))))
1238            (if (eql table-key key)
1239              (return vector-index)
1240              (if (eq table-key free-hash-key-marker)
1241                (return (or first-deleted-index vector-index))
1242                (if (and (null first-deleted-index)
1243                         (eq table-key deleted-hash-key-marker))
1244                  (setq first-deleted-index vector-index))))))))
1245    (eq-hash-find-for-put hash key)))
1246
1247;;; Rehash.  Caller should have exclusive access to the hash table
1248;;; and have disabled interrupts.
1249(defun %rehash (hash)
1250  (let* ((vector (nhash.vector hash))
1251         (flags (nhash.vector.flags vector))         )
1252    (setf (nhash.vector.flags vector)
1253          (logand flags $nhash-clear-key-bits-mask))
1254    (do-rehash hash)))
1255
1256
1257(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash))))
1258  (declare (fixnum size))
1259  (let ((rehash-bits (nhash.rehash-bits hash)))
1260    (unless (and rehash-bits
1261                 (>= (uvsize rehash-bits) size))
1262      (return-from %make-rehash-bits
1263        (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0))))
1264    (fill (the simple-bit-vector rehash-bits) 0)))
1265
1266(defun do-rehash (hash)
1267  (let* ((vector (nhash.vector hash))
1268         (vector-index (- $nhash.vector_overhead 2))
1269         (size (nhash.vector-size vector))
1270         (rehash-bits (%make-rehash-bits hash size))
1271         (index -1))
1272    (declare (fixnum size index vector-index))   
1273    (setf (nhash.vector.cache-key vector) (%unbound-marker)
1274          (nhash.vector.cache-value vector) nil)
1275    (%set-does-not-need-rehashing hash)
1276    (loop
1277      (when (>= (incf index) size) (return))
1278      (setq vector-index (+ vector-index 2))
1279      (unless (%already-rehashed-p index rehash-bits)
1280        (let* ((key (%svref vector vector-index))
1281               (deleted (eq key deleted-hash-key-marker)))
1282          (unless
1283            (when (or deleted (eq key free-hash-key-marker))
1284              (if deleted  ; one less deleted entry
1285                (let ((count (1- (nhash.vector.deleted-count vector))))
1286                  (declare (fixnum count))
1287                  (setf (nhash.vector.deleted-count vector) count)
1288                  (if (< count 0)
1289                    (let ((wdc (nhash.vector.weak-deletions-count vector)))
1290                      (setf (nhash.vector.weak-deletions-count vector) 0)
1291                      (incf (nhash.vector.deleted-count vector) wdc)
1292                      (decf (nhash.count hash) wdc)))
1293                  (incf (nhash.grow-threshold hash))
1294                  ;; Change deleted to free
1295                  (setf (%svref vector vector-index) free-hash-key-marker)))
1296              t)
1297            (let* ((last-index index)
1298                   (value (%svref vector (the fixnum (1+ vector-index))))
1299                   (first t))
1300                (loop
1301                  (let ((vector (nhash.vector hash))
1302                        (found-index (%rehash-probe rehash-bits hash key)))
1303                    (%set-already-rehashed-p found-index rehash-bits)
1304                    (if (eq last-index found-index)
1305                      (return)
1306                      (let* ((found-vector-index (index->vector-index found-index))
1307                             (newkey (%svref vector found-vector-index))
1308                             (newvalue (%svref vector (the fixnum (1+ found-vector-index)))))
1309                        (declare (fixnum found-vector-index))
1310                        (when first ; or (eq last-index index) ?
1311                          (setq first nil)
1312                          (setf (%svref vector vector-index) free-hash-key-marker)
1313                          (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-key-marker))
1314                        (%set-hash-table-vector-key vector found-vector-index key)
1315                        (setf (%svref vector (the fixnum (1+ found-vector-index))) value)                       
1316                        (when (or (eq newkey free-hash-key-marker)
1317                                  (setq deleted (eq newkey deleted-hash-key-marker)))
1318                          (when deleted
1319                            (let ((count (1- (nhash.vector.deleted-count vector))))
1320                              (declare (fixnum count))
1321                              (setf (nhash.vector.deleted-count vector) count)
1322                              (if (< count 0)
1323                                (let ((wdc (nhash.vector.weak-deletions-count vector)))
1324                                  (setf (nhash.vector.weak-deletions-count vector) 0)
1325                                  (incf (nhash.vector.deleted-count vector) wdc)
1326                                  (decf (nhash.count hash) wdc)))
1327                              (incf (nhash.grow-threshold hash))))
1328                          (return))
1329                        (when (eq key newkey)
1330                          (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
1331                                  key hash value newvalue index found-index)                       
1332                          (decf (nhash.count hash))
1333                          (incf (nhash.grow-threshold hash))
1334                          (return))
1335                        (setq key newkey
1336                              value newvalue
1337                              last-index found-index)))))))))))
1338    t )
1339
1340;;; Hash to an index that is not set in rehash-bits
1341 
1342(defun %rehash-probe (rehash-bits hash key)
1343  (declare (optimize (speed 3)(safety 0))) 
1344  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t)
1345    (declare (fixnum hash-code index entries))
1346    (when (null hash-code)(cerror "nuts" "Nuts"))
1347    (let* ((vector (nhash.vector hash))
1348           (vector-index (index->vector-index  index)))
1349      (if (or (not (%already-rehashed-p index rehash-bits))
1350              (eq key (%svref vector vector-index)))
1351        (return-from %rehash-probe index)
1352        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1353          (declare (fixnum second))
1354          (loop
1355            (setq index (+ index second))
1356            (when (>= index entries)
1357              (setq index (- index entries)))
1358            (when (or (not (%already-rehashed-p index rehash-bits))
1359                      (eq key (%svref vector (index->vector-index index))))
1360              (return-from %rehash-probe index))))))))
1361
1362;;; Returns one value: the index of the entry in the vector
1363;;; Since we're growing, we don't need to compare and can't find a key that's
1364;;; already there.
1365(defun %growhash-probe (vector hash key)
1366  (declare (optimize (speed 3)(safety 0)))
1367  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector)
1368    (declare (fixnum hash-code index entries))
1369    (let* ((vector-index (index->vector-index  index))
1370           (vector-key nil))
1371      (declare (fixnum vector-index))
1372      (if (or (eq free-hash-key-marker
1373                  (setq vector-key (%svref vector vector-index)))
1374              (eq deleted-hash-key-marker vector-key))
1375        (return-from %growhash-probe index)
1376        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1377          (declare (fixnum second))
1378          (loop
1379            (setq index (+ index second))
1380            (when (>= index entries)
1381              (setq index (- index entries)))
1382            (when (or (eq free-hash-key-marker
1383                          (setq vector-key (%svref vector (index->vector-index index))))
1384                      (eq deleted-hash-key-marker vector-key))
1385              (return-from %growhash-probe index))))))))
1386
1387;;;;;;;;;;;;;
1388;;
1389;; Mapping functions are in "ccl:lib;hash"
1390;;
1391
1392
1393
1394;;;;;;;;;;;;;
1395;;
1396;; Hashing functions
1397;; EQ & the EQ part of EQL are done in-line.
1398;;
1399
1400
1401
1402
1403
1404
1405
1406
1407
1408;;; so whats so special about bit vectors as opposed to any other vectors of bytes
1409;;; For starters, it's guaranteed that they exist in the implementation; that may
1410;;; not be true of other immediate vector types.
1411(defun bit-vector-hash (bv)
1412  (declare (optimize (speed 3)(safety 0)))
1413  (let ((length (length bv)))
1414    (declare (fixnum length)) ;will this always be true? it's true of all vectors.
1415    (multiple-value-bind (data offset) (array-data-and-offset bv)
1416      (declare (type simple-bit-vector data) (fixnum offset))
1417      (let* ((hash 0)
1418             (limit (+ length offset))
1419             (nbytes (ash (the fixnum (+ length 7)) -3)))
1420        (declare (fixnum hash limit nbytes))
1421        (dotimes (i nbytes (mixup-hash-code hash))
1422          (let* ((w 0))
1423            (declare (fixnum w))
1424            (dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3))  w)))
1425              (setq w (the fixnum
1426                        (logxor
1427                         (the fixnum
1428                           (ash (if (< offset limit) 
1429                                  (the fixnum (sbit data offset))
1430                                  0)
1431                                (the fixnum j)))
1432                         w)))
1433              (incf offset))))))))
1434
1435#|
1436(defun bit-vector-hash (bv)
1437  (declare (optimize (speed 3)(safety 0)))
1438  (let ((length (length bv)))
1439    (declare (fixnum length))
1440    (let* ((all (+ length 15))
1441           (nwds (ash all -4))
1442           (rem (logand all 15))
1443           (hash 0)
1444           (mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem)))))
1445      (declare (fixnum all nwds rem hash mask))
1446      (multiple-value-bind (data offset)
1447                           (array-data-and-offset bv)
1448        (declare (fixnum offset))
1449        (locally (declare (type (simple-array (unsigned-byte 16) (*)) data))
1450          (dotimes (i nwds)
1451            (setq hash (%i+ hash (aref data (the fixnum (+ i offset))))))
1452          (when (neq 0 mask)           
1453            (setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds)))))))
1454          (mixup-hash-code hash))))))
1455|#
1456
1457
1458;;; Same as %%equalhash, but different:
1459;;;  1) Real numbers are hashed as if they were double-floats.  The real components of complex numbers
1460;;;     are hashed as double-floats and XORed together.
1461;;;  2) Characters and strings are hashed in a case-insensitive manner.
1462;;;  3) Hash tables are hashed based on their size and type.
1463;;;  4) Structures and CL array types are hashed based on their content.
1464
1465
1466;;; check fixnum befor immediate-p. call %%eqlhash
1467
1468(defun %%equalphash (key)
1469  (cond ((or (fixnump key)(short-float-p key))
1470         (%dfloat-hash (float key 1.0d0))) 
1471        ((immediate-p-macro key)
1472         (mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key))))
1473        ((bignump key)
1474         (if (<= most-negative-double-float key most-positive-double-float)
1475           (%dfloat-hash (float key 1.0d0))  ; with-stack-double-floats
1476           (%%eqlhash-internal key)))
1477        ((double-float-p key)
1478         (%dfloat-hash key))
1479        ((ratiop key)
1480         (%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key))))
1481        ((complexp key)
1482         (%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key))))
1483        ((hash-table-p key)
1484         (equalphash-hash-table key))
1485        ((or (istructp key)
1486             (structurep key))  ; was (gvectorp key)
1487         (%%equalphash-structure 11 key))
1488        ((or (arrayp key)) ;(uvectorp key)) ;??
1489         (%%equalphash-array 11 key))
1490        ((consp key)
1491         (%%equalphash-aux 11 key))
1492        (t (%%eqlhash key))))
1493
1494
1495(defun equalphash-hash-table (hash-table)
1496  (let ((hash (%%equalhash "HASH-TABLE"))
1497        addressp)
1498    (declare (fixnum hash))
1499    (incf hash (the fixnum (%%eqhash (hash-table-count hash-table))))
1500    (multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table))
1501      (declare (fixnum h))
1502      (incf hash h)
1503      (if ap (setq addressp t)))
1504    (multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table))
1505      (declare (fixnum h))
1506      (incf hash h)
1507      (if ap (setq addressp t)))
1508    (values hash addressp)))
1509
1510(defun %%equalphash-structure (limit key)
1511  (let* ((size (uvsize key))
1512         (hash (mixup-hash-code size))
1513         addressp)
1514    (declare (fixnum limit size hash))
1515    (dotimes (i size)
1516      (multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i))
1517        (declare (fixnum h))
1518        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1519        (if ap (setq addressp t)))
1520      (when (<= (decf limit) 0)
1521        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1522                                  #.(mixup-hash-code 11))))
1523        (return)))
1524    (values hash addressp)))
1525
1526(defun %%equalphash-array (limit key)
1527  (multiple-value-bind (array offset) (array-data-and-offset key)
1528    (let* ((rank (array-rank key))
1529           (vectorp (eql rank 1))
1530           (size (if vectorp (length key) (array-total-size key)))
1531           (hash (mixup-hash-code rank))
1532           addressp)
1533      (declare (fixnum size hash limit rank))
1534      (if vectorp
1535        (setq hash
1536              (the fixnum
1537                   (+ (the fixnum (rotate-hash-code hash))
1538                      (the fixnum (mixup-hash-code size)))))
1539        (dotimes (i rank)
1540          (declare (fixnum i))
1541          (setq hash
1542                (the fixnum 
1543                     (+ (the fixnum (rotate-hash-code hash))
1544                        (the fixnum
1545                             (mixup-hash-code (array-dimension key i))))))))     
1546      (dotimes (i size)
1547        (declare (fixnum i))
1548        (multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset))
1549          (declare (fixnum h))
1550          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1551          (if ap (setq addressp t)))
1552        (when (<= (decf limit) 0)
1553          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
1554                                    #.(mixup-hash-code 11))))
1555          (return))
1556        (incf offset))
1557      (values hash addressp))))
1558
1559(defun %%equalphash-aux (limit key)
1560  (if (<= limit 0) 
1561    #.(mixup-hash-code 11)
1562    (if (null key) #.(mixup-hash-code 17)
1563        (cond ((consp key)
1564               (let ((hash 0)
1565                     address-p)
1566                 (do ((l limit (1- l)))
1567                     ((eq l 0)(values hash address-p))
1568                   (multiple-value-bind (ahash ap)
1569                                        (%%equalphash-aux l (if (consp key)(car key) key))
1570                     (setq hash (mixup-hash-code (logxor ahash hash)))
1571                     (if ap (setq address-p t)))
1572                   (when (not (consp key))
1573                     (return (values hash address-p)))
1574                   (setq key (cdr key)))))
1575              ((hash-table-p key)
1576               (equalphash-hash-table key))
1577              ; what are the dudes called that contain bits? they are uvectors but not gvectors?
1578              ; ivectors.
1579              ((or (istructp key)
1580                   (structurep key))    ;was (gvectorp key)
1581               (%%equalphash-structure limit key))
1582              ((or (arrayp key))  ; (uvectorp key))
1583               (%%equalphash-array limit key))
1584              (t (%%equalphash key))))))
1585
1586(defun alist-hash-table (alist &rest hash-table-args)
1587  (declare (dynamic-extent hash-table-args))
1588  (if (typep alist 'hash-table)
1589    alist
1590    (let ((hash-table (apply #'make-hash-table hash-table-args)))
1591      (dolist (cons alist) (puthash (car cons) hash-table (cdr cons)))
1592      hash-table)))
1593
1594(defun %hash-table-equalp (x y)
1595  ;; X and Y are both hash tables
1596  (and (eq (hash-table-test x)
1597           (hash-table-test y))
1598       (eql (hash-table-count x)
1599            (hash-table-count y))
1600       (block nil
1601         (let* ((default (cons nil nil))
1602                (foo #'(lambda (k v)
1603                         (let ((y-value (gethash k y default)))
1604                           (unless (and (neq default y-value)
1605                                        (equalp v y-value))
1606                             (return nil))))))
1607           (declare (dynamic-extent foo default))
1608           (maphash foo x))
1609         t)))
1610
1611(defun sxhash (s-expr)
1612  "Computes a hash code for S-EXPR and returns it as an integer."
1613  (logand (sxhash-aux s-expr 7 17) most-positive-fixnum))
1614
1615(defun sxhash-aux (expr counter key)
1616  (declare (fixnum counter))
1617  (if (> counter 0)
1618    (typecase expr
1619      ((or string bit-vector number character)  (+ key (%%equalhash expr)))
1620      ((or pathname logical-pathname)
1621       (dotimes (i (uvsize expr) key)
1622         (declare (fixnum i))
1623         (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))
1624      (symbol (+ key (%%equalhash (symbol-name expr))))
1625      (cons (sxhash-aux
1626             (cdr expr)
1627             (the fixnum (1- counter))             
1628             (+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key))))
1629      (t (+  key (%%equalhash (symbol-name (%type-of expr))))))
1630    key))
1631
1632
1633
1634#+ppc32-target
1635(defun immediate-p (thing)
1636  (let* ((tag (lisptag thing)))
1637    (declare (fixnum tag))
1638    (or (= tag ppc32::tag-fixnum)
1639        (= tag ppc32::tag-imm))))
1640
1641#+ppc64-target
1642(defun immediate-p (thing)
1643  (let* ((tag (lisptag thing)))
1644    (declare (fixnum tag))
1645    (or (= tag ppc64::tag-fixnum)
1646        (= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm))))
1647
1648#+x8664-target
1649(defun immediate-p (thing)
1650  (let* ((tag (lisptag thing)))
1651    (declare (type (unsigned-byte 3) tag))
1652    (logbitp tag
1653             (logior (ash 1 x8664::tag-fixnum)
1654                     (ash 1 x8664::tag-imm-0)
1655                     (ash 1 x8664::tag-imm-1)))))
1656
1657
1658
1659(defun get-fwdnum (&optional hash)
1660  (let* ((res (%get-fwdnum)))
1661    (if hash
1662      (setf (nhash.fixnum hash) res))
1663    res))
1664
1665(defun gc-count (&optional hash)
1666   (let ((res (%get-gc-count)))
1667    (if hash
1668      (setf (nhash.gc-count hash) res)
1669      res)))
1670
1671
1672(defun %cons-nhash-vector (size &optional (flags 0))
1673  (declare (fixnum size))
1674  (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector (%unbound-marker))))
1675    (setf (nhash.vector.link vector) 0
1676          (nhash.vector.flags vector) flags
1677          (nhash.vector.free-alist vector) nil
1678          (nhash.vector.finalization-alist vector) nil
1679          (nhash.vector.weak-deletions-count vector) 0
1680          (nhash.vector.hash vector) nil
1681          (nhash.vector.deleted-count vector) 0
1682          (nhash.vector.cache-key vector) (%unbound-marker)
1683          (nhash.vector.cache-value vector) nil
1684          (nhash.vector.cache-idx vector) nil)
1685    vector))
1686
1687(defun assert-hash-table-readonly (hash)
1688  (unless (hash-table-p hash)
1689    (report-bad-arg hash 'hash-table))
1690  (or (nhash.read-only hash)
1691      (with-lock-context
1692        (without-interrupts
1693         (write-lock-hash-table hash)
1694         (let* ((flags (nhash.vector.flags (nhash.vector hash))))
1695           (declare (fixnum flags))
1696           (when (or (logbitp $nhash_track_keys_bit flags)
1697                     (logbitp $nhash_component_address_bit flags))
1698             (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
1699             (unlock-hash-table hash nil)
1700             (return-from assert-hash-table-readonly nil))
1701           (setf (nhash.read-only hash) t)
1702           (unlock-hash-table hash nil)
1703           t)))))
1704
1705;; This is dangerous, if multiple threads are accessing a read-only
1706;; hash table. Use it responsibly.
1707(defun assert-hash-table-writeable (hash)
1708  (unless (hash-table-p hash)
1709    (report-bad-arg hash 'hash-table))
1710  (when (nhash.read-only hash)
1711    (setf (nhash.read-only hash) nil)
1712    t))
1713
1714(defun readonly-hash-table-p (hash)
1715  (unless (hash-table-p hash)
1716    (report-bad-arg hash 'hash-table))
1717  (nhash.read-only hash))
1718
1719(defun hash-table-owner (hash)
1720  (unless (hash-table-p hash)
1721    (report-bad-arg hash 'hash-table))
1722  (nhash.owner hash))
1723
1724(defun claim-hash-table (hash &optional steal)
1725  (unless (hash-table-p hash)
1726    (report-bad-arg hash 'hash-table))
1727  (let* ((owner (nhash.owner hash)))
1728    (if owner
1729      (or (eq owner *current-process*)
1730          (when steal
1731            (setf (nhash.owner hash) *current-process*)))
1732      (progn
1733        (write-lock-hash-table hash)
1734        (setf (nhash.exclusion-lock hash) nil
1735              (nhash.owner hash) *current-process*)
1736        t))))
1737
1738 
1739 
1740
1741
1742(defun enumerate-hash-keys (hash out)
1743  (unless (hash-table-p hash)
1744    (report-bad-arg hash 'hash-table))
1745  (with-lock-context
1746    (without-interrupts
1747     (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
1748       (do* ((in (nhash.vector hash))
1749             (in-idx $nhash.vector_overhead (+ in-idx 2))
1750             (insize (uvsize in))
1751             (outsize (length out))
1752             (out-idx 0))
1753            ((or (= in-idx insize)
1754                 (= out-idx outsize))
1755             (unlock-hash-table hash readonly)
1756             out-idx)
1757         (declare (fixnum in-idx insize out-idx outsize))
1758         (let* ((val (%svref in in-idx)))
1759           (unless (or (eq val free-hash-key-marker)
1760                       (eq val deleted-hash-key-marker))
1761             (setf (%svref out out-idx) val)
1762             (incf out-idx))))))))
1763
1764(defun enumerate-hash-keys-and-values (hash keys values)
1765  (unless (hash-table-p hash)
1766    (report-bad-arg hash 'hash-table))
1767  (with-lock-context
1768    (without-interrupts
1769     (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
1770       (do* ((in (nhash.vector hash))
1771             (in-idx $nhash.vector_overhead (+ in-idx 2))
1772             (insize (uvsize in))
1773             (outsize (length keys))
1774             (out-idx 0))
1775            ((or (= in-idx insize)
1776                 (= out-idx outsize))
1777             (unlock-hash-table hash readonly)
1778             out-idx)
1779         (declare (fixnum in-idx insize out-idx outsize))
1780         (let* ((key (%svref in in-idx)))
1781           (unless (or (eq key free-hash-key-marker)
1782                       (eq key deleted-hash-key-marker))
1783             (setf (%svref keys out-idx) key)
1784             (setf (%svref values out-idx) (%svref in (the fixnum (1+ in-idx))))
1785             (incf out-idx))))))))
Note: See TracBrowser for help on using the repository browser.