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

Last change on this file since 6534 was 6534, checked in by gb, 14 years ago

Fix bad call to %pname-hash.

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