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

Last change on this file since 9999 was 9999, checked in by gz, 12 years ago

Propagate r9930,r9931 (faster mod for hash) to trunk

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