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

Last change on this file since 15601 was 15601, checked in by gb, 7 years ago

Logical host names aren't case-sensitive in CCL; don't hash logical
pathnames (or compare them with EQUAL) as if they were.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 93.1 KB
RevLine 
[2491]1;;;-*- Mode: Lisp; Package: CCL -*-
[6]2;;;
[13067]3;;;   Copyright (C) 2009 Clozure Associates
[6]4;;;   Copyright (C) 1994-2001 Digitool, Inc
[13066]5;;;   This file is part of Clozure CL. 
[6]6;;;
[13066]7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
[6]9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
[13066]10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
[6]11;;;   conflict, the preamble takes precedence. 
12;;;
[13066]13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
[6]14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
[1937]18(in-package "CCL")
[6]19
20;;;;;;;;;;;;;
21;;
[10731]22;; See hash.lisp for documentation
[6]23
24
25(eval-when (:compile-toplevel :execute)
26  (require "HASHENV" "ccl:xdump;hashenv")
27  (require :number-case-macro)
[15504]28  (assert (and (not (eql (%unbound-marker) (%slot-unbound-marker)))
29               (not (eql (%unbound-marker) (%illegal-marker)))
30               (not (eql (%slot-unbound-marker) (%illegal-marker)))))
[2491]31  (define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker))
[15504]32  (define-symbol-macro deleted-hash-value-marker (%slot-unbound-marker))
[10731]33  (define-symbol-macro free-hash-marker (%unbound-marker))
[15504]34  (define-symbol-macro rehashing-value-marker (%illegal-marker))
[6]35  (declaim (inline nhash.vector-size))
36  (declaim (inline mixup-hash-code))
37  (declaim (inline hash-table-p))
38  (declaim (inline %%eqhash))
39  (declaim (inline index->vector-index vector-index->index swap))
[2491]40  (declaim (inline %already-rehashed-p %set-already-rehashed-p))
41  (declaim (inline need-use-eql))
42  (declaim (inline %needs-rehashing-p))
43  (declaim (inline compute-hash-code))
[2513]44  (declaim (inline eq-hash-find eq-hash-find-for-put))
[7908]45  (declaim (inline read-lock-hash-table write-lock-hash-table  unlock-hash-table))
[10731]46  (declaim (inline %hash-symbol))
47  (declaim (inline hash-mod))
48  (declaim (inline set-hash-key-conditional set-hash-value-conditional))
49  (declaim (inline hash-lock-free-p lock-free-gethash)))
[6]50
[15264]51#+eq-hash-monitor
52(progn
53(defparameter eq-hash-find-calls 0)
54(defparameter eq-hash-find-probes 0)
55(defparameter eq-hash-find-for-put-calls 0)
56(defparameter eq-hash-find-for-put-probes 0)
57)
[7908]58
59
[10731]60(defun %cons-hash-table (keytrans-function compare-function vector
61                         threshold rehash-ratio rehash-size find find-new owner &optional lock-free-p)
[6]62  (%istruct
63   'HASH-TABLE                          ; type
64   keytrans-function                    ; nhash.keytransF
65   compare-function                     ; nhash.compareF
66   nil                                  ; nhash.rehash-bits
67   vector                               ; nhash.vector
[10731]68   (if lock-free-p $nhash.lock-free 0)  ; nhash.lock
[2513]69   owner                                ; nhash.owner
[6]70   threshold                            ; nhash.grow-threshold
71   rehash-ratio                         ; nhash.rehash-ratio
72   rehash-size                          ; nhash.rehash-size
73   0                                    ; nhash.puthash-count
[10731]74   (if lock-free-p
75     (make-lock)
76     (unless owner (make-read-write-lock))) ; nhash.exclusion-lock
[2491]77   find                                 ; nhash.find
78   find-new                             ; nhash.find-new
[10731]79   nil                                  ; nhash.read-only
[6]80   ))
81
82(defun nhash.vector-size (vector)
[9999]83  (nhash.vector.size vector))
[6]84
[9999]85(defun hash-mod (hash entries vector)
86  (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector)))
87
[10731]88;; For lock-free hash tables
89(defun set-hash-key-conditional (index vector old new)
90  (%set-hash-table-vector-key-conditional (%i+ target::misc-data-offset
91                                               (ash (the fixnum index) target::word-shift))
92                                          vector
93                                          old
94                                          new))
95
96(defun set-hash-value-conditional (index vector old new)
97  (store-gvector-conditional (%i+ index 1) vector old new))
98
99(defun hash-lock-free-p (hash)
100  (logtest $nhash.lock-free (the fixnum (nhash.lock hash))))
101 
[2491]102;;; Is KEY something which can be EQL to something it's not EQ to ?
103;;; (e.g., is it a number or macptr ?)
104;;; This can be more general than necessary but shouldn't be less so.
105(defun need-use-eql (key)
106  (let* ((typecode (typecode key)))
107    (declare (fixnum typecode))
108    (or (= typecode target::subtag-macptr)
[15093]109        (and (< typecode (- target::nbits-in-word target::fixnumshift))
110             (logbitp (the (integer 0 (#.(- target::nbits-in-word target::fixnumshift)))
111                        typecode)
[15264]112                      (logior (ash 1 target::subtag-bignum)
113                              #-64-bit-target
[15093]114                              (ash 1 target::subtag-single-float)
115                              (ash 1 target::subtag-double-float)
116                              (ash 1 target::subtag-ratio)
117                              (ash 1 target::subtag-complex)))))))
[6]118
119;;; Don't rehash at all, unless some key is address-based (directly or
120;;; indirectly.)
[10731]121(defun %needs-rehashing-p (vector)
122  (let* ((flags (nhash.vector.flags vector)))
[2491]123    (declare (fixnum flags))
124    (if (logbitp $nhash_track_keys_bit flags)
125      ;; GC is tracking key movement
126      (logbitp $nhash_key_moved_bit flags)
127      ;; GC is not tracking key movement
128      (if (logbitp $nhash_component_address_bit flags)
[10775]129        (not (eql (the fixnum (%get-gc-count)) (the fixnum (nhash.vector.gc-count vector))))))))
[6]130
[10913]131(defun %set-does-not-need-rehashing (vector)
132  (let* ((flags (nhash.vector.flags vector)))
[6]133    (declare (fixnum flags))
[10731]134    (setf (nhash.vector.gc-count vector) (%get-gc-count))
[6]135    (when (logbitp $nhash_track_keys_bit flags)
136      (setf (nhash.vector.flags vector)
137            (logand (lognot (ash 1 $nhash_key_moved_bit)) flags)))))
138
139
[4151]140;;; Tempting though it may be to remove this, a hash table loaded from
141;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM
142;;; for hash tables needs to be able to call this or something similar.
143(defun %set-needs-rehashing (hash)
144  (let* ((vector (nhash.vector hash))
145         (flags (nhash.vector.flags vector)))
146    (declare (fixnum flags))
[10731]147    (setf (nhash.vector.gc-count vector) (the fixnum (1- (the fixnum (%get-gc-count)))))
[4151]148    (when (logbitp $nhash_track_keys_bit flags)
149      (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags)))))
150
[15269]151;;;
152;;; This is a fairly straightforward translation of the "one-at-a-time"
153;;; hash function described at:
154;;; http://www.burtleburtle.net/bob/hash/doobs.html
155;;;
[6]156(defun mixup-hash-code (fixnum)
[15269]157  (declare (fixnum fixnum)
158           (optimize (speed 3) (safety 0)))
159  (setq fixnum (logand fixnum target::most-positive-fixnum))
160  (do* ((hash 0))
161       ((zerop fixnum)
162        (setq hash (+ hash (the fixnum (ash hash 3)))
163              hash (logxor hash (the fixnum (ash hash -11))))
164        (the fixnum (+ hash (the fixnum (ash hash 15)))))
165    (declare (fixnum hash))
166    (setq hash (+ hash (the fixnum (logand fixnum #xff)))
167          fixnum (ash fixnum -8)
168          hash (+ hash (the fixnum (ash hash 10)))
169          hash (logxor hash (the fixnum (ash hash -6))))))
170         
[6]171(defun rotate-hash-code (fixnum)
172  (declare (fixnum fixnum))
173  (let* ((low-3 (logand 7 fixnum))
174         (but-low-3 (%ilsr 3 fixnum))
175         (low-3*64K (%ilsl 13 low-3))
176         (low-3-in-high-3 (%ilsl (- 32 3 3) low-3)))
177    (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3))
178    (the fixnum (+ low-3-in-high-3
179                   (the fixnum (logxor low-3*64K but-low-3))))))
180
181
[1624]182
[3567]183
[6]184(defconstant $nhash-track-keys-mask
185  #.(- (ash 1 $nhash_track_keys_bit)))
186
187(defconstant $nhash-clear-key-bits-mask #xfffff)
188
189
[10731]190(defun %hash-symbol (sym)
191  (if sym   
192    (let* ((vector (%symptr->symvector sym))
[13279]193           (cell (%svref vector target::symbol.plist-cell))
194           (consp (consp cell)))
195      (or (if consp (%car cell) cell)
[10731]196          (let* ((pname (%svref vector target::symbol.pname-cell))
197                 (hash (mixup-hash-code (%pname-hash pname (uvsize pname)))))
[13279]198            (declare (type simple-string pname) (fixnum hash))
199            (if consp
200              (setf (%car cell) hash)
201              (setf (%svref vector target::symbol.plist-cell) hash)))))
[10731]202    +nil-hash+))
203             
[1833]204;;; Hash on address, or at least on some persistent, immutable
205;;; attribute of the key.  If all keys are fixnums or immediates (or if
206;;; that attribute exists), rehashing won't ever be necessary.
[6]207(defun %%eqhash (key)
208  (let* ((typecode (typecode key)))
[2491]209    (if (eq typecode target::tag-fixnum)
210      (values (mixup-hash-code key) nil)
211      (if (eq typecode target::subtag-instance)
212        (values (mixup-hash-code (instance.hash key)) nil)
[7908]213        (if (symbolp key)
214          (values (%hash-symbol key) nil)
[2491]215          (let ((hash (mixup-hash-code (strip-tag-to-fixnum key))))
216            (if (immediate-p-macro key)
217              (values hash nil)
218              (values hash :key ))))))))
[6]219
220
[6918]221#+32-bit-target
[2491]222(defun swap (num)
223  (declare (fixnum num))
224  (the fixnum (+ (the fixnum (%ilsl 16 num))(the fixnum (%ilsr 13 num)))))
225
[6918]226#+64-bit-target
227(defun swap (num)
228  (declare (fixnum num))
229  (the fixnum (+ (the fixnum (%ilsl 32 num))(the fixnum (%ilsr 29 num)))))
230
[6]231;;; teeny bit faster when nothing to do
232(defun %%eqlhash-internal (key)
233  (number-case key
234    (fixnum (mixup-hash-code key)) ; added this
235    (double-float (%dfloat-hash key))
236    (short-float (%sfloat-hash key))
237    (bignum (%bignum-hash key))
238    (ratio (logxor (swap (%%eqlhash-internal (numerator key)))
239                   (%%eqlhash-internal (denominator key))))
240    (complex
241     (logxor (swap (%%eqlhash-internal (realpart key)))
242             (%%eqlhash-internal (imagpart key))))
243    (t (cond ((macptrp key)
244              (%macptr-hash key))
245             (t key)))))
246
247               
248
249
[1833]250;;; new function
[6]251
252(defun %%eqlhash (key)
[1833]253  ;; if key is a macptr, float, bignum, ratio, or complex, convert it
254  ;; to a fixnum
[6]255  (if (hashed-by-identity key)
256    (%%eqhash key)
257    (let ((primary  (%%eqlhash-internal key)))
258      (if (eq primary key)
259        (%%eqhash key)
260        (mixup-hash-code (strip-tag-to-fixnum primary))))))
261
262
263(defun %%equalhash (key)
264  (let* ((id-p (hashed-by-identity key))
265         (hash (if (and key (not id-p)) (%%eqlhash-internal key)))
266         addressp)
267    (cond ((null key) (mixup-hash-code 17))
[3567]268          #+64-bit-target
[1901]269          ((and (typep key 'single-float)
270                (zerop (the single-float key)))
271           0)
[6]272          ((immediate-p-macro key) (mixup-hash-code (strip-tag-to-fixnum key)))
273          ((and hash (neq hash key)) hash)  ; eql stuff
274          (t (typecase key
[15459]275                (simple-string (%string-hash 0 key (length key)))
[6]276                (string
277                 (let ((length (length key)))
278                   (multiple-value-bind (data offset) (array-data-and-offset key)
[7943]279                     (%string-hash offset data length))))
[6]280                (bit-vector (bit-vector-hash key))
281                (cons
282                 (let ((hash 0))
283                   (do* ((i 0 (1+ i))
[15459]284                         (done nil)
285                         (list key (unless done (cdr list))))
286                        ((or done (> i 11))) ; who figured 11?
[6]287                     (declare (fixnum i))
[15459]288                     (multiple-value-bind (h1 a1) (%%equalhash
289                                                   (if (atom list)
290                                                     (progn
291                                                       (setq done t)
292                                                       list)
293                                                     (%car list)))
[6]294                       (when a1 (setq addressp t))
295                       ; fix the case of lists of same stuff in different order
296                       ;(setq hash (%ilogxor (fixnum-rotate h1 i) hash))
297                       (setq hash (%i+ (rotate-hash-code hash) h1))
298                       ))
[15459]299                   (values (mixup-hash-code hash) addressp)))
[6]300                (pathname (%%equalphash key))
301                (t (%%eqlhash key)))))))
302
[15596]303(defun %string-hash-folding-case (start string len)
304  (declare (index start len)
305           (optimize (speed 3) (safety 0)))
306  (let* ((copy (make-string len)))
307    (declare (dynamic-extent copy))
308    (dotimes (i len (values (%string-hash 0 copy len)))
309      (declare (index i))
310      (setf (schar copy i)
311            (char-upcase (schar string start))
312            start (1+ start)))))
313
314(defun %hash-pathname (key)
315  (let* ((logical (istruct-typep key 'logical-pathnames))
316         (case-sensitive *case-sensitive-filesystem*)
317         (hash 0))
318    (flet ((incorporate (component)
319             (setq hash (logand target::target-most-positive-fixnum
320                                (+ hash
321                                   (if case-sensitive
322                                     (%%equalhash component)
323                                     (%%equalphash component)))))))
324      (if logical
325        (progn
[15601]326          (setq hash (%%equalphash (%logical-pathname-host key)))
[15596]327          (incorporate (%logical-pathname-version key)))
328        (incorporate (%physical-pathname-device key)))
329      (dolist (element (%pathname-directory key))
330        (incorporate element))
331      (incorporate (%pathname-name key))
332      (incorporate (%pathname-type key))
333      (mixup-hash-code hash))))
334   
335
336         
337   
338
[10814]339(defun update-hash-flags (hash vector addressp)
340  (when addressp
341    (flet ((new-flags (flags addressp)
342             (declare (fixnum flags))
343             (if (eq :key addressp)
344               ;; hash code depended on key's address
345               (if (logbitp $nhash_component_address_bit flags)
346                 flags
347                 (logior $nhash-track-keys-mask
348                         (if (logbitp $nhash_track_keys_bit flags)
349                           flags
350                           (bitclr $nhash_key_moved_bit flags))))
351               ;; hash code depended on component address
352               (bitset $nhash_component_address_bit
353                       (logand (lognot $nhash-track-keys-mask) flags)))))
354      (declare (inline new-flags))
355      (if (hash-lock-free-p hash)
356        (loop
357          (let* ((flags (nhash.vector.flags vector))
358                 (new-flags (new-flags flags addressp)))
359            (when (or (eq flags new-flags)
360                      (store-gvector-conditional nhash.vector.flags vector flags new-flags))
361              (return))))
362        (setf (nhash.vector.flags vector)
363              (new-flags (nhash.vector.flags vector) addressp))))))
364
[2491]365(defun compute-hash-code (hash key update-hash-flags &optional
366                               (vector (nhash.vector hash))) ; vectorp))
[6]367  (let ((keytransF (nhash.keytransF hash))
368        primary addressp)
369    (if (not (fixnump keytransF))
[2491]370      ;; not EQ or EQL hash table
371      (progn
[6]372        (multiple-value-setq (primary addressp) (funcall keytransF key))
373        (let ((immediate-p (immediate-p-macro primary)))
374          (setq primary (strip-tag-to-fixnum primary))
375          (unless immediate-p
376            (setq primary (mixup-hash-code primary))
377            (setq addressp :key))))
[2491]378      ;; EQ or EQL hash table
[6]379      (if (and (not (eql keytransF 0))
380               (need-use-eql key))
381        ;; EQL hash table
382        (setq primary (%%eqlhash-internal key))
383        ;; EQ hash table - or something eql doesn't do
384        (multiple-value-setq (primary addressp) (%%eqhash key))))
[10814]385    (when update-hash-flags
386      (when addressp
387        (update-hash-flags hash vector addressp)))
[9999]388    (let* ((entries (nhash.vector-size vector)))
389      (declare (fixnum entries))
[6]390      (values primary
[9999]391              (hash-mod primary entries vector)
[6]392              entries))))
393
394(defun %already-rehashed-p (primary rehash-bits)
395  (declare (optimize (speed 3)(safety 0)))
396  (declare (type (simple-array bit (*)) rehash-bits))
[4146]397  (eql 1 (sbit rehash-bits primary)))
[6]398
399(defun %set-already-rehashed-p (primary rehash-bits)
400  (declare (optimize (speed 3)(safety 0)))
401  (declare (type (simple-array bit (*)) rehash-bits))
[4146]402  (setf (sbit rehash-bits primary) 1))
[6]403
404
405(defun hash-table-p (hash)
406  (istruct-typep hash 'hash-table))
407
408(defun %normalize-hash-table-count (hash)
409  (let* ((vector (nhash.vector hash))
[10731]410         (weak-deletions-count (nhash.vector.weak-deletions-count vector)))
[6]411    (declare (fixnum weak-deletions-count))
412    (unless (eql 0 weak-deletions-count)
413      (setf (nhash.vector.weak-deletions-count vector) 0)
[10731]414      ;; lock-free hash tables don't maintain deleted-count, since would need to
415      ;; lock and it's not worth it.
416      (unless (hash-lock-free-p hash)
417        (let ((deleted-count (the fixnum
418                               (+ (the fixnum (nhash.vector.deleted-count vector))
419                                  weak-deletions-count)))
420              (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count))))
421          (setf (nhash.vector.deleted-count vector) deleted-count
422                (nhash.vector.count vector) count))))))
[6]423
424
[2513]425(defparameter *shared-hash-table-default* t
426  "Be sure that you understand the implications of changing this
427before doing so.")
428
[10867]429(defparameter *lock-free-hash-table-default* :shared
[10751]430  "If NIL, hash tables default to using the standard algorithms, with locks for shared tables.
431   If :SHARED, shared hash tables default to using the \"lock-free\" algorithm,
432   which is faster for typical access but slower for rehashing or growing the table.
433   Otherwise, all hash tables default to the lock-free algorithm")
[10731]434
[6]435(defun make-hash-table (&key (test 'eql)
436                             (size 60)
437                             (rehash-size 1.5)
438                             (rehash-threshold .85)
439                             (hash-function nil)
440                             (weak nil)
441                             (finalizeable nil)
[10731]442                             (address-based t)  ;; Ignored
443                             (lock-free *lock-free-hash-table-default*)
[2513]444                             (shared *shared-hash-table-default*))
[929]445  "Create and return a new hash table. The keywords are as follows:
446     :TEST -- Indicates what kind of test to use.
447     :SIZE -- A hint as to how many elements will be put in this hash
448       table.
449     :REHASH-SIZE -- Indicates how to expand the table when it fills up.
450       If an integer, add space for that many elements. If a floating
451       point number (which must be greater than 1.0), multiply the size
452       by that amount.
453     :REHASH-THRESHOLD -- Indicates how dense the table can become before
454       forcing a rehash. Can be any positive number <=1, with density
455       approaching zero as the threshold approaches 0. Density 1 means an
456       average of one entry per bucket."
[10731]457  (declare (ignore address-based)) ;; TODO: could reinterpret as "warn if becomes address-based"
[6]458  (unless (and test (or (functionp test) (symbolp test)))
459    (report-bad-arg test '(and (not null) (or symbol function))))
460  (unless (or (functionp hash-function) (symbolp hash-function))
461    (report-bad-arg hash-function '(or symbol function)))
462  (unless (and (realp rehash-threshold) (<= 0.0 rehash-threshold) (<= rehash-threshold 1.0))
463    (report-bad-arg rehash-threshold '(real 0 1)))
464  (unless (or (fixnump rehash-size) (and (realp rehash-size) (< 1.0 rehash-size)))
465    (report-bad-arg rehash-size '(or fixnum (real 1 *))))
466  (unless (fixnump size) (report-bad-arg size 'fixnum))
467  (setq rehash-threshold (/ 1.0 (max 0.01 rehash-threshold)))
[2491]468  (let* ((default-hash-function
469             (cond ((or (eq test 'eq) (eq test #'eq)) 
470                    (setq test 0))
471                   ((or (eq test 'eql) (eq test #'eql)) 
472                    (setq test -1))
473                   ((or (eq test 'equal) (eq test #'equal))
474                    (setq test #'equal) #'%%equalhash)
475                   ((or (eq test 'equalp) (eq test #'equalp))
476                    (setq test #'equalp) #'%%equalphash)
477                   (t (setq test (require-type test 'symbol))
[10731]478                      (or hash-function 
479                          (error "non-standard test specified without hash-function")))))
[2491]480         (find-function
481          (case test
482            (0 #'eq-hash-find)
483            (-1 #'eql-hash-find)
[2546]484            (t #'general-hash-find)))
[2491]485         (find-put-function
486          (case test
487            (0 #'eq-hash-find-for-put)
488            (-1 #'eql-hash-find-for-put)
[2546]489            (t #'general-hash-find-for-put))))
[6]490    (setq hash-function
491          (if hash-function
492            (require-type hash-function 'symbol)
[2491]493            default-hash-function))
494    (when (and weak (neq weak :value) (neq test 0))
495      (error "Only EQ hash tables can be weak."))
496    (when (and finalizeable (not weak))
497      (error "Only weak hash tables can be finalizeable."))
[10812]498    (when (and (eq lock-free :shared) (not shared))
499      (setq lock-free nil))
[10731]500    (multiple-value-bind (grow-threshold total-size)
[2491]501        (compute-hash-size (1- size) 1 rehash-threshold)
[10731]502      (let* ((flags (+ (if weak (ash 1 $nhash_weak_bit) 0)
503                       (ecase weak
504                         ((t nil :key) 0)
505                         (:value (ash 1 $nhash_weak_value_bit)))
506                       (if finalizeable (ash 1 $nhash_finalizeable_bit) 0)
507                       (if lock-free (ash 1 $nhash_keys_frozen_bit) 0)))
[2491]508             (hash (%cons-hash-table 
[10731]509                    hash-function test
[2491]510                    (%cons-nhash-vector total-size flags)
[10731]511                    grow-threshold rehash-threshold rehash-size
[2513]512                    find-function find-put-function
[10731]513                    (unless shared *current-process*)
514                    lock-free)))
[2491]515        (setf (nhash.vector.hash (nhash.vector hash)) hash)
516        hash))))
[6]517
518(defun compute-hash-size (size rehash-size rehash-ratio)
519  (let* ((new-size size))
[10731]520    (declare (fixnum size new-size))
[6]521    (setq new-size (max 30 (if (fixnump rehash-size)
[10731]522                             (%i+ size rehash-size)
[6]523                             (ceiling (* size rehash-size)))))
524    (if (<= new-size size)
525      (setq new-size (1+ size)))        ; God save you if you make this happen
526   
[10731]527    (let ((vector-size (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio))))))
528      ; TODO: perhaps allow more entries, based on actual size:
529      ;  (values (min (floor vector-size rehash-ratio) (%i- vector-size 2)) vector-size))
530      (values new-size vector-size)
531      )))
[6]532
[1596]533;;;  Suggested size is a fixnum: number of pairs.  Return a fixnum >=
534;;;  that size that is relatively prime to all secondary keys.
[6]535(defun %hash-size (suggestion)
536  (declare (fixnum suggestion))
537  (declare (optimize (speed 3)(safety 0)))
538  (if (<= suggestion #.(aref secondary-keys 7))
539    (setq suggestion (+ 2 #.(aref secondary-keys 7)))
540     (setq suggestion (logior 1 suggestion)))
541  (loop
542    (dovector (key secondary-keys (return-from %hash-size suggestion))
543      (when (eql 0 (fast-mod suggestion key))
544        (return)))
545    (incf suggestion 2)))
546
547
[10731]548(defvar *continue-from-readonly-hashtable-lock-error* t)
[6]549
[7722]550(defun signal-read-only-hash-table-error (hash)
[10978]551  (cond ((hash-lock-free-p hash)
552         ;; We don't really do anything different if this is set, so no problem
553         (cerror "Modify it anyway"
554                 "Attempt to modify readonly hash table ~s" hash))
555        (*continue-from-readonly-hashtable-lock-error*
[10731]556         (cerror "Make the hash-table writable. DANGEROUS! This could damage your lisp if another thread is acccessing this table. CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
[7624]557                 "Hash-table ~s is readonly" hash)
558         (assert-hash-table-writeable hash)
[7722]559         (write-lock-hash-table hash))
[7624]560        (t (error "Hash-table ~s is readonly" hash))))
[6]561
[7722]562(defun read-lock-hash-table (hash)
[7624]563  (if (nhash.read-only hash)
[7722]564    :readonly
[7624]565    (let* ((lock (nhash.exclusion-lock hash)))
566      (if lock
[7722]567        (read-lock-rwlock lock)
568        (unless (eq (nhash.owner hash) *current-process*)
569          (error "Not owner of hash table ~s" hash))))))
[6]570
[7722]571(defun write-lock-hash-table (hash)
[7624]572  (if (nhash.read-only hash)
[7722]573    (signal-read-only-hash-table-error hash)
[7624]574    (let* ((lock (nhash.exclusion-lock hash)))
575      (if lock
576        (write-lock-rwlock lock)
[7722]577        (unless (eq (nhash.owner hash) *current-process*)
578          (error "Not owner of hash table ~s" hash))))))
[6]579
580
[7624]581(defun unlock-hash-table (hash was-readonly)
582  (unless was-readonly
583    (let* ((lock (nhash.exclusion-lock hash)))
584      (if lock
585        (unlock-rwlock lock)))))
586
[6]587(defun index->vector-index (index)
588  (declare (fixnum index))
589  (the fixnum (+ $nhash.vector_overhead (the fixnum (+ index index)))))
590
591(defun vector-index->index (index)
592  (declare (fixnum index))
593  (the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1)))
594
595(defun hash-table-count (hash)
[929]596  "Return the number of entries in the given HASH-TABLE."
[10731]597  (setq hash (require-type hash 'hash-table))
598  (when (hash-lock-free-p hash)
599    ;; We don't try to maintain a running total, so just count.
600    (return-from hash-table-count (lock-free-count-entries hash)))
[6]601  (%normalize-hash-table-count hash)
[10731]602  (the fixnum (nhash.vector.count (nhash.vector hash))))
[6]603
604(defun hash-table-rehash-size (hash)
[929]605  "Return the rehash-size HASH-TABLE was created with."
[6]606  (nhash.rehash-size (require-type hash 'hash-table)))
607
608(defun hash-table-rehash-threshold (hash)
[929]609  "Return the rehash-threshold HASH-TABLE was created with."
[6]610  (/ 1.0 (nhash.rehash-ratio (require-type hash 'hash-table))))
611
612(defun hash-table-size (hash)
[929]613  "Return a size that can be used with MAKE-HASH-TABLE to create a hash
614   table that can hold however many entries HASH-TABLE can hold without
615   having to be grown."
[10731]616  (let* ((hash (require-type hash 'hash-table))
617         (vector (nhash.vector hash)))
618    (values (floor (nhash.vector.size vector) (nhash.rehash-ratio hash)))))
[6]619
620(defun hash-table-test (hash)
[929]621  "Return the test HASH-TABLE was created with."
[6]622  (let ((f (nhash.compareF (require-type hash 'hash-table))))
623    (if (fixnump f)
624      (if (eql 0 f) 'eq 'eql)
625      (let ((name (if (symbolp f) f (function-name f))))
626        (if (memq name '(equal equalp)) name f)))))
627
[1884]628;;; sometimes you'd rather have the function than the symbol.
[6]629(defun hash-table-test-function (hash)
630  (let ((f (nhash.compareF (require-type hash 'hash-table))))
631    (if (fixnump f)
632      (if (eql 0 f) #'eq #'eql)
633      f)))
634
[10731]635;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
636;;
637;; nearly-lock-free hash tables
638;;
639;; A modification of the lock-free hash table algorithm described by Cliff Click Jr.  in
640;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html.
641;;
[10814]642;; The modifications have to do with the fact that our goal is just to minimize the
643;; performance impact of thread-safety, by eliminating the need for locking on every
644;; read.  I don't bother with aspects of his algorithm that aren't relevant to that goal.
[10731]645;;
646;; The main difference from Click's algorithm is that I don't try to do rehashing
647;; concurrently.  Instead, rehashing grabs a lock, so that only one thread can be
648;; rehashing at any given time, and readers/writers will block waiting for the rehashing
649;; to finish.
650;;
[15504]651;; In our implementation the following are the possible states of a hash table entry:
652;;   (where "object" means any object other than the special markers):
[10731]653;;
654;; State      Key               Value
[15504]655;; FREE       free-hash-marker  free-hash-marker
656;; INSERTING  object            free-hash-marker
[15525]657;; DELETING0  deleted-marker    free-hash-marker  ;; abandoned insert
[10731]658;; IN-USE     object            object
[15504]659;; DELETING1  object            deleted-marker
660;; DELETING2  deleted-marker    object
661;; DELETED    deleted-marker    deleted-marker
[10731]662;; REHASHING  object            rehashing-value-marker
663;; REHASHING  free-hash-marker  rehashing-value-marker
[10814]664;; REHASHING  deleted-marker    rehashing-value-marker
[10731]665;;
666;; No other states are allowed - at no point in time can a hash table entry be in any
[10814]667;; other state.   In addition, the only transitions allowed on the key slot are
668;; free-hash-marker -> object/deleted-marker -> deleted-marker.  Once a key slot
669;; is claimed, it must never change to free or another key value (even after the hash
[15504]670;; vector has been discarded after rehashing, because some process might still be
671;; looking at it).
[10731]672;; In particular, rehashing in place is not an option.  All rehashing creates a new
673;; vector and copies into it.  This means it's kinda risky to use lock-free hash
674;; tables with address-based keys, because they will thrash in low-memory situations,
675;; but we don't disallow it because a particular use might not have this problem.
[10814]676;;
677;; The following operations may take place:
678;;
679;; * gethash: find matching key - if no match, return not found.  Else fetch value,
680;;   if value is rehashing-value-marker then maybe-rehash and try again;
[15504]681;;   if value is free-hash-marker or deleted-marker, return not found, else return found value.
[10814]682;; * puthash: find matching key or FREE slot.
683;;   ** If found key, fetch value.
684;;      if value is rehashing-value-marker then maybe-rehash and try again;
685;;      else store-conditional the value -> new value, if fails try again.
686;;   ** Else have FREE slot, store-key-conditional free-hash-marker -> key,
[15525]687;;      if that succeeds, check whether key moved (invalidating the hash), if so,
688;;         back out to DELETED0 and try again,
689;;      else store-conditional free-hash-marker -> new value,
690;;      if either store fails, maybe-rehash and try again.
[10814]691;; * remhash: find matching key - if no match, done.  Else fetch value,
692;;   if value is rehashing-value-marker then maybe-rehash and try again;
[15504]693;;   if value is free-hash-marker or deleted-marker, done.
694;;   else store-conditional the value -> deleted-marker, if fails try again.
695;;    if succeeds, clobber key with deleted-marker to allow it to get gc'd.
696;; * clrhash: grab the rehash lock, then set all slots to DELETED (transitioning through either
[15525]697;;    DELETING1 or DELETING2 state).
[10814]698;; * rehash: grab a lock, estimate number of entries, make a new vector.  loop over
699;; old vector, at each entry fetch the old value with atomic swap of
700;; rehashing-value-marker.  This prevents any further state changes involving the
701;; value.  It doesn't prevent state changes involving the key, but the only ones that
[15504]702;; can happen is FREE -> INSERTING, and DELETINGn -> DELETED, all of which are
[10814]703;; equivalent from the point of view of rehashing.  Anyway, if the old value was
704;; rehashing-value-marker then bug (because we have a lock).  If the old value is
[15504]705;; free-hash-marker or deleted-marker then do nothing, else get the entry key and
706;; rehash into the new vector -- if no more room, start over.  When done, store the
707;; new vector in the hash table and release lock.
[10814]708;;
[15504]709;; * gc: for weak tables, gc may convert IN-USE states to DELETED states.
[6]710
711
[10731]712(defun lock-free-rehash (hash)
713  ;;(break "We think we need to rehash ~s" (nhash.vector hash))
714  (with-lock-context
715    (without-interrupts ;; not re-entrant
716      (let ((lock (nhash.exclusion-lock hash)))
717        (%lock-recursive-lock-object lock)
718        ;; TODO: might also want to rehash if deleted entries are a large percentage
719        ;; of all entries, more or less.
720        (when (or (%i<= (nhash.grow-threshold hash) 0) ;; no room
721                  (%needs-rehashing-p (nhash.vector hash))) ;; or keys moved
722          (%lock-free-rehash hash))
723        (%unlock-recursive-lock-object lock)))))
[6]724
[10731]725
726;; TODO: This is silly.  We're implementing atomic swap using store-conditional,
727;; but internally store-conditional is probably implemented using some kind of
728;; an atomic swap!!
729(defun atomic-swap-gvector (index gvector value)
730  (loop
731    (let ((old-value (%svref gvector index)))
732      (when (store-gvector-conditional index gvector old-value value)
733        (return old-value)))))
734
735;; Interrupts are disabled and caller has the hash lock on the table, blocking other
736;; threads attempting a rehash.
737;; Other threads might be reading/writing/deleting individual entries, but they
738;; will block if they see a value = rehashing-value-marker.
739;; GC may run, updating the needs-rehashing flags and deleting weak entries in both
740;; old and new vectors.
741(defun %lock-free-rehash (hash)
742  (let* ((old-vector (nhash.vector hash))
743         (inherited-flags (logand $nhash_weak_flags_mask (nhash.vector.flags old-vector)))
[10913]744         (grow-threshold (nhash.grow-threshold hash))
745         count new-vector vector-size)
[15525]746    ;; Prevent puthash from adding new entries.
[10913]747    (setf (nhash.grow-threshold hash) 0)
748    (setq count (lock-free-count-entries hash))
749    (multiple-value-setq (grow-threshold vector-size)
750      (if (%i<= grow-threshold 0) ; if ran out of room, grow, else get just enough.
751        (compute-hash-size count (nhash.rehash-size hash) (nhash.rehash-ratio hash))
752        (compute-hash-size count 1 (nhash.rehash-ratio hash))))
753    (setq new-vector (%cons-nhash-vector vector-size inherited-flags))
[15525]754    (loop ;; with full-count = grow-threshold
[10913]755          for i from $nhash.vector_overhead below (uvsize old-vector) by 2
756          do (let* ((value (atomic-swap-gvector (%i+ i 1) old-vector rehashing-value-marker))
757                    (key (%svref old-vector i)))
758               (when (eq value rehashing-value-marker) (error "Who else is doing this?"))
[15504]759               (unless (or (eq value free-hash-marker)
760                           (eq value deleted-hash-value-marker)
761                           (eq key deleted-hash-key-marker))
[10913]762                 (let* ((new-index (%growhash-probe new-vector hash key))
763                        (new-vector-index (index->vector-index new-index)))
764                   (%set-hash-table-vector-key new-vector new-vector-index key)
765                   (setf (%svref new-vector (%i+ new-vector-index 1)) value)
766                   (decf grow-threshold)
767                   (when (%i<= grow-threshold 0)
[15525]768                     (error "Bug: undeleted entries?")
769                     #+obsolete ;; we no longer undelete entries
[10913]770                     ;; Too many entries got undeleted while we were rehashing (that's the
771                     ;; only way we could end up with more than COUNT entries, as adding
772                     ;; new entries is blocked).  Grow the output vector.
773                     (multiple-value-bind (bigger-threshold bigger-vector-size)
774                         (compute-hash-size full-count (nhash.rehash-size hash) (nhash.rehash-ratio hash))
775                       (assert (> bigger-vector-size vector-size))
776                       (let ((bigger-vector (%cons-nhash-vector bigger-vector-size 0)))
777                         (%copy-gvector-to-gvector new-vector
778                                                   $nhash.vector_overhead
779                                                   bigger-vector
780                                                   $nhash.vector_overhead
781                                                   (%i- (uvsize new-vector) $nhash.vector_overhead))
782                         (setf (nhash.vector.flags bigger-vector) (nhash.vector.flags new-vector))
783                         (%lock-free-rehash-in-place hash bigger-vector)
784                         (setq grow-threshold (- bigger-threshold full-count))
785                         (setq full-count bigger-threshold)
786                         (setq new-vector bigger-vector)
787                         (setq vector-size bigger-vector-size))))))))
788    (when (%needs-rehashing-p new-vector) ;; keys moved, but at least can use the same new-vector.
789      (%lock-free-rehash-in-place hash new-vector))
[10731]790    (setf (nhash.vector.hash new-vector) hash)
791    (setf (nhash.grow-threshold hash) grow-threshold)
792    ;; At this point, another thread might decrement the threshold while they're looking at the old
793    ;; vector. That's ok, just means it will be too small and we'll rehash sooner than planned,
794    ;; no big deal.
795    (setf (nhash.vector hash) new-vector)))
796
[10913]797;; This is called on a new vector that hasn't been installed yet, so no other thread is
798;; accessing it.  However, gc might be deleting stuff from it, which is why it tests
799;; key for deleted-hash-key-marker in addition to free-hash-marker value
800(defun %lock-free-rehash-in-place (hash vector)
801  (let* ((vector-index (- $nhash.vector_overhead 2))
802         (size (nhash.vector-size vector))
803         (rehash-bits (%make-rehash-bits hash size))
804         (index -1))
805    (declare (fixnum size index vector-index))
806    (%set-does-not-need-rehashing vector)
807    (loop
808      (when (>= (incf index) size) (return))
809      (setq vector-index (+ vector-index 2))
810      (unless (%already-rehashed-p index rehash-bits)
[15525]811        (let* ((key (%svref vector vector-index)))
812          (if (or (eq key free-hash-marker) (eq key deleted-hash-key-marker))
813            (unless (eq key free-hash-marker)
814              (setf (%svref vector vector-index) free-hash-marker
815                    (%svref vector (%i+ vector-index 1)) free-hash-marker))
[10913]816            (let* ((last-index index)
[15525]817                   (value (%svref vector (%i+ vector-index 1)))
[10913]818                   (first t))
819              (loop
820                (let ((found-index (%rehash-probe rehash-bits hash key vector)))
821                  (%set-already-rehashed-p found-index rehash-bits)
822                  (when (eq last-index found-index)
823                    (return))
824                  (let* ((found-vector-index (index->vector-index found-index))
825                         (newvalue (%svref vector (the fixnum (1+ found-vector-index))))
826                         (newkey (%svref vector found-vector-index)))
827                    (declare (fixnum found-vector-index))
828                    (when first         ; or (eq last-index index) ?
829                      (setq first nil)
830                      (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker)
831                      (setf (%svref vector vector-index) free-hash-marker))
832                    (%set-hash-table-vector-key vector found-vector-index key)
833                    (setf (%svref vector (the fixnum (1+ found-vector-index))) value)
[15525]834                    (when (or (eq newkey deleted-hash-key-marker) (eq newkey free-hash-marker))
[10913]835                      (return))
836                    (when (eq key newkey)
837                      (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
838                              key hash value newvalue index found-index)                       
839                      (return))
840                    (setq key newkey
841                          value newvalue
842                          last-index found-index))))))))))
843  t )
[10731]844
[10913]845
[10731]846(defun lock-free-gethash (key hash default)
847  (declare (optimize (speed 3) (safety 0) (debug 0)))
848  (loop
849    (let* ((vector (nhash.vector hash))
850           (vector-index (funcall (the function (nhash.find hash)) hash key)))
851      (declare (fixnum vector-index))
852      ;; Need to punt if vector changed because no way to know whether nhash.find was
853      ;; using old or new vector.
854      (when (eq vector (nhash.vector hash))
855        (cond ((eql vector-index -1)
856               (unless (%needs-rehashing-p vector)
857                 (return-from lock-free-gethash (values default nil))))
858              (t (let ((value (%svref vector (%i+ vector-index 1))))
859                   (unless (eq value rehashing-value-marker)
[15504]860                     (if (or (eq value deleted-hash-value-marker)
861                             (eq value free-hash-marker))
[10731]862                       (return-from lock-free-gethash (values default nil))
863                       (return-from lock-free-gethash (values value t)))))))))
864    ;; We're here because the table needs rehashing or it was getting rehashed while we
865    ;; were searching. Take care of it and try again.
866    (lock-free-rehash hash)))
867
868(defun lock-free-remhash (key hash)
869  (declare (optimize (speed 3) (safety 0) (debug 0)))
[10978]870  (when (nhash.read-only hash)
871    (signal-read-only-hash-table-error hash)) ;; continuable
[10731]872  (loop
873    (let* ((vector (nhash.vector hash))
874           (vector-index (funcall (the function (nhash.find hash)) hash key)))
875      (declare (fixnum vector-index))
876      ;; Need to punt if vector changed because no way to know whether nhash.find was
877      ;; using old or new vector.
878      (when (eq vector (nhash.vector hash))
879        (cond ((eql vector-index -1)
880               (unless (%needs-rehashing-p vector)
881                 (return-from lock-free-remhash nil)))
882              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
883                   (unless (eq old-value rehashing-value-marker)
[15504]884                     (when (or (eq old-value deleted-hash-value-marker) ;; deleted
885                               (eq old-value free-hash-marker)) ;; or about to be added
[10731]886                       (return-from lock-free-remhash nil))
[15504]887                     (when (set-hash-value-conditional vector-index vector old-value deleted-hash-value-marker)
888                       ;; Clear the key slot so can be gc'd.
889                       (setf (%svref vector vector-index) deleted-hash-key-marker)
[10731]890                       (return-from lock-free-remhash t)))))))
891      ;; We're here because the table needs rehashing or it was getting rehashed while we
892      ;; were searching.  Take care of it and try again.
893      (lock-free-rehash hash))))
894
[15504]895;; TODO: might be better (faster, safer) to just create a new all-free vector?
[10731]896(defun lock-free-clrhash (hash)
[10978]897  (when (nhash.read-only hash)
898    (signal-read-only-hash-table-error hash)) ;;continuable
[10731]899  (with-lock-context
900    (without-interrupts
901     (let ((lock (nhash.exclusion-lock hash)))
902       (%lock-recursive-lock-object lock) ;; disallow rehashing.
903       (loop
904         with vector = (nhash.vector hash)
[15504]905         for i fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize vector) by 2
906         as val = (%svref vector i)
907         unless (or (eq val free-hash-marker) (eq val deleted-hash-value-marker))
908         do (setf (%svref vector (%i- i 1)) deleted-hash-key-marker
909                  (%svref vector i) deleted-hash-value-marker))
[10731]910       (%unlock-recursive-lock-object lock))))
911  hash)
912
913(defun lock-free-puthash (key hash value)
914  (declare (optimize (speed 3) (safety 0) (debug 0)))
915  (when (or (eq value rehashing-value-marker)
[15504]916            (eq value free-hash-marker)
917            (eq value deleted-hash-value-marker))
[10731]918    (error "Illegal value ~s for storing in a hash table" value))
[10978]919  (when (nhash.read-only hash)
920    (signal-read-only-hash-table-error hash)) ;;continuable
[10731]921  (loop
[15525]922    (let* ((vector (nhash.vector hash))
923           (address (strip-tag-to-fixnum key))
924           ;; This also makes sure the vector's track_keys bit is set if key is address based (in an eq table),
925           ;; and component_address bit is set if a key component is address based (in an equal[p] table).
[10731]926           (vector-index (funcall (nhash.find-new hash) hash key)))
927      ;; Need to punt if vector changed because no way to know whether nhash.find-new was
928      ;; using old or new vector.
929      (when (eq vector (nhash.vector hash))
930        (cond ((or (eql vector-index -1)
931                   (eq (%svref vector vector-index) free-hash-marker))
932               (unless (or (%needs-rehashing-p vector)
933                           (%i<= (nhash.grow-threshold hash) 0))
934                 ;; Note if the puthash fails, grow-threshold will end up too small. This
935                 ;; just means we might rehash sooner than absolutely necessary, no real
936                 ;; harm done (the most likely cause of failing is that somebody is
937                 ;; already rehashing anyway).  DON'T try to incf it back on failure --
938                 ;; that risks grow-threshold ending up too big (e.g. if somebody rehashes
939                 ;; before the incf), which _could_ be harmful.
940                 (atomic-decf (nhash.grow-threshold hash))
[15504]941                 (when (set-hash-key-conditional vector-index vector free-hash-marker key)
[15525]942                   ;; %needs-rehashing-p is not equite enough in the track_keys case, since gc cannot
943                   ;; track this key until it's actually added to the table.  Check now.
944                   (if (and (%ilogbitp $nhash_track_keys_bit (nhash.vector.flags vector))
945                            (not (eq address (strip-tag-to-fixnum key))))
946                     (setf (%svref vector vector-index) deleted-hash-key-marker)                       ;; Back out and try again.
947                     (when (set-hash-value-conditional vector-index vector free-hash-marker value)
948                       (return-from lock-free-puthash value))))))
[10731]949              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
[15504]950                   (unless (or (eq old-value rehashing-value-marker)
951                               ;; In theory, could reuse the deleted slot since we know it had this key
952                               ;; initially, but that would complicate the state machine for very little gain.
953                               (eq old-value deleted-hash-value-marker))
[10731]954                     (when (set-hash-value-conditional vector-index vector old-value value)
955                       (return-from lock-free-puthash value))))))))
956    ;; We're here because the table needs rehashing or it was getting rehashed while we
957    ;; were searching, or no room for new entry, or somebody else claimed the key from
958    ;; under us (that last case doesn't need to retry, but it's unlikely enough that
959    ;; it's not worth checking for).  Take care of it and try again.
960    (lock-free-rehash hash)))
961
962(defun lock-free-count-entries (hash)
963  ;; Other threads could be adding/removing entries while we count, some of
964  ;; which will be included in the count (i.e. will be treated as if they
965  ;; happened after counting) and some won't (i.e. will be treated as if
966  ;; they happened before counting), but not necessarily in correlation
967  ;; with their temporal relationship.
968  (loop
969    with vector = (nhash.vector hash)
970    for i fixnum from $nhash.vector_overhead below (uvsize vector) by 2
[10913]971    count (let ((value (%svref vector (%i+ i 1))))
972            (when (eq value rehashing-value-marker)
973              ;; This table is being rehashed.  Wait for it to be
974              ;; done and try again.
975              (lock-free-rehash hash)
976              (return-from lock-free-count-entries (lock-free-count-entries hash)))
[15508]977            (and (neq value free-hash-marker)
978                 (neq value deleted-hash-value-marker)))))
[10731]979
980;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
981
982
[2491]983(defun gethash (key hash &optional default)
984  "Finds the entry in HASH-TABLE whose key is KEY and returns the associated
985   value and T as multiple values, or returns DEFAULT and NIL if there is no
986   such entry. Entries can be added using SETF."
[9912]987  (unless (typep hash 'hash-table)
[6]988    (report-bad-arg hash 'hash-table))
[10775]989  (when (or (eq key free-hash-marker)
990            (eq key deleted-hash-key-marker))
991    (return-from gethash (values default nil)))
[10731]992  (when (hash-lock-free-p hash)
993    (return-from gethash (lock-free-gethash key hash default)))
[2491]994  (let* ((value nil)
[6918]995         (gc-locked nil)
[7624]996         (readonly nil)
[2730]997         (foundp nil))
[7679]998    (with-lock-context
999      (without-interrupts
[10731]1000        (setq readonly (eq (read-lock-hash-table hash) :readonly))
1001        (let* ((vector (nhash.vector hash)))
1002          (if (and (eq key (nhash.vector.cache-key vector))
1003                   ;; Check twice: the GC might nuke the cached key/value pair
1004                   (progn (setq value (nhash.vector.cache-value vector))
1005                          (eq key (nhash.vector.cache-key vector))))
1006            (setq foundp t)
1007            (loop
1008              (let* ((vector-index (funcall (nhash.find hash) hash key)))
1009                (declare (fixnum vector-index))
1010                (cond ((setq foundp (not (eql vector-index -1)))
1011                       ;; Referencing both key and value here - and referencing
1012                       ;; value first - is an attempt to compensate for the
1013                       ;; possibility that the GC deletes a weak-on-key pair.
1014                       (setq value (%svref vector (%i+ vector-index 1)))
1015                       (when (nhash.owner hash)
1016                         (setf (nhash.vector.cache-key vector)
1017                               (%svref vector vector-index)
1018                               (nhash.vector.cache-value vector)
1019                               value
1020                               (nhash.vector.cache-idx vector)
1021                               (vector-index->index (the fixnum vector-index))))
1022                       (return))
1023                      ((%needs-rehashing-p vector)
1024                       (%lock-gc-lock)
1025                       (setq gc-locked t)
1026                       (unless readonly
1027                         (let* ((lock (nhash.exclusion-lock hash)))
1028                           (when lock (%promote-rwlock lock))))
1029                       (when (%needs-rehashing-p vector)
1030                         (%rehash hash)))
1031                      (t (return)))))))
1032        (when gc-locked (%unlock-gc-lock))
1033        (unlock-hash-table hash readonly)))
[2491]1034    (if foundp
1035      (values value t)
1036      (values default nil))))
[6]1037
[2491]1038(defun remhash (key hash)
1039  "Remove the entry in HASH-TABLE associated with KEY. Return T if there
1040   was such an entry, or NIL if not."
[9912]1041  (unless (typep hash 'hash-table)
[2491]1042    (setq hash (require-type hash 'hash-table)))
[10731]1043  (when (hash-lock-free-p hash)
1044    (return-from remhash (lock-free-remhash key hash)))
[2730]1045  (let* ((foundp nil))
[7679]1046    (with-lock-context
1047      (without-interrupts
[7722]1048       (write-lock-hash-table hash)
[7679]1049       (%lock-gc-lock)
1050       (let* ((vector (nhash.vector hash)))
[10731]1051         (when (%needs-rehashing-p vector)
1052           (%rehash hash))
[7679]1053         (if (eq key (nhash.vector.cache-key vector))
1054           (progn
[10731]1055             (setf (nhash.vector.cache-key vector) free-hash-marker
[2730]1056                   (nhash.vector.cache-value vector) nil)
[7679]1057             (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
1058               (setf (%svref vector vidx) deleted-hash-key-marker)
1059               (setf (%svref vector (the fixnum (1+ vidx))) nil))
[2730]1060             (incf (the fixnum (nhash.vector.deleted-count vector)))
[10731]1061             (decf (the fixnum (nhash.vector.count vector)))
[7679]1062             (setq foundp t))
[10731]1063           (let* ((vector-index (funcall (nhash.find hash) hash key)))
[7679]1064             (declare (fixnum vector-index))
[10731]1065             (unless (eql vector-index -1)
[7679]1066               ;; always clear the cache cause I'm too lazy to call the
1067               ;; comparison function and don't want to keep a possibly
1068               ;; deleted key from being GC'd
[10731]1069               (setf (nhash.vector.cache-key vector) free-hash-marker
[7679]1070                     (nhash.vector.cache-value vector) nil)
1071               ;; Update the count
1072               (incf (the fixnum (nhash.vector.deleted-count vector)))
[10731]1073               (decf (the fixnum (nhash.vector.count vector)))
[7679]1074               ;; Delete the value from the table.
1075               (setf (%svref vector vector-index) deleted-hash-key-marker
[10731]1076                     (%svref vector (the fixnum (1+ vector-index))) nil)
[14625]1077               (setq foundp t)))))
[7679]1078       ;; Return T if we deleted something
1079       (%unlock-gc-lock)
1080       (unlock-hash-table hash nil)))
[2491]1081    foundp))
[6]1082
[10731]1083;;; what if somebody is mapping, growing, rehashing?
1084(defun clrhash (hash)
1085  "This removes all the entries from HASH-TABLE and returns the hash table
1086   itself."
1087  (unless (typep hash 'hash-table)
1088    (report-bad-arg hash 'hash-table))
1089  (when (hash-lock-free-p hash)
1090    (return-from clrhash (lock-free-clrhash hash)))
1091  (with-lock-context
1092    (without-interrupts
1093     (write-lock-hash-table hash)
1094     (let* ((vector (nhash.vector hash))
1095            (size (nhash.vector-size vector))
1096            (count (+ size size))
1097            (index $nhash.vector_overhead))
1098       (declare (fixnum size count index))
1099       (dotimes (i count)
1100         (setf (%svref vector index) free-hash-marker)
1101         (incf index))
1102       (incf (the fixnum (nhash.grow-threshold hash))
1103             (the fixnum (+ (the fixnum (nhash.vector.count vector))
1104                            (the fixnum (nhash.vector.deleted-count vector)))))
1105       (setf (nhash.vector.count vector) 0
1106             (nhash.vector.cache-key vector) free-hash-marker
1107             (nhash.vector.cache-value vector) nil
1108             (nhash.vector.finalization-alist vector) nil
1109             (nhash.vector.free-alist vector) nil
1110             (nhash.vector.weak-deletions-count vector) 0
1111             (nhash.vector.deleted-count vector) 0
1112             (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
1113                                                 (nhash.vector.flags vector))))
1114     (unlock-hash-table hash nil)
1115     hash)))
1116
1117
[2491]1118(defun puthash (key hash default &optional (value default))
1119  (declare (optimize (speed 3) (space 0)))
[9912]1120  (unless (typep hash 'hash-table)
[2491]1121    (report-bad-arg hash 'hash-table))
[10775]1122  (when (or (eq key free-hash-marker)
1123            (eq key deleted-hash-key-marker))
1124    (error "Can't use ~s as a hash-table key" key))
[10731]1125  (when (hash-lock-free-p hash)
1126    (return-from puthash (lock-free-puthash key hash value)))
[7679]1127  (with-lock-context
1128    (without-interrupts
1129     (block protected
1130       (tagbody
[7722]1131          (write-lock-hash-table hash)
[6428]1132        AGAIN
[7679]1133          (%lock-gc-lock)
[10731]1134          (let ((vector (nhash.vector hash)))
1135            (when (%needs-rehashing-p vector)
1136              (%rehash hash))
[7679]1137            (when (eq key (nhash.vector.cache-key vector))
1138              (let* ((idx (nhash.vector.cache-idx vector)))
1139                (declare (fixnum idx))
1140                (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
1141                      value)
1142                (setf (nhash.vector.cache-value vector) value)
1143                (return-from protected)))               
1144            (let* ((vector-index (funcall (nhash.find-new hash) hash key))
1145                   (old-value (%svref vector vector-index)))
1146              (declare (fixnum vector-index))
[2513]1147
[7679]1148              (cond ((eq old-value deleted-hash-key-marker)
1149                     (%set-hash-table-vector-key vector vector-index key)
1150                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
[10731]1151                     (incf (the fixnum (nhash.vector.count vector)))
[7679]1152                     ;; Adjust deleted-count
1153                     (when (> 0 (the fixnum
1154                                  (decf (the fixnum
1155                                          (nhash.vector.deleted-count vector)))))
[10731]1156                       (%normalize-hash-table-count hash)))
1157                    ((eq old-value free-hash-marker)
[7679]1158                     (when (eql 0 (nhash.grow-threshold hash))
1159                       (%unlock-gc-lock)
[10731]1160                       (%grow-hash-table hash)
[7679]1161                       (go AGAIN))
1162                     (%set-hash-table-vector-key vector vector-index key)
1163                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
1164                     (decf (the fixnum (nhash.grow-threshold hash)))
[10731]1165                     (incf (the fixnum (nhash.vector.count vector))))
[7679]1166                    (t
1167                     ;; Key was already there, update value.
1168                     (setf (%svref vector (the fixnum (1+ vector-index))) value)))
1169              (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
1170                    (nhash.vector.cache-key vector) key
1171                    (nhash.vector.cache-value vector) value)))))
1172     (%unlock-gc-lock)
1173     (unlock-hash-table hash nil)))
[2730]1174  value)
[6]1175
1176
1177(defun count-entries (hash)
[10731]1178  (if (hash-lock-free-p hash)
1179    (lock-free-count-entries hash)
1180    (let* ((vector (nhash.vector hash))
1181           (size (uvsize vector))
1182           (idx $nhash.vector_overhead)
1183           (count 0))
1184      (loop
1185        (when (neq (%svref vector idx) free-hash-marker)
1186          (incf count))
1187        (when (>= (setq idx (+ idx 2)) size)
1188          (return count))))))
[6]1189
1190
[2491]1191
1192
1193
1194     
1195
[6]1196(defun grow-hash-table (hash)
[9912]1197  (unless (typep hash 'hash-table)
[6]1198    (setq hash (require-type hash 'hash-table)))
[2491]1199  (%grow-hash-table hash))
[6]1200
[14625]1201(defun %grow-hash-table-in-place-p (hash)
1202  ;; Arbitrarily: if the number of deleted entries is > half
1203  ;; the number of used entries, do an in-place rehash.
1204  (let* ((vec (nhash.vector hash)))
1205    (> (the fixnum (nhash.vector.deleted-count vec))
1206       (the fixnum (ash (the fixnum (nhash.vector.count vec)) -1)))))
1207           
1208
[2491]1209;;; Interrupts are disabled, and the caller has an exclusive
1210;;; lock on the hash table.
[6]1211(defun %grow-hash-table (hash)
1212  (block grow-hash-table
1213    (%normalize-hash-table-count hash)
1214    (let* ((old-vector (nhash.vector hash))
[10731]1215           (old-size (nhash.vector.count old-vector))
1216           (old-total-size (nhash.vector.size old-vector))
[6]1217           (flags 0)
1218           (flags-sans-weak 0)
[10775]1219           (weak-flags nil))
1220      (declare (fixnum old-total-size flags flags-sans-weak))
[14625]1221      (when (%grow-hash-table-in-place-p hash)
[2546]1222        ;; There are enough deleted entries. Rehash to get rid of them
1223        (%rehash hash)
[6]1224        (return-from grow-hash-table))
1225      (multiple-value-bind (size total-size)
1226                           (compute-hash-size 
1227                            old-size (nhash.rehash-size hash) (nhash.rehash-ratio hash))
1228        (unless (eql 0 (nhash.grow-threshold hash))       ; maybe it's done already - shouldnt happen               
1229          (return-from grow-hash-table ))
[3741]1230        (progn
[6]1231          (unwind-protect
[10731]1232            (let ((gc-count (%get-gc-count))
[6]1233                  vector)
1234              (setq flags (nhash.vector.flags old-vector)
1235                    flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask))
[10731]1236                    weak-flags (logand flags $nhash_weak_flags_mask))
1237              (setf (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
[6]1238              (%normalize-hash-table-count hash)
[14625]1239              (when (%grow-hash-table-in-place-p hash)
[10775]1240                (setf (nhash.vector.flags old-vector) flags)
1241                (setq weak-flags nil)
[10731]1242                (return-from grow-hash-table (%rehash hash)))
[6]1243              (setq vector (%cons-nhash-vector total-size 0))
1244              (do* ((index 0 (1+ index))
1245                    (vector-index (index->vector-index 0) (+ vector-index 2)))
1246                   ((>= index old-total-size))
1247                (declare (fixnum index vector-index))
1248               
1249                 (let ((key (%svref old-vector vector-index)))
[10731]1250                   (unless (or (eq key free-hash-marker)
[2546]1251                               (eq key deleted-hash-key-marker))
[6]1252                     (let* ((new-index (%growhash-probe vector hash key))
1253                            (new-vector-index (index->vector-index new-index)))
1254                       (setf (%svref vector new-vector-index) key)
1255                       (setf (%svref vector (the fixnum (1+ new-vector-index)))
[2546]1256                             (%svref old-vector (the fixnum (1+ vector-index))))))))
[3741]1257              (progn
[6]1258               (setf (nhash.vector.finalization-alist vector)
1259                     (nhash.vector.finalization-alist old-vector)
1260                     (nhash.vector.free-alist vector)
1261                     (nhash.vector.free-alist old-vector)
[10731]1262                     (nhash.vector.count vector) old-size
[6]1263                     (nhash.vector.flags vector)
[10775]1264                     (logior (the fixnum weak-flags)
1265                             (the fixnum (nhash.vector.flags vector))))
[6]1266               (setf (nhash.rehash-bits hash) nil
1267                     (nhash.vector hash) vector
1268                     (nhash.vector.hash vector) hash
[10731]1269                     (nhash.vector.cache-key vector) free-hash-marker
[6]1270                     (nhash.vector.cache-value vector) nil
[10731]1271                     (nhash.vector.gc-count vector) gc-count
1272                     (nhash.grow-threshold hash) (- size old-size))
1273               (setq weak-flags nil)       ; tell clean-up form we finished the loop
[3741]1274               ;; If the old vector's in some static heap, zero it
1275               ;; so that less garbage is retained.
[10731]1276               (%init-misc 0 old-vector)))
1277            (when weak-flags
1278              (setf (nhash.vector.flags old-vector)
[10775]1279                    (logior (the fixnum weak-flags)
1280                            (the fixnum (nhash.vector.flags old-vector)))))))))))
[6]1281
1282
1283
[2546]1284(defun general-hash-find (hash key)
1285  (%hash-probe hash key nil))
1286
1287(defun general-hash-find-for-put (hash key)
[10814]1288  (%hash-probe hash key (if (hash-lock-free-p hash) :free :reuse)))
[2546]1289
[2491]1290;;; returns a single value:
[6]1291;;;   index - the index in the vector for key (where it was or where
[2491]1292;;;           to insert if the current key at that index is deleted-hash-key-marker
[10731]1293;;;           or free-hash-marker)
[1954]1294
1295
[7943]1296
[10731]1297(defun %hash-probe (hash key for-put-p)
[2491]1298  (declare (optimize (speed 3) (space 0)))
[6]1299  (multiple-value-bind (hash-code index entries)
[10731]1300                       (compute-hash-code hash key for-put-p)
[2491]1301    (locally (declare (fixnum hash-code index entries))
[6]1302      (let* ((compareF (nhash.compareF hash))
1303             (vector (nhash.vector hash))
1304             (vector-index 0)
[2491]1305             table-key
1306             (first-deleted-index nil))
1307        (declare (fixnum vector-index))
[1624]1308        (macrolet ((return-it (form)
[2491]1309                     `(return-from %hash-probe ,form)))
[6]1310          (macrolet ((test-it (predicate)
1311                       (unless (listp predicate) (setq predicate (list predicate)))
1312                       `(progn
1313                          (setq vector-index (index->vector-index index)
[2491]1314                                table-key (%svref vector vector-index))
[10731]1315                          (cond ((eq table-key free-hash-marker)
1316                                 (return-it (if for-put-p
1317                                              (or first-deleted-index
1318                                                  vector-index)
1319                                              -1)))
[2730]1320                                ((eq table-key deleted-hash-key-marker)
[10814]1321                                 (when (and (eq for-put-p :reuse)
1322                                            (null first-deleted-index))
[2730]1323                                   (setq first-deleted-index vector-index)))
1324                                ((,@predicate key table-key)
1325                                 (return-it vector-index))))))
[6]1326            (macrolet ((do-it (predicate)
1327                         `(progn
1328                            (test-it ,predicate)
1329                            ; First probe failed. Iterate on secondary key
1330                            (let ((initial-index index)
[15504]1331                                  (secondary-hash (%svref secondary-keys (logand 7 hash-code)))
1332                                  (DEBUG-COUNT 0))
[6]1333                              (declare (fixnum secondary-hash initial-index))
1334                              (loop
[15504]1335                                (INCF DEBUG-COUNT)
[6]1336                                (incf index secondary-hash)
1337                                (when (>= index entries)
1338                                  (decf index entries))
1339                                (when (eql index initial-index)
[10731]1340                                  (return-it (if for-put-p
1341                                               (or first-deleted-index
[15504]1342                                                   #+NOT-SO-HELPFUL (error "Bug: no room in table")
1343                                                   (bug (format nil "No room in table after ~s tests, ~%initial ~s index ~s entries ~s for-put-p ~s"
1344                                                                DEBUG-COUNT initial-index index entries for-put-p))
1345                                                   )
[10731]1346                                               -1)))
[6]1347                                (test-it ,predicate))))))
1348              (if (fixnump comparef)
[2491]1349                ;; EQ or EQL hash table
[6]1350                (if (or (eql 0 comparef)
1351                        (immediate-p-macro key)
1352                        (not (need-use-eql key)))
[2491]1353                  ;; EQ hash table or EQL == EQ for KEY
[6]1354                  (do-it eq)
1355                  (do-it eql))
[2491]1356                ;; general compare function
[6]1357                (do-it (funcall comparef))))))))))
1358
[2491]1359(defun eq-hash-find (hash key)
1360  (declare (optimize (speed 3) (safety 0)))
[15264]1361  #+eq-hash-monitor (progn
1362                      (incf eq-hash-find-calls)
1363                      (incf eq-hash-find-probes))
[2491]1364  (let* ((vector (nhash.vector hash))
1365         (hash-code
1366          (let* ((typecode (typecode key)))
1367            (if (eq typecode target::tag-fixnum)
1368              (mixup-hash-code key)
1369              (if (eq typecode target::subtag-instance)
1370                (mixup-hash-code (instance.hash key))
[7908]1371                (if (symbolp key)
1372                  (%hash-symbol key)
[2491]1373                  (mixup-hash-code (strip-tag-to-fixnum key)))))))
[9999]1374         (entries (nhash.vector-size vector))
1375         (vector-index (index->vector-index (hash-mod hash-code entries vector)))
[2491]1376         (table-key (%svref vector vector-index)))
[9999]1377    (declare (fixnum hash-code  entries vector-index))
[10731]1378    (if (eq table-key key)
[2491]1379      vector-index
[10731]1380      (if (eq table-key free-hash-marker)
1381        -1
1382        (let* ((secondary-hash (%svref secondary-keys-*-2
1383                                       (logand 7 hash-code)))
1384               (initial-index vector-index)             
1385               (count (+ entries entries))
1386               (length (+ count $nhash.vector_overhead)))
1387          (declare (fixnum secondary-hash initial-index count length))
1388          (loop
[15264]1389            #+eq-hash-monitor (incf eq-hash-find-probes)
[10731]1390            (incf vector-index secondary-hash)
1391            (when (>= vector-index length)
1392              (decf vector-index count))
1393            (setq table-key (%svref vector vector-index))
1394            (when (= vector-index initial-index)
1395              (return -1))
1396            (if (eq table-key key)
1397              (return vector-index)
1398              (when (eq table-key free-hash-marker)
1399                (return -1)))))))))
[6]1400
[2491]1401;;; As above, but note whether the key is in some way address-based
1402;;; and update the hash-vector's flags word if so.
1403;;; This only needs to be done by PUTHASH, and it only really needs
1404;;; to be done if we're adding a new key.
1405(defun eq-hash-find-for-put (hash key)
1406  (declare (optimize (speed 3) (safety 0)))
[15264]1407  #+eq-hash-monitor (progn
1408                      (incf eq-hash-find-for-put-calls)
1409                      (incf eq-hash-find-for-put-probes))
[2491]1410  (let* ((vector (nhash.vector hash))
1411         (hash-code
1412          (let* ((typecode (typecode key)))
1413            (if (eq typecode target::tag-fixnum)
1414              (mixup-hash-code key)
1415              (if (eq typecode target::subtag-instance)
1416                (mixup-hash-code (instance.hash key))
[7908]1417                (if (symbolp key)
1418                  (%hash-symbol key)
[2491]1419                  (progn
1420                    (unless (immediate-p-macro key)
[10814]1421                      (update-hash-flags hash vector :key))
[2491]1422                    (mixup-hash-code (strip-tag-to-fixnum key))))))))
[9999]1423         (entries (nhash.vector-size vector))
1424         (vector-index (index->vector-index (hash-mod hash-code entries vector)))
[10814]1425         (table-key (%svref vector vector-index))
1426         (reuse (not (hash-lock-free-p hash))))
[9999]1427    (declare (fixnum hash-code vector-index))
[2491]1428    (if (or (eq key table-key)
[10731]1429            (eq table-key free-hash-marker))
[2491]1430      vector-index
1431      (let* ((secondary-hash (%svref secondary-keys-*-2
1432                                     (logand 7 hash-code)))
1433             (initial-index vector-index)             
[10814]1434             (first-deleted-index (and reuse
1435                                       (eq table-key deleted-hash-key-marker)
1436                                       vector-index))
[9999]1437             (count (+ entries entries))
1438             (length (+ count $nhash.vector_overhead)))
1439        (declare (fixnum secondary-hash initial-index count length))
[2491]1440        (loop
[15264]1441          #+eq-hash-monitor (incf eq-hash-find-for-put-probes)
[2491]1442          (incf vector-index secondary-hash)
1443          (when (>= vector-index length)
1444            (decf vector-index count))
1445          (setq table-key (%svref vector vector-index))
1446          (when (= vector-index initial-index)
[10775]1447            (return (or first-deleted-index
[10814]1448                        (error "Bug: no room in table"))))
[2502]1449          (if (eq table-key key)
[2491]1450            (return vector-index)
[10731]1451            (if (eq table-key free-hash-marker)
[2502]1452              (return (or first-deleted-index vector-index))
[10814]1453              (if (and reuse
1454                       (null first-deleted-index)
[2502]1455                       (eq table-key deleted-hash-key-marker))
1456                (setq first-deleted-index vector-index)))))))))
[6]1457
[2491]1458(defun eql-hash-find (hash key)
1459  (declare (optimize (speed 3) (safety 0)))
1460  (if (need-use-eql key)
1461    (let* ((vector (nhash.vector hash))
1462           (hash-code (%%eqlhash-internal key))
[9999]1463           (entries (nhash.vector-size vector))
1464           (vector-index (index->vector-index (hash-mod hash-code entries vector)))
[2491]1465           (table-key (%svref vector vector-index)))
[9999]1466      (declare (fixnum hash-code entries vector-index))
[10731]1467      (if (eql key table-key)
[2491]1468        vector-index
[10731]1469        (if (eq table-key free-hash-marker)
1470          -1
1471          (let* ((secondary-hash (%svref secondary-keys-*-2
1472                                         (logand 7 hash-code)))
1473                 (initial-index vector-index)
1474                 (count (+ entries entries))
1475                 (length (+ count $nhash.vector_overhead)))
1476            (declare (fixnum secondary-hash initial-index count length))
1477            (loop
1478              (incf vector-index secondary-hash)
1479              (when (>= vector-index length)
1480                (decf vector-index count))
1481              (setq table-key (%svref vector vector-index))
1482              (when (= vector-index initial-index)
1483                (return -1))
1484              (if (eql table-key key)
1485                (return vector-index)
1486                (when (eq table-key free-hash-marker)
1487                  (return -1))))))))
[2491]1488    (eq-hash-find hash key)))
[6]1489
[2491]1490(defun eql-hash-find-for-put (hash key)
1491  (declare (optimize (speed 3) (safety 0)))
1492  (if (need-use-eql key)
1493    (let* ((vector (nhash.vector hash))
1494           (hash-code (%%eqlhash-internal key))
[9999]1495           (entries (nhash.vector-size vector))
1496           (vector-index (index->vector-index (hash-mod hash-code entries vector)))
[10814]1497           (table-key (%svref vector vector-index))
1498           (reuse (not (hash-lock-free-p hash))))
[9999]1499      (declare (fixnum hash-code entries vector-index))
[2491]1500      (if (or (eql key table-key)
[10731]1501              (eq table-key free-hash-marker))
[2491]1502        vector-index
1503        (let* ((secondary-hash (%svref secondary-keys-*-2
1504                                       (logand 7 hash-code)))
1505               (initial-index vector-index)
[10814]1506               (first-deleted-index (and reuse
1507                                         (eq table-key deleted-hash-key-marker)
1508                                         vector-index))
[9999]1509               (count (+ entries entries))
1510               (length (+ count $nhash.vector_overhead)))
1511          (declare (fixnum secondary-hash initial-index count length))
[2491]1512          (loop
1513            (incf vector-index secondary-hash)
1514            (when (>= vector-index length)
1515              (decf vector-index count))
1516            (setq table-key (%svref vector vector-index))
1517            (when (= vector-index initial-index)
1518              (return (or first-deleted-index
[10814]1519                          (error "Bug: no room in table"))))
[2502]1520            (if (eql table-key key)
[2491]1521              (return vector-index)
[10731]1522              (if (eq table-key free-hash-marker)
[2502]1523                (return (or first-deleted-index vector-index))
[10814]1524                (if (and reuse
1525                         (null first-deleted-index)
[2502]1526                         (eq table-key deleted-hash-key-marker))
1527                  (setq first-deleted-index vector-index))))))))
[2491]1528    (eq-hash-find-for-put hash key)))
[6]1529
1530(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash))))
1531  (declare (fixnum size))
1532  (let ((rehash-bits (nhash.rehash-bits hash)))
1533    (unless (and rehash-bits
1534                 (>= (uvsize rehash-bits) size))
1535      (return-from %make-rehash-bits
1536        (setf (nhash.rehash-bits hash) (make-array size :element-type 'bit :initial-element 0))))
1537    (fill (the simple-bit-vector rehash-bits) 0)))
1538
[10731]1539;;; Rehash.  Caller should have exclusive access to the hash table
1540;;; and have disabled interrupts.
1541(defun %rehash (hash)
[10814]1542  (when (hash-lock-free-p hash)
1543    (error "How did we get here?"))
[6]1544  (let* ((vector (nhash.vector hash))
[10731]1545         (flags (nhash.vector.flags vector))
[6]1546         (vector-index (- $nhash.vector_overhead 2))
1547         (size (nhash.vector-size vector))
[2491]1548         (rehash-bits (%make-rehash-bits hash size))
[6]1549         (index -1))
[10731]1550    (declare (fixnum size index vector-index))
1551    (setf (nhash.vector.flags vector)
1552          (logand flags $nhash-clear-key-bits-mask))
1553    (setf (nhash.vector.cache-key vector) free-hash-marker
[2538]1554          (nhash.vector.cache-value vector) nil)
[10913]1555    (%set-does-not-need-rehashing vector)
[6]1556    (loop
1557      (when (>= (incf index) size) (return))
1558      (setq vector-index (+ vector-index 2))
1559      (unless (%already-rehashed-p index rehash-bits)
1560        (let* ((key (%svref vector vector-index))
[2491]1561               (deleted (eq key deleted-hash-key-marker)))
[6]1562          (unless
[10731]1563            (when (or deleted (eq key free-hash-marker))
[2491]1564              (if deleted  ; one less deleted entry
[6]1565                (let ((count (1- (nhash.vector.deleted-count vector))))
1566                  (declare (fixnum count))
1567                  (setf (nhash.vector.deleted-count vector) count)
1568                  (if (< count 0)
1569                    (let ((wdc (nhash.vector.weak-deletions-count vector)))
1570                      (setf (nhash.vector.weak-deletions-count vector) 0)
1571                      (incf (nhash.vector.deleted-count vector) wdc)
[10731]1572                      (decf (nhash.vector.count vector) wdc)))
[6]1573                  (incf (nhash.grow-threshold hash))
[2538]1574                  ;; Change deleted to free
[10731]1575                  (setf (%svref vector vector-index) free-hash-marker)))
[6]1576              t)
[2491]1577            (let* ((last-index index)
1578                   (value (%svref vector (the fixnum (1+ vector-index))))
1579                   (first t))
1580                (loop
1581                  (let ((vector (nhash.vector hash))
1582                        (found-index (%rehash-probe rehash-bits hash key)))
1583                    (%set-already-rehashed-p found-index rehash-bits)
1584                    (if (eq last-index found-index)
1585                      (return)
1586                      (let* ((found-vector-index (index->vector-index found-index))
1587                             (newkey (%svref vector found-vector-index))
[4064]1588                             (newvalue (%svref vector (the fixnum (1+ found-vector-index)))))
1589                        (declare (fixnum found-vector-index))
[2491]1590                        (when first ; or (eq last-index index) ?
1591                          (setq first nil)
[10731]1592                          (setf (%svref vector vector-index) free-hash-marker)
1593                          (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker))
[2491]1594                        (%set-hash-table-vector-key vector found-vector-index key)
1595                        (setf (%svref vector (the fixnum (1+ found-vector-index))) value)                       
[10731]1596                        (when (or (eq newkey free-hash-marker)
[2491]1597                                  (setq deleted (eq newkey deleted-hash-key-marker)))
[4064]1598                          (when deleted
[2491]1599                            (let ((count (1- (nhash.vector.deleted-count vector))))
1600                              (declare (fixnum count))
1601                              (setf (nhash.vector.deleted-count vector) count)
1602                              (if (< count 0)
1603                                (let ((wdc (nhash.vector.weak-deletions-count vector)))
1604                                  (setf (nhash.vector.weak-deletions-count vector) 0)
1605                                  (incf (nhash.vector.deleted-count vector) wdc)
[10731]1606                                  (decf (nhash.vector.count vector) wdc)))
[2491]1607                              (incf (nhash.grow-threshold hash))))
1608                          (return))
[4146]1609                        (when (eq key newkey)
[2491]1610                          (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
1611                                  key hash value newvalue index found-index)                       
[10731]1612                          (decf (nhash.vector.count vector))
[2491]1613                          (incf (nhash.grow-threshold hash))
1614                          (return))
1615                        (setq key newkey
1616                              value newvalue
1617                              last-index found-index)))))))))))
[6]1618    t )
1619
[1884]1620;;; Hash to an index that is not set in rehash-bits
[1954]1621 
[10913]1622(defun %rehash-probe (rehash-bits hash key &optional (vector (nhash.vector hash)))
[6]1623  (declare (optimize (speed 3)(safety 0))) 
[10913]1624  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector)
[6]1625    (declare (fixnum hash-code index entries))
1626    (when (null hash-code)(cerror "nuts" "Nuts"))
[10913]1627    (let* ((vector-index (index->vector-index index)))
[6]1628      (if (or (not (%already-rehashed-p index rehash-bits))
1629              (eq key (%svref vector vector-index)))
1630        (return-from %rehash-probe index)
1631        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1632          (declare (fixnum second))
1633          (loop
1634            (setq index (+ index second))
1635            (when (>= index entries)
1636              (setq index (- index entries)))
1637            (when (or (not (%already-rehashed-p index rehash-bits))
1638                      (eq key (%svref vector (index->vector-index index))))
1639              (return-from %rehash-probe index))))))))
1640
[1884]1641;;; Returns one value: the index of the entry in the vector
1642;;; Since we're growing, we don't need to compare and can't find a key that's
1643;;; already there.
[6]1644(defun %growhash-probe (vector hash key)
1645  (declare (optimize (speed 3)(safety 0)))
[2491]1646  (multiple-value-bind (hash-code index entries)(compute-hash-code hash key t vector)
[6]1647    (declare (fixnum hash-code index entries))
[2491]1648    (let* ((vector-index (index->vector-index  index))
1649           (vector-key nil))
[6]1650      (declare (fixnum vector-index))
[10731]1651      (if (or (eq free-hash-marker
[2491]1652                  (setq vector-key (%svref vector vector-index)))
1653              (eq deleted-hash-key-marker vector-key))
[6]1654        (return-from %growhash-probe index)
1655        (let ((second (%svref secondary-keys (%ilogand 7 hash-code))))
1656          (declare (fixnum second))
1657          (loop
1658            (setq index (+ index second))
1659            (when (>= index entries)
1660              (setq index (- index entries)))
[10731]1661            (when (or (eq free-hash-marker
[2491]1662                          (setq vector-key (%svref vector (index->vector-index index))))
1663                      (eq deleted-hash-key-marker vector-key))
[6]1664              (return-from %growhash-probe index))))))))
1665
1666;;;;;;;;;;;;;
1667;;
1668;; Mapping functions are in "ccl:lib;hash"
1669;;
1670
1671
1672
1673;;;;;;;;;;;;;
1674;;
1675;; Hashing functions
1676;; EQ & the EQ part of EQL are done in-line.
1677;;
1678
1679
1680
1681
1682
1683
1684
1685
[2491]1686
[1884]1687;;; so whats so special about bit vectors as opposed to any other vectors of bytes
1688;;; For starters, it's guaranteed that they exist in the implementation; that may
1689;;; not be true of other immediate vector types.
[6]1690(defun bit-vector-hash (bv)
1691  (declare (optimize (speed 3)(safety 0)))
1692  (let ((length (length bv)))
1693    (declare (fixnum length)) ;will this always be true? it's true of all vectors.
1694    (multiple-value-bind (data offset) (array-data-and-offset bv)
1695      (declare (type simple-bit-vector data) (fixnum offset))
1696      (let* ((hash 0)
1697             (limit (+ length offset))
1698             (nbytes (ash (the fixnum (+ length 7)) -3)))
1699        (declare (fixnum hash limit nbytes))
1700        (dotimes (i nbytes (mixup-hash-code hash))
1701          (let* ((w 0))
1702            (declare (fixnum w))
1703            (dotimes (j 8 (setq hash (+ (the fixnum (ash hash -3))  w)))
1704              (setq w (the fixnum
1705                        (logxor
1706                         (the fixnum
1707                           (ash (if (< offset limit) 
1708                                  (the fixnum (sbit data offset))
1709                                  0)
1710                                (the fixnum j)))
1711                         w)))
1712              (incf offset))))))))
1713
1714#|
1715(defun bit-vector-hash (bv)
1716  (declare (optimize (speed 3)(safety 0)))
1717  (let ((length (length bv)))
1718    (declare (fixnum length))
1719    (let* ((all (+ length 15))
1720           (nwds (ash all -4))
1721           (rem (logand all 15))
1722           (hash 0)
1723           (mask (ash (the fixnum (1- (the fixnum (expt 2 rem))))(the fixnum(- 16 rem)))))
1724      (declare (fixnum all nwds rem hash mask))
1725      (multiple-value-bind (data offset)
1726                           (array-data-and-offset bv)
1727        (declare (fixnum offset))
1728        (locally (declare (type (simple-array (unsigned-byte 16) (*)) data))
1729          (dotimes (i nwds)
1730            (setq hash (%i+ hash (aref data (the fixnum (+ i offset))))))
1731          (when (neq 0 mask)           
1732            (setq hash (%i+ hash (%ilogand mask (aref data (the fixnum (+ offset nwds)))))))
1733          (mixup-hash-code hash))))))
1734|#
1735
1736
[1884]1737;;; Same as %%equalhash, but different:
1738;;;  1) Real numbers are hashed as if they were double-floats.  The real components of complex numbers
1739;;;     are hashed as double-floats and XORed together.
1740;;;  2) Characters and strings are hashed in a case-insensitive manner.
1741;;;  3) Hash tables are hashed based on their size and type.
1742;;;  4) Structures and CL array types are hashed based on their content.
[6]1743
1744
[1884]1745;;; check fixnum befor immediate-p. call %%eqlhash
[6]1746
1747(defun %%equalphash (key)
1748  (cond ((or (fixnump key)(short-float-p key))
1749         (%dfloat-hash (float key 1.0d0))) 
1750        ((immediate-p-macro key)
1751         (mixup-hash-code (strip-tag-to-fixnum (if (characterp key)(char-upcase key) key))))
1752        ((bignump key)
1753         (if (<= most-negative-double-float key most-positive-double-float)
1754           (%dfloat-hash (float key 1.0d0))  ; with-stack-double-floats
1755           (%%eqlhash-internal key)))
1756        ((double-float-p key)
1757         (%dfloat-hash key))
1758        ((ratiop key)
1759         (%ilogxor (%%equalphash (numerator key)) (%%equalphash (denominator key))))
1760        ((complexp key)
1761         (%ilogxor (%%equalphash (realpart key)) (%%equalphash (imagpart key))))
1762        ((hash-table-p key)
1763         (equalphash-hash-table key))
[15596]1764        ((typep key 'simple-string)
1765         (%string-hash-folding-case 0 key (length key)))
1766        ((typep key 'string)
1767         (multiple-value-bind (data offset) (array-data-and-offset key)
1768           (%string-hash-folding-case offset data (length key))))
1769        ((pathnamep key)
1770         (%hash-pathname key))
[6]1771        ((or (istructp key)
1772             (structurep key))  ; was (gvectorp key)
1773         (%%equalphash-structure 11 key))
1774        ((or (arrayp key)) ;(uvectorp key)) ;??
1775         (%%equalphash-array 11 key))
1776        ((consp key)
1777         (%%equalphash-aux 11 key))
1778        (t (%%eqlhash key))))
1779
1780
1781(defun equalphash-hash-table (hash-table)
1782  (let ((hash (%%equalhash "HASH-TABLE"))
1783        addressp)
1784    (declare (fixnum hash))
1785    (incf hash (the fixnum (%%eqhash (hash-table-count hash-table))))
1786    (multiple-value-bind (h ap) (%%eqhash (nhash.comparef hash-table))
1787      (declare (fixnum h))
1788      (incf hash h)
1789      (if ap (setq addressp t)))
1790    (multiple-value-bind (h ap) (%%eqhash (nhash.keytransF hash-table))
1791      (declare (fixnum h))
1792      (incf hash h)
1793      (if ap (setq addressp t)))
1794    (values hash addressp)))
1795
1796(defun %%equalphash-structure (limit key)
1797  (let* ((size (uvsize key))
1798         (hash (mixup-hash-code size))
1799         addressp)
1800    (declare (fixnum limit size hash))
1801    (dotimes (i size)
1802      (multiple-value-bind (h ap) (%%equalphash-aux limit (%svref key i))
1803        (declare (fixnum h))
1804        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1805        (if ap (setq addressp t)))
1806      (when (<= (decf limit) 0)
1807        (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
[10156]1808                                  (the fixnum (mixup-hash-code 11)))))
[6]1809        (return)))
1810    (values hash addressp)))
1811
1812(defun %%equalphash-array (limit key)
1813  (multiple-value-bind (array offset) (array-data-and-offset key)
1814    (let* ((rank (array-rank key))
1815           (vectorp (eql rank 1))
1816           (size (if vectorp (length key) (array-total-size key)))
1817           (hash (mixup-hash-code rank))
1818           addressp)
1819      (declare (fixnum size hash limit rank))
1820      (if vectorp
1821        (setq hash
1822              (the fixnum
1823                   (+ (the fixnum (rotate-hash-code hash))
1824                      (the fixnum (mixup-hash-code size)))))
1825        (dotimes (i rank)
1826          (declare (fixnum i))
1827          (setq hash
1828                (the fixnum 
1829                     (+ (the fixnum (rotate-hash-code hash))
1830                        (the fixnum
1831                             (mixup-hash-code (array-dimension key i))))))))     
1832      (dotimes (i size)
1833        (declare (fixnum i))
1834        (multiple-value-bind (h ap) (%%equalphash-aux limit (uvref array offset))
1835          (declare (fixnum h))
1836          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash)) h)))
1837          (if ap (setq addressp t)))
1838        (when (<= (decf limit) 0)
1839          (setq hash (the fixnum (+ (the fixnum (rotate-hash-code hash))
[10156]1840                                    (the fixnum (mixup-hash-code 11)))))
[6]1841          (return))
1842        (incf offset))
1843      (values hash addressp))))
1844
1845(defun %%equalphash-aux (limit key)
1846  (if (<= limit 0) 
[10156]1847    (mixup-hash-code 11)
1848    (if (null key) (mixup-hash-code 17)
[6]1849        (cond ((consp key)
1850               (let ((hash 0)
1851                     address-p)
1852                 (do ((l limit (1- l)))
1853                     ((eq l 0)(values hash address-p))
1854                   (multiple-value-bind (ahash ap)
1855                                        (%%equalphash-aux l (if (consp key)(car key) key))
1856                     (setq hash (mixup-hash-code (logxor ahash hash)))
1857                     (if ap (setq address-p t)))
1858                   (when (not (consp key))
1859                     (return (values hash address-p)))
1860                   (setq key (cdr key)))))
[9912]1861              ((typep key 'hash-table)
[6]1862               (equalphash-hash-table key))
1863              ; what are the dudes called that contain bits? they are uvectors but not gvectors?
1864              ; ivectors.
1865              ((or (istructp key)
1866                   (structurep key))    ;was (gvectorp key)
1867               (%%equalphash-structure limit key))
1868              ((or (arrayp key))  ; (uvectorp key))
1869               (%%equalphash-array limit key))
1870              (t (%%equalphash key))))))
1871
1872(defun alist-hash-table (alist &rest hash-table-args)
1873  (declare (dynamic-extent hash-table-args))
1874  (if (typep alist 'hash-table)
1875    alist
1876    (let ((hash-table (apply #'make-hash-table hash-table-args)))
1877      (dolist (cons alist) (puthash (car cons) hash-table (cdr cons)))
1878      hash-table)))
1879
1880(defun %hash-table-equalp (x y)
[1884]1881  ;; X and Y are both hash tables
[900]1882  (and (eq (hash-table-test x)
1883           (hash-table-test y))
1884       (eql (hash-table-count x)
1885            (hash-table-count y))
1886       (block nil
1887         (let* ((default (cons nil nil))
1888                (foo #'(lambda (k v)
1889                         (let ((y-value (gethash k y default)))
1890                           (unless (and (neq default y-value)
1891                                        (equalp v y-value))
1892                             (return nil))))))
1893           (declare (dynamic-extent foo default))
1894           (maphash foo x))
1895         t)))
[6]1896
1897(defun sxhash (s-expr)
1898  "Computes a hash code for S-EXPR and returns it as an integer."
[10156]1899  (logand (sxhash-aux s-expr 7 17) target::target-most-positive-fixnum))
[6]1900
1901(defun sxhash-aux (expr counter key)
1902  (declare (fixnum counter))
1903  (if (> counter 0)
1904    (typecase expr
[1901]1905      ((or string bit-vector number character)  (+ key (%%equalhash expr)))
[10871]1906      (logical-pathname
[6]1907       (dotimes (i (uvsize expr) key)
1908         (declare (fixnum i))
[1901]1909         (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key)))))
[10871]1910      (pathname
1911       ;; Don't consider %PHYSICAL-PATHNAME-VERSION to be significant
1912       (dotimes (i (uvsize expr) key)
1913         (declare (fixnum i))
1914         (unless (= i %physical-pathname-version)
1915           (setq key (+ key (sxhash-aux (%svref expr i) (1- counter) key))))))
[1901]1916      (symbol (+ key (%%equalhash (symbol-name expr))))
[6]1917      (cons (sxhash-aux
1918             (cdr expr)
1919             (the fixnum (1- counter))             
[1901]1920             (+ key (sxhash-aux (car expr) (the fixnum (1- counter)) key))))
1921      (t (+  key (%%equalhash (symbol-name (%type-of expr))))))
[6]1922    key))
1923
1924
1925
[10156]1926#+(or ppc32-target x8632-target)
[6]1927(defun immediate-p (thing)
1928  (let* ((tag (lisptag thing)))
1929    (declare (fixnum tag))
[10156]1930    (or (= tag target::tag-fixnum)
1931        (= tag target::tag-imm))))
[6]1932
[1596]1933#+ppc64-target
1934(defun immediate-p (thing)
1935  (let* ((tag (lisptag thing)))
1936    (declare (fixnum tag))
1937    (or (= tag ppc64::tag-fixnum)
1938        (= (logand tag ppc64::lowtagmask) ppc64::lowtag-imm))))
1939
[3567]1940#+x8664-target
1941(defun immediate-p (thing)
1942  (let* ((tag (lisptag thing)))
1943    (declare (type (unsigned-byte 3) tag))
1944    (logbitp tag
1945             (logior (ash 1 x8664::tag-fixnum)
1946                     (ash 1 x8664::tag-imm-0)
1947                     (ash 1 x8664::tag-imm-1)))))
[6]1948
[2491]1949
[3567]1950
[6]1951(defun %cons-nhash-vector (size &optional (flags 0))
1952  (declare (fixnum size))
[10731]1953  (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector free-hash-marker)))
1954    (%init-nhash-vector vector flags)
1955    vector))
1956
1957(defun %init-nhash-vector (vector flags)
1958  (let ((size (vector-index->index (uvsize vector))))
1959    (declare (fixnum size))
[6]1960    (setf (nhash.vector.link vector) 0
1961          (nhash.vector.flags vector) flags
[10731]1962          (nhash.vector.gc-count vector) (%get-gc-count)
[6]1963          (nhash.vector.free-alist vector) nil
1964          (nhash.vector.finalization-alist vector) nil
1965          (nhash.vector.weak-deletions-count vector) 0
1966          (nhash.vector.hash vector) nil
1967          (nhash.vector.deleted-count vector) 0
[10731]1968          (nhash.vector.count vector) 0
1969          (nhash.vector.cache-key vector) free-hash-marker
[6]1970          (nhash.vector.cache-value vector) nil
[9999]1971          (nhash.vector.cache-idx vector) nil
1972          (nhash.vector.size vector) size
[10731]1973          (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size))))
[6]1974
[7624]1975(defun assert-hash-table-readonly (hash)
[9912]1976  (unless (typep hash 'hash-table)
[7624]1977    (report-bad-arg hash 'hash-table))
1978  (or (nhash.read-only hash)
[9877]1979      (when (nhash.owner hash)
1980        (error "Hash~table ~s is thread-private and can't be made read-only for that reason" hash))
[10978]1981      (if (hash-lock-free-p hash)
1982        (setf (nhash.read-only hash) t)
1983        (with-lock-context
1984          (without-interrupts
1985           (write-lock-hash-table hash)
1986           (let* ((flags (nhash.vector.flags (nhash.vector hash))))
1987             (declare (fixnum flags))
1988             (when (or (logbitp $nhash_track_keys_bit flags)
1989                       (logbitp $nhash_component_address_bit flags))
1990               (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
1991               (unlock-hash-table hash nil)
1992               (return-from assert-hash-table-readonly nil))
1993             (setf (nhash.read-only hash) t)
[7679]1994             (unlock-hash-table hash nil)
[10978]1995             t))))))
[7624]1996
1997;; This is dangerous, if multiple threads are accessing a read-only
1998;; hash table. Use it responsibly.
1999(defun assert-hash-table-writeable (hash)
[9912]2000  (unless (typep hash 'hash-table)
[7624]2001    (report-bad-arg hash 'hash-table))
2002  (when (nhash.read-only hash)
2003    (setf (nhash.read-only hash) nil)
2004    t))
2005
2006(defun readonly-hash-table-p (hash)
[9912]2007  (unless (typep hash 'hash-table)
[7624]2008    (report-bad-arg hash 'hash-table))
2009  (nhash.read-only hash))
[7679]2010
[7901]2011(defun hash-table-owner (hash)
[9912]2012  (unless (typep hash 'hash-table)
[7901]2013    (report-bad-arg hash 'hash-table))
2014  (nhash.owner hash))
2015
2016(defun claim-hash-table (hash &optional steal)
[9912]2017  (unless (typep hash 'hash-table)
[7901]2018    (report-bad-arg hash 'hash-table))
2019  (let* ((owner (nhash.owner hash)))
2020    (if owner
2021      (or (eq owner *current-process*)
2022          (when steal
2023            (setf (nhash.owner hash) *current-process*)))
2024      (progn
[10731]2025        (unless (hash-lock-free-p hash)
2026          (write-lock-hash-table hash)
2027          (setf (nhash.exclusion-lock hash) nil))
2028        (setf (nhash.owner hash) *current-process*)
[7901]2029        t))))
2030
2031 
[15504]2032;; ** TODO: for lock-free hash tables, maybe we don't need to copy,
[10731]2033;; we could map over the actual hash table vector, because it's
2034;; always valid.
2035(defun lock-free-enumerate-hash-keys-and-values (hash keys values)
2036  (do* ((in (nhash.vector hash))
2037        (in-idx $nhash.vector_overhead (+ in-idx 2))
2038        (insize (uvsize in))
2039        (outsize (length (or keys values)))
2040        (out-idx 0))
2041       ((or (= in-idx insize)
2042            (= out-idx outsize))
2043        out-idx)
2044    (declare (fixnum in-idx insize out-idx outsize))
2045    (let* ((key (%svref in in-idx)))
2046      (unless (eq key free-hash-marker)
2047        (let ((val (%svref in (%i+ in-idx 1))))
2048          (when (eq val rehashing-value-marker)
2049            ;; This table is being rehashed.  Wait to finish and try again
2050            (lock-free-rehash hash)
2051            (return-from lock-free-enumerate-hash-keys-and-values
2052                         (lock-free-enumerate-hash-keys-and-values hash keys values)))
[15504]2053          (unless (or (eq key deleted-hash-key-marker)
2054                      (eq val deleted-hash-value-marker)
2055                      (eq val free-hash-marker))
[10731]2056            (when keys (setf (%svref keys out-idx) key))
2057            (when values (setf (%svref values out-idx) val))
2058            (incf out-idx)))))))
[7943]2059
2060(defun enumerate-hash-keys-and-values (hash keys values)
[9912]2061  (unless (typep hash 'hash-table)
[7943]2062    (report-bad-arg hash 'hash-table))
[10731]2063  (when (hash-lock-free-p hash)
2064    (return-from enumerate-hash-keys-and-values
2065                 (lock-free-enumerate-hash-keys-and-values hash keys values)))
[7943]2066  (with-lock-context
[10775]2067    (without-interrupts
2068     (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
2069       (do* ((in (nhash.vector hash))
2070             (in-idx $nhash.vector_overhead (+ in-idx 2))
2071             (insize (uvsize in))
2072             (outsize (length (or keys values)))
2073             (out-idx 0))
2074           ((or (= in-idx insize)
2075                (= out-idx outsize))
2076              (unlock-hash-table hash readonly)
2077              out-idx)
2078         (declare (fixnum in-idx insize out-idx outsize))
2079         (let* ((key (%svref in in-idx)))
2080           (unless (or (eq key free-hash-marker)
2081                       (eq key deleted-hash-key-marker))
2082             (when keys
2083               (setf (%svref keys out-idx) key))
2084             (when values
2085               (setf (%svref values out-idx) (%svref in (%i+ in-idx 1))))
2086             (incf out-idx))))))))
2087
[10731]2088(defun enumerate-hash-keys (hash out)
2089  (enumerate-hash-keys-and-values hash out nil))
Note: See TracBrowser for help on using the repository browser.