source: branches/working-0710/ccl/level-0/l0-hash.lisp @ 7392

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

So far: move a couple of inlined functions before their first use.

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