Changeset 10731


Ignore:
Timestamp:
Sep 14, 2008, 6:48:21 PM (11 years ago)
Author:
gz
Message:

Implemented "nearly-lock-free" hash tables. They are created by
calling MAKE-HASH-TABLE with :LOCK-FREE t, or by setting
CCL::*LOCK-FREE-HASH-TABLE-DEFAULT* to T. There is some documentation
in a big comment in l0-hash.lisp, but basically the idea is to try to
avoid any locking in GETHASH, getting the performance equivalent to
readonly tables, at the cost of rehashing becoming more
expensive. PUTHASH should be roughly equivalent (it avoids getting a
lock, but does sync memory a few times).

So far, I've only tested them on linuxx8664, by building ccl multiple
times with *lock-free-hash-table-default* = T on, so no real
multi-threaded testing. I will now switch to the mac and try to
build and use the IDE that way.

Other changes: moved some slots from the hash table to the hash table
vector so they can all be swapped in/out all at once. Made nhash.find
return -1 when not found, also to avoid some synchronization issues.
%needs-rehashing-p now takes a hash table vector, not the hash table.
Got rid of a bunch of unused slots and constants in hash tables.

Incremented fasl version in case there are any fasdumped hash tables out there.

Location:
trunk/source
Files:
24 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/compiler/PPC/ppc-arch.lisp

    r8417 r10731  
    483483         (defppcsubprim .SPpoweropen-ffcall-return-registers)
    484484         (defppcsubprim .SPnmkunwind)
    485          (defppcsubprim .SPunused-6)
     485         (defppcsubprim .SPset-hash-key-conditional)
    486486         (defppcsubprim .SPunbind-interrupt-level)
    487487         (defppcsubprim .SPunbind)
  • trunk/source/compiler/X86/X8632/x8632-arch.lisp

    r10677 r10731  
    10191019         (defx8632subprim .SPffcall-return-registers)
    10201020         (defx8632subprim .SPaset1)
    1021          (defx8632subprim .SPunused-6)
     1021         (defx8632subprim .SPset-hash-key-conditional)
    10221022         (defx8632subprim .SPunbind-interrupt-level)
    10231023         (defx8632subprim .SPunbind)
  • trunk/source/compiler/X86/X8664/x8664-arch.lisp

    r10677 r10731  
    11221122         (defx8664subprim .SPffcall-return-registers)
    11231123         (defx8664subprim .SPunused-5)
    1124          (defx8664subprim .SPunused-6)
     1124         (defx8664subprim .SPset-hash-key-conditional)
    11251125         (defx8664subprim .SPunbind-interrupt-level)
    11261126         (defx8664subprim .SPunbind)
  • trunk/source/level-0/PPC/ppc-hash.lisp

    r10028 r10731  
    156156  (ba .SPset-hash-key))
    157157
     158(defppclapfunction %set-hash-table-vector-key-conditional ((offset 0) (vector arg_x) (old arg_y) (new arg_z))
     159  (ba .SPset-hash-key-conditional))
     160
    158161;;; Strip the tag bits to turn x into a fixnum
    159162(defppclapfunction strip-tag-to-fixnum ((x arg_z))
  • trunk/source/level-0/X86/X8632/x8632-hash.lisp

    r10272 r10731  
    100100  (jmp-subprim .SPset-hash-key))
    101101
     102;;; This needs to be done out-of-line, to handle EGC memoization.
     103(defx8632lapfunction %set-hash-table-vector-key-conditional ((offset 8)
     104                                                             (vector 4)
     105                                                             #|(ra 0)|#
     106                                                             (old arg_y)
     107                                                             (new arg_z))
     108  (movl (@ offset (% esp)) (% temp0))
     109  (movl (@ vector (% esp)) (% temp1))
     110  (save-simple-frame)
     111  (call-subprim .SPset-hash-key-conditional)
     112  (restore-simple-frame)
     113  (single-value-return 4))
     114
     115
    102116;;; Strip the tag bits to turn x into a fixnum
    103117(defx8632lapfunction strip-tag-to-fixnum ((x arg_z))
  • trunk/source/level-0/X86/x86-hash.lisp

    r10145 r10731  
    115115  (jmp-subprim .SPset-hash-key))
    116116
     117;;; This needs to be done out-of-line, to handle EGC memoization.
     118(defx86lapfunction %set-hash-table-vector-key-conditional ((offset 8) #|(ra 0)|# (vector arg_x) (old arg_y) (new arg_z))
     119  (movq (@ offset (% rsp)) (% temp0))
     120  (save-simple-frame)
     121  (call-subprim .SPset-hash-key-conditional)
     122  (restore-simple-frame)
     123  (single-value-return 3))
     124
    117125;;; Strip the tag bits to turn x into a fixnum
    118126(defx86lapfunction strip-tag-to-fixnum ((x arg_z))
  • trunk/source/level-0/l0-hash.lisp

    r10156 r10731  
    1919;;;;;;;;;;;;;
    2020;;
    21 ;; hash.lisp
    22 ;; New hash table implementation
    23 
    24 ;;;;;;;;;;;;;
    25 ;;
    26 ;; Things I didn't do
    27 ;;
    28 ;; Save the 32-bit hash code along with the key so that growing the table can
    29 ;; avoid calling the hashing function (at least until a GC happens during growing).
    30 ;;
    31 ;; Maybe use Knuth's better method for hashing:
    32 ;; find two primes N-2, N.  N is the table size.
    33 ;; First probe is at primary = (mod (funcall (nhash.keytransF h) key) N)
    34 ;; Secondary probes are spaced by (mod (funcall (nhash.keytransF h) key) N-2)
    35 ;; This does a bit better scrambling of the secondary probes, but costs another divide.
    36 ;;
    37 ;; Rethink how finalization is reported to the user.  Maybe have a finalization function which
    38 ;; is called with the hash table and the deleted key & value.
    39 
    40 
    41 ;;;;;;;;;;;;;
    42 ;;
    43 ;; Documentation
    44 ;;
    45 ;; MAKE-HASH-TABLE is extended to accept a :HASH-FUNCTION keyword arg which
    46 ;; defaults for the 4 Common Lisp defined :TEST's.  Also, any fbound symbol can
    47 ;; be used for the :TEST argument.  The HASH-FUNCTION is a function of one
    48 ;; argument, the key, which returns two values:
    49 ;;
    50 ;; 1) HASH-CODE
    51 ;; 2) ADDRESSP
    52 ;;
    53 ;; The HASH-CODE can be any object.  If it is a relocateable object (not a
    54 ;; fixnum, short float, or immediate) then ADDRESSP will default to :KEY
    55 ;; and it is an error if NIL is returned for ADDRESSP.
    56 ;;
    57 ;; If ADDRESSP is NIL, the hashing code assumes that no addresses were used
    58 ;; in computing the HASH-CODE.  If ADDRESSP is :KEY (which is the default
    59 ;; if the hash function returns only one value and it is relocateable) then
    60 ;; the hashing code assumes that only the KEY's address was used to compute
    61 ;; the HASH-CODE.  Otherwise, it is assumed that the address of a
    62 ;; component of the key was used to compute the HASH-CODE.
    63 ;;
    64 ;;
    65 ;;
    66 ;; Some (proposed) functions for using in user hashing functions:
    67 ;;
    68 ;; (HASH-CODE object)
    69 ;;
    70 ;; returns two values:
    71 ;;
    72 ;; 1) HASH-CODE
    73 ;; 2) ADDRESSP
    74 ;;
    75 ;; HASH-CODE is the object transformed into a fixnum by changing its tag
    76 ;; bits to a fixnum's tag.  ADDRESSP is true if the object was
    77 ;; relocateable.
    78 ;;
    79 ;;
    80 ;; (FIXNUM-ADD o1 o2)
    81 ;; Combines two objects additively and returns a fixnum.
    82 ;; If the two objects are fixnums, will be the same as (+ o1 o2) except
    83 ;; that the result can not be a bignum.
    84 ;;
    85 ;; (FIXNUM-MULTIPLY o1 o2)
    86 ;; Combines two objects multiplicatively and returns a fixnum.
    87 ;;
    88 ;; (FIXNUM-FLOOR dividend &optional divisor)
    89 ;; Same as Common Lisp's FLOOR function, but converts the objects into
    90 ;; fixnums before doing the divide and returns two fixnums: quotient &
    91 ;; remainder.
    92 ;;
    93 ;;;;;;;;;;;;;
    94 ;;
    95 ;; Implementation details.
    96 ;;
    97 ;; Hash table vectors have a header that the garbage collector knows about
    98 ;; followed by alternating keys and values.  Empty or deleted slots are
    99 ;; denoted by a key of $undefined.  Empty slots have a value of $undefined.
    100 ;; Deleted slots have a value of NIL.
    101 ;;
    102 ;;
     21;; See hash.lisp for documentation
    10322;; Five bits in the nhash.vector.flags fixnum interact with the garbage
    10423;; collector.  This description uses the symbols that represent bit numbers
     
    14867  (require "HASHENV" "ccl:xdump;hashenv")
    14968  (require :number-case-macro)
    150   (define-symbol-macro free-hash-key-marker (%unbound-marker))
    15169  (define-symbol-macro deleted-hash-key-marker (%slot-unbound-marker))
     70  (define-symbol-macro free-hash-marker (%unbound-marker))
     71  (define-symbol-macro rehashing-value-marker (%slot-unbound-marker))
    15272  (declaim (inline nhash.vector-size))
    15373  (declaim (inline mixup-hash-code))
     
    16181  (declaim (inline eq-hash-find eq-hash-find-for-put))
    16282  (declaim (inline read-lock-hash-table write-lock-hash-table  unlock-hash-table))
    163   (declaim (inline %hash-symbol)))
    164 
     83  (declaim (inline %hash-symbol))
     84  (declaim (inline hash-mod))
     85  (declaim (inline set-hash-key-conditional set-hash-value-conditional))
     86  (declaim (inline hash-lock-free-p lock-free-gethash)))
     87
     88
     89
     90(defun %cons-hash-table (keytrans-function compare-function vector
     91                         threshold rehash-ratio rehash-size find find-new owner &optional lock-free-p)
     92  (%istruct
     93   'HASH-TABLE                          ; type
     94   keytrans-function                    ; nhash.keytransF
     95   compare-function                     ; nhash.compareF
     96   nil                                  ; nhash.rehash-bits
     97   vector                               ; nhash.vector
     98   (if lock-free-p $nhash.lock-free 0)  ; nhash.lock
     99   owner                                ; nhash.owner
     100   threshold                            ; nhash.grow-threshold
     101   rehash-ratio                         ; nhash.rehash-ratio
     102   rehash-size                          ; nhash.rehash-size
     103   0                                    ; nhash.puthash-count
     104   (if lock-free-p
     105     (make-lock)
     106     (unless owner (make-read-write-lock))) ; nhash.exclusion-lock
     107   find                                 ; nhash.find
     108   find-new                             ; nhash.find-new
     109   nil                                  ; nhash.read-only
     110   ))
     111
     112(defun nhash.vector-size (vector)
     113  (nhash.vector.size vector))
     114
     115(defun hash-mod (hash entries vector)
     116  (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector)))
     117
     118;; For lock-free hash tables
     119(defun set-hash-key-conditional (index vector old new)
     120  (%set-hash-table-vector-key-conditional (%i+ target::misc-data-offset
     121                                               (ash (the fixnum index) target::word-shift))
     122                                          vector
     123                                          old
     124                                          new))
     125
     126(defun set-hash-value-conditional (index vector old new)
     127  (store-gvector-conditional (%i+ index 1) vector old new))
     128
     129(defun hash-lock-free-p (hash)
     130  (logtest $nhash.lock-free (the fixnum (nhash.lock hash))))
     131 
     132;;; Is KEY something which can be EQL to something it's not EQ to ?
     133;;; (e.g., is it a number or macptr ?)
     134;;; This can be more general than necessary but shouldn't be less so.
     135(defun need-use-eql (key)
     136  (let* ((typecode (typecode key)))
     137    (declare (fixnum typecode))
     138    (or (= typecode target::subtag-macptr)
     139        #+(or ppc32-target x8632-target)
     140        (and (>= typecode target::min-numeric-subtag)
     141             (<= typecode target::max-numeric-subtag))
     142        #+64-bit-target
     143        (or (= typecode target::subtag-bignum)
     144            (= typecode target::subtag-double-float)
     145            (= typecode target::subtag-ratio)
     146            (= typecode target::subtag-complex)))))
     147
     148;;; Don't rehash at all, unless some key is address-based (directly or
     149;;; indirectly.)
     150(defun %needs-rehashing-p (vector)
     151  (let* ((flags (nhash.vector.flags vector)))
     152    (declare (fixnum flags))
     153    (if (logbitp $nhash_track_keys_bit flags)
     154      ;; GC is tracking key movement
     155      (logbitp $nhash_key_moved_bit flags)
     156      ;; GC is not tracking key movement
     157      (if (logbitp $nhash_component_address_bit flags)
     158         (not (eql (the fixnum (%get-gc-count)) (the fixnum (nhash.vector.gc-count vector))))))))
     159
     160(defun %set-does-not-need-rehashing (hash)
     161  (let* ((vector (nhash.vector hash))
     162         (flags (nhash.vector.flags vector)))
     163    (declare (fixnum flags))
     164    (setf (nhash.vector.gc-count vector) (%get-gc-count))
     165    (when (logbitp $nhash_track_keys_bit flags)
     166      (setf (nhash.vector.flags vector)
     167            (logand (lognot (ash 1 $nhash_key_moved_bit)) flags)))))
     168
     169
     170;;; Tempting though it may be to remove this, a hash table loaded from
     171;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM
     172;;; for hash tables needs to be able to call this or something similar.
     173(defun %set-needs-rehashing (hash)
     174  (let* ((vector (nhash.vector hash))
     175         (flags (nhash.vector.flags vector)))
     176    (declare (fixnum flags))
     177    (setf (nhash.vector.gc-count vector) (the fixnum (1- (the fixnum (%get-gc-count)))))
     178    (when (logbitp $nhash_track_keys_bit flags)
     179      (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags)))))
     180
     181#+32-bit-target
     182(defun mixup-hash-code (fixnum)
     183  (declare (fixnum fixnum))
     184  (the fixnum
     185    (+ fixnum
     186       (the fixnum (%ilsl (- 32 8)
     187                          (logand (1- (ash 1 (- 8 3))) fixnum))))))
     188
     189#+64-bit-target
     190(defun mixup-hash-code (fixnum)
     191  (declare (fixnum fixnum))
     192  (the fixnum
     193    (+ fixnum
     194       (the fixnum (%ilsl 50
     195                          (logand (1- (ash 1 (- 8 3))) fixnum))))))
     196
     197
     198(defun rotate-hash-code (fixnum)
     199  (declare (fixnum fixnum))
     200  (let* ((low-3 (logand 7 fixnum))
     201         (but-low-3 (%ilsr 3 fixnum))
     202         (low-3*64K (%ilsl 13 low-3))
     203         (low-3-in-high-3 (%ilsl (- 32 3 3) low-3)))
     204    (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3))
     205    (the fixnum (+ low-3-in-high-3
     206                   (the fixnum (logxor low-3*64K but-low-3))))))
     207
     208
     209
     210
     211(defconstant $nhash-track-keys-mask
     212  #.(- (ash 1 $nhash_track_keys_bit)))
     213
     214(defconstant $nhash-clear-key-bits-mask #xfffff)
    165215
    166216
     
    181231    +nil-hash+))
    182232             
    183 
    184 (defun %cons-hash-table (rehash-function keytrans-function compare-function vector
    185                                          threshold rehash-ratio rehash-size address-based find find-new owner)
    186   (%istruct
    187    'HASH-TABLE                          ; type
    188    rehash-function                      ; nhash.rehashF
    189    keytrans-function                    ; nhash.keytransF
    190    compare-function                     ; nhash.compareF
    191    nil                                  ; nhash.rehash-bits
    192    vector                               ; nhash.vector
    193    0                                    ; nhash.lock
    194    0                                    ; nhash.count
    195    owner                                ; nhash.owner
    196    (get-fwdnum)                         ; nhash.fixnum
    197    (gc-count)                           ; nhash.gc-count
    198    threshold                            ; nhash.grow-threshold
    199    rehash-ratio                         ; nhash.rehash-ratio
    200    rehash-size                          ; nhash.rehash-size
    201    0                                    ; nhash.puthash-count
    202    (unless owner
    203      (make-read-write-lock))               ; nhash.exclusion-lock
    204    nil ;;(make-lock)                            ; nhash.rehash-lock
    205    nil                                  ; nhash.iterator
    206    address-based                        ; nhash.address-based
    207    find                                 ; nhash.find
    208    find-new                             ; nhash.find-new
    209    nil                                  ; hhash.read-only
    210    ))
    211 
    212 
    213  
    214 (defun nhash.vector-size (vector)
    215   (nhash.vector.size vector))
    216 
    217 (eval-when (:compile-toplevel :execute) (declaim (inline hash-mod)))
    218 (defun hash-mod (hash entries vector)
    219   (fast-mod-3 hash entries (nhash.vector.size-reciprocal vector)))
    220 
    221 ;;; Is KEY something which can be EQL to something it's not EQ to ?
    222 ;;; (e.g., is it a number or macptr ?)
    223 ;;; This can be more general than necessary but shouldn't be less so.
    224 (defun need-use-eql (key)
    225   (let* ((typecode (typecode key)))
    226     (declare (fixnum typecode))
    227     (or (= typecode target::subtag-macptr)
    228         #+(or ppc32-target x8632-target)
    229         (and (>= typecode target::min-numeric-subtag)
    230              (<= typecode target::max-numeric-subtag))
    231         #+64-bit-target
    232         (or (= typecode target::subtag-bignum)
    233             (= typecode target::subtag-double-float)
    234             (= typecode target::subtag-ratio)
    235             (= typecode target::subtag-complex)))))
    236 
    237 ;;; Don't rehash at all, unless some key is address-based (directly or
    238 ;;; indirectly.)
    239 (defun %needs-rehashing-p (hash)
    240   (let ((flags (nhash.vector.flags (nhash.vector hash))))
    241     (declare (fixnum flags))
    242     (if (logbitp $nhash_track_keys_bit flags)
    243       ;; GC is tracking key movement
    244       (logbitp $nhash_key_moved_bit flags)
    245       ;; GC is not tracking key movement
    246       (if (logbitp $nhash_component_address_bit flags)
    247         (not (eql (the fixnum (gc-count)) (the fixnum (nhash.gc-count hash))))))))
    248 
    249 (defun %set-does-not-need-rehashing (hash)
    250   (get-fwdnum hash)
    251   (gc-count hash)
    252   (let* ((vector (nhash.vector hash))
    253          (flags (nhash.vector.flags vector)))
    254     (declare (fixnum flags))
    255     (when (logbitp $nhash_track_keys_bit flags)
    256       (setf (nhash.vector.flags vector)
    257             (logand (lognot (ash 1 $nhash_key_moved_bit)) flags)))))
    258 
    259 
    260 ;;; Tempting though it may be to remove this, a hash table loaded from
    261 ;;; a fasl file likely needs to be rehashed, and the MAKE-LOAD-FORM
    262 ;;; for hash tables needs to be able to call this or something similar.
    263 (defun %set-needs-rehashing (hash)
    264   (setf (nhash.fixnum hash)   (the fixnum (1- (the fixnum (get-fwdnum))))
    265         (nhash.gc-count hash) (the fixnum (1- (the fixnum (gc-count)))))
    266   (let* ((vector (nhash.vector hash))
    267          (flags (nhash.vector.flags vector)))
    268     (declare (fixnum flags))
    269     (when (logbitp $nhash_track_keys_bit flags)
    270       (setf (nhash.vector.flags vector) (logior (ash 1 $nhash_key_moved_bit) flags)))))
    271 
    272 #+32-bit-target
    273 (defun mixup-hash-code (fixnum)
    274   (declare (fixnum fixnum))
    275   (the fixnum
    276     (+ fixnum
    277        (the fixnum (%ilsl (- 32 8)
    278                           (logand (1- (ash 1 (- 8 3))) fixnum))))))
    279 
    280 #+64-bit-target
    281 (defun mixup-hash-code (fixnum)
    282   (declare (fixnum fixnum))
    283   (the fixnum
    284     (+ fixnum
    285        (the fixnum (%ilsl 50
    286                           (logand (1- (ash 1 (- 8 3))) fixnum))))))
    287 
    288 
    289 (defun rotate-hash-code (fixnum)
    290   (declare (fixnum fixnum))
    291   (let* ((low-3 (logand 7 fixnum))
    292          (but-low-3 (%ilsr 3 fixnum))
    293          (low-3*64K (%ilsl 13 low-3))
    294          (low-3-in-high-3 (%ilsl (- 32 3 3) low-3)))
    295     (declare (fixnum low-3 but-low-3 low-3*64K low-3-in-high-3))
    296     (the fixnum (+ low-3-in-high-3
    297                    (the fixnum (logxor low-3*64K but-low-3))))))
    298 
    299 
    300 
    301 
    302 (defconstant $nhash-track-keys-mask
    303   #.(- (ash 1 $nhash_track_keys_bit)))
    304 
    305 (defconstant $nhash-clear-key-bits-mask #xfffff)
    306 
    307 
    308233;;; Hash on address, or at least on some persistent, immutable
    309234;;; attribute of the key.  If all keys are fixnums or immediates (or if
     
    421346    (when addressp
    422347      (when update-hash-flags
    423         (let ((flags (nhash.vector.flags vector)))
    424           (declare (fixnum flags))
    425           (if (eq :key addressp)
    426             ;; hash code depended on key's address
    427             (unless (logbitp $nhash_component_address_bit flags)
    428               (when (not (logbitp $nhash_track_keys_bit flags))
    429                 (setq flags (bitclr $nhash_key_moved_bit flags)))
    430               (setq flags (logior $nhash-track-keys-mask flags)))
    431             ;; hash code depended on component address
    432             (progn
    433               (setq flags (logand (lognot $nhash-track-keys-mask) flags))
    434               (setq flags (bitset $nhash_component_address_bit flags))))
    435           (setf (nhash.vector.flags vector) flags))))
     348        (flet ((new-flags (flags addressp)
     349                 (declare (fixnum flags))
     350                 (if (eq :key addressp)
     351                   ;; hash code depended on key's address
     352                   (if (logbitp $nhash_component_address_bit flags)
     353                     flags
     354                     (logior $nhash-track-keys-mask
     355                             (if (logbitp $nhash_track_keys_bit flags)
     356                               flags
     357                               (bitclr $nhash_key_moved_bit flags))))
     358                   ;; hash code depended on component address
     359                   (bitset $nhash_component_address_bit
     360                           (logand (lognot $nhash-track-keys-mask) flags)))))
     361          (declare (inline new-flags))
     362          (if (hash-lock-free-p hash)
     363            (loop
     364                (let* ((flags (nhash.vector.flags vector))
     365                       (new-flags (new-flags flags addressp)))
     366                  (when (or (eq flags new-flags)
     367                            (store-gvector-conditional nhash.vector.flags vector flags new-flags))
     368                    (return))))
     369            (setf (nhash.vector.flags vector) (new-flags (nhash.vector.flags vector) addressp))))))
    436370    (let* ((entries (nhash.vector-size vector)))
    437371      (declare (fixnum entries))
     
    456390(defun %normalize-hash-table-count (hash)
    457391  (let* ((vector (nhash.vector hash))
    458         (weak-deletions-count (nhash.vector.weak-deletions-count vector)))
     392        (weak-deletions-count (nhash.vector.weak-deletions-count vector)))
    459393    (declare (fixnum weak-deletions-count))
    460394    (unless (eql 0 weak-deletions-count)
    461395      (setf (nhash.vector.weak-deletions-count vector) 0)
    462       (let ((deleted-count (the fixnum
    463                              (+ (the fixnum (nhash.vector.deleted-count vector))
    464                                 weak-deletions-count)))
    465             (count (the fixnum (- (the fixnum (nhash.count hash)) weak-deletions-count))))
    466         (setf (nhash.vector.deleted-count vector) deleted-count
    467               (nhash.count hash) count)))))
     396      ;; lock-free hash tables don't maintain deleted-count, since would need to
     397      ;; lock and it's not worth it.
     398      (unless (hash-lock-free-p hash)
     399        (let ((deleted-count (the fixnum
     400                               (+ (the fixnum (nhash.vector.deleted-count vector))
     401                                  weak-deletions-count)))
     402              (count (the fixnum (- (the fixnum (nhash.vector.count vector)) weak-deletions-count))))
     403          (setf (nhash.vector.deleted-count vector) deleted-count
     404                (nhash.vector.count vector) count))))))
    468405
    469406
     
    471408  "Be sure that you understand the implications of changing this
    472409before doing so.")
     410
     411(defparameter *lock-free-hash-table-default* #+(or gz ccl-0711) t #-(or gz ccl-0711) nil)
    473412
    474413(defun make-hash-table (&key (test 'eql)
     
    479418                             (weak nil)
    480419                             (finalizeable nil)
    481                              (address-based t)
     420                             (address-based t)  ;; Ignored
     421                             (lock-free *lock-free-hash-table-default*)
    482422                             (shared *shared-hash-table-default*))
    483423  "Create and return a new hash table. The keywords are as follows:
     
    493433       approaching zero as the threshold approaches 0. Density 1 means an
    494434       average of one entry per bucket."
     435  (declare (ignore address-based)) ;; TODO: could reinterpret as "warn if becomes address-based"
    495436  (unless (and test (or (functionp test) (symbolp test)))
    496437    (report-bad-arg test '(and (not null) (or symbol function))))
     
    513454                    (setq test #'equalp) #'%%equalphash)
    514455                   (t (setq test (require-type test 'symbol))
    515                    (or hash-function
    516                        (error "non-standard test specified without hash-function")))))
     456                      (or hash-function
     457                          (error "non-standard test specified without hash-function")))))
    517458         (find-function
    518459          (case test
     
    533474    (when (and finalizeable (not weak))
    534475      (error "Only weak hash tables can be finalizeable."))
    535     (multiple-value-bind (size total-size)
     476    (multiple-value-bind (grow-threshold total-size)
    536477        (compute-hash-size (1- size) 1 rehash-threshold)
    537       (let* ((flags (if weak
    538                       (+ (+
    539                           (ash 1 $nhash_weak_bit)
    540                           (ecase weak
    541                             ((t :key) 0)
    542                             (:value (ash 1 $nhash_weak_value_bit))))
    543                          (if finalizeable (ash 1 $nhash_finalizeable_bit) 0))
    544                       0))
     478      (let* ((flags (+ (if weak (ash 1 $nhash_weak_bit) 0)
     479                       (ecase weak
     480                         ((t nil :key) 0)
     481                         (:value (ash 1 $nhash_weak_value_bit)))
     482                       (if finalizeable (ash 1 $nhash_finalizeable_bit) 0)
     483                       (if lock-free (ash 1 $nhash_keys_frozen_bit) 0)))
    545484             (hash (%cons-hash-table
    546                     #'%no-rehash hash-function test
     485                    hash-function test
    547486                    (%cons-nhash-vector total-size flags)
    548                     size rehash-threshold rehash-size address-based
     487                    grow-threshold rehash-threshold rehash-size
    549488                    find-function find-put-function
    550                     (unless shared *current-process*))))
     489                    (unless shared *current-process*)
     490                    lock-free)))
    551491        (setf (nhash.vector.hash (nhash.vector hash)) hash)
    552492        hash))))
     
    554494(defun compute-hash-size (size rehash-size rehash-ratio)
    555495  (let* ((new-size size))
     496    (declare (fixnum size new-size))
    556497    (setq new-size (max 30 (if (fixnump rehash-size)
    557                              (+ size rehash-size)
     498                             (%i+ size rehash-size)
    558499                             (ceiling (* size rehash-size)))))
    559500    (if (<= new-size size)
    560501      (setq new-size (1+ size)))        ; God save you if you make this happen
    561502   
    562     (values new-size
    563             (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio)))))))
     503    (let ((vector-size (%hash-size (max (+ new-size 2) (ceiling (* new-size rehash-ratio))))))
     504      ; TODO: perhaps allow more entries, based on actual size:
     505      ;  (values (min (floor vector-size rehash-ratio) (%i- vector-size 2)) vector-size))
     506      (values new-size vector-size)
     507      )))
    564508
    565509;;;  Suggested size is a fixnum: number of pairs.  Return a fixnum >=
     
    578522
    579523
    580 (defvar *continue-from-readonly-hashtable-lock-error* nil)
     524(defvar *continue-from-readonly-hashtable-lock-error* t)
    581525
    582526(defun signal-read-only-hash-table-error (hash)
    583527  (cond (*continue-from-readonly-hashtable-lock-error*
    584          (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
     528         (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!"
    585529                 "Hash-table ~s is readonly" hash)
    586530         (assert-hash-table-writeable hash)
     
    613557        (unlock-rwlock lock)))))
    614558
    615 
    616 ;;; what if somebody is mapping, growing, rehashing?
    617 (defun clrhash (hash)
    618   "This removes all the entries from HASH-TABLE and returns the hash table
    619    itself."
    620   (unless (typep hash 'hash-table)
    621     (report-bad-arg hash 'hash-table))
    622   (with-lock-context
    623     (without-interrupts
    624      (write-lock-hash-table hash)
    625      (let* ((vector (nhash.vector hash))
    626             (size (nhash.vector-size vector))
    627             (count (+ size size))
    628             (index $nhash.vector_overhead))
    629        (declare (fixnum size count index))
    630        (dotimes (i count)
    631          (setf (%svref vector index) (%unbound-marker))
    632          (incf index))
    633        (incf (the fixnum (nhash.grow-threshold hash))
    634              (the fixnum (+ (the fixnum (nhash.count hash))
    635                             (the fixnum (nhash.vector.deleted-count vector)))))
    636        (setf (nhash.count hash) 0
    637              (nhash.vector.cache-key vector) (%unbound-marker)
    638              (nhash.vector.cache-value vector) nil
    639              (nhash.vector.finalization-alist vector) nil
    640              (nhash.vector.free-alist vector) nil
    641              (nhash.vector.weak-deletions-count vector) 0
    642              (nhash.vector.deleted-count vector) 0
    643              (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
    644                                                  (nhash.vector.flags vector))))
    645      (unlock-hash-table hash nil)
    646      hash)))
    647 
    648559(defun index->vector-index (index)
    649560  (declare (fixnum index))
     
    654565  (the fixnum (ash (the fixnum (- index $nhash.vector_overhead)) -1)))
    655566
    656 
    657567(defun hash-table-count (hash)
    658568  "Return the number of entries in the given HASH-TABLE."
    659   (require-type hash 'hash-table)
     569  (setq hash (require-type hash 'hash-table))
     570  (when (hash-lock-free-p hash)
     571    ;; We don't try to maintain a running total, so just count.
     572    (return-from hash-table-count (lock-free-count-entries hash)))
    660573  (%normalize-hash-table-count hash)
    661   (the fixnum (nhash.count hash)))
     574  (the fixnum (nhash.vector.count (nhash.vector hash))))
    662575
    663576(defun hash-table-rehash-size (hash)
     
    673586   table that can hold however many entries HASH-TABLE can hold without
    674587   having to be grown."
    675   (%i+ (the fixnum (hash-table-count hash))
    676        (the fixnum (nhash.grow-threshold hash))
    677        (the fixnum (nhash.vector.deleted-count (nhash.vector hash)))))
     588  (let* ((hash (require-type hash 'hash-table))
     589         (vector (nhash.vector hash)))
     590    (values (floor (nhash.vector.size vector) (nhash.rehash-ratio hash)))))
    678591
    679592(defun hash-table-test (hash)
     
    692605      f)))
    693606
    694 ;; Finalization-list accessors are in "ccl:lib;hash" because SETF functions
    695 ;;  don't get dumped as "simple" %defuns.
    696 ;;
    697 
     607;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
     608;;
     609;; nearly-lock-free hash tables
     610;;
     611;; A modification of the lock-free hash table algorithm described by Cliff Click Jr.  in
     612;; http://blogs.azulsystems.com/cliff/2007/03/a_nonblocking_h.html.
     613;;
     614;; The modifications have to do with the fact that the goal of the current implementation
     615;; is to have thread-safe hash tables with minimal performance penalty on reads, so I don't
     616;; bother with aspects of his algorithm that aren't relevant to that goal.
     617;;
     618;; The main difference from Click's algorithm is that I don't try to do rehashing
     619;; concurrently.  Instead, rehashing grabs a lock, so that only one thread can be
     620;; rehashing at any given time, and readers/writers will block waiting for the rehashing
     621;; to finish.
     622;;
     623;; In addition, I don't have a separate state for partially inserted key, I reuse the
     624;; DELETED state for that.  So in our implementation the following are the possible states
     625;; of a hash table entry (where "object" means any object other than the special markers):
     626;;
     627;; State      Key               Value
     628;; DELETED    object            free-hash-marker
     629;; IN-USE     object            object
     630;; FREE       free-hash-marker  free-hash-marker
     631;; REHASHING  object            rehashing-value-marker
     632;; REHASHING  free-hash-marker  rehashing-value-marker
     633;;
     634;; No other states are allowed - at no point in time can a hash table entry be in any
     635;; other state.   In addition, the only transition allowed on the Key slot is
     636;; free-hash-marker -> object.  Once a key slot is so claimed, it must never change
     637;; again (even after the hash vector has been discarded after rehashing, because
     638;; there can be some process still looking at it).
     639;; In particular, rehashing in place is not an option.  All rehashing creates a new
     640;; vector and copies into it.  This means it's kinda risky to use lock-free hash
     641;; tables with address-based keys, because they will thrash in low-memory situations,
     642;; but we don't disallow it because a particular use might not have this problem.
     643
     644
     645(defun lock-free-rehash (hash)
     646  ;;(break "We think we need to rehash ~s" (nhash.vector hash))
     647  (with-lock-context
     648    (without-interrupts ;; not re-entrant
     649      (let ((lock (nhash.exclusion-lock hash)))
     650        (%lock-recursive-lock-object lock)
     651        ;; TODO: might also want to rehash if deleted entries are a large percentage
     652        ;; of all entries, more or less.
     653        (when (or (%i<= (nhash.grow-threshold hash) 0) ;; no room
     654                  (%needs-rehashing-p (nhash.vector hash))) ;; or keys moved
     655          (%lock-free-rehash hash))
     656        (%unlock-recursive-lock-object lock)))))
     657
     658
     659;; TODO: This is silly.  We're implementing atomic swap using store-conditional,
     660;; but internally store-conditional is probably implemented using some kind of
     661;; an atomic swap!!
     662(defun atomic-swap-gvector (index gvector value)
     663  (loop
     664    (let ((old-value (%svref gvector index)))
     665      (when (store-gvector-conditional index gvector old-value value)
     666        (return old-value)))))
     667
     668;; Interrupts are disabled and caller has the hash lock on the table, blocking other
     669;; threads attempting a rehash.
     670;; Other threads might be reading/writing/deleting individual entries, but they
     671;; will block if they see a value = rehashing-value-marker.
     672;; GC may run, updating the needs-rehashing flags and deleting weak entries in both
     673;; old and new vectors.
     674(defun %lock-free-rehash (hash)
     675  ;; Prevent puthash from adding new entries.  Note this doesn't keep it from undeleting
     676  ;; existing entries, so we might still lose, but this makes the odds much smaller.
     677  (setf (nhash.grow-threshold hash) 0)
     678  (let* ((old-vector (nhash.vector hash))
     679         (inherited-flags (logand $nhash_weak_flags_mask (nhash.vector.flags old-vector)))
     680         count new-vector grow-threshold vector-size)
     681    (tagbody
     682     RESTART
     683     (setq count (lock-free-count-entries hash))
     684     (multiple-value-setq (grow-threshold vector-size)
     685       (compute-hash-size count (nhash.rehash-size hash) (nhash.rehash-ratio hash)))
     686     (setq new-vector (%cons-nhash-vector vector-size inherited-flags))
     687     REHASH
     688     (loop for i from $nhash.vector_overhead below (uvsize old-vector) by 2
     689       do (let ((value (atomic-swap-gvector (%i+ i 1) old-vector rehashing-value-marker)))
     690            (when (eq value rehashing-value-marker) (error "Who else is doing this?"))
     691            (unless (eq value free-hash-marker)
     692              (let* ((key (%svref old-vector i))
     693                     (new-index (%growhash-probe new-vector hash key))
     694                     (new-vector-index (index->vector-index new-index)))
     695                (setf (%svref new-vector new-vector-index) key)
     696                (setf (%svref new-vector (%i+ new-vector-index 1)) value)
     697                (when (%i<= (decf grow-threshold) 0)
     698                  ;; Too many entries got undeleted while we were rehashing!
     699                  (go RESTART))))))
     700     (when (%needs-rehashing-p new-vector) ;; keys moved, but at least can use the same new-vector.
     701       (%init-misc free-hash-marker new-vector)
     702       (%init-nhash-vector new-vector inherited-flags)
     703       (go REHASH)))
     704    (setf (nhash.vector.hash new-vector) hash)
     705    (setf (nhash.grow-threshold hash) grow-threshold)
     706    ;; At this point, another thread might decrement the threshold while they're looking at the old
     707    ;; vector. That's ok, just means it will be too small and we'll rehash sooner than planned,
     708    ;; no big deal.
     709    (setf (nhash.vector hash) new-vector)))
     710
     711
     712(defun lock-free-gethash (key hash default)
     713  (declare (optimize (speed 3) (safety 0) (debug 0)))
     714  (loop
     715    (let* ((vector (nhash.vector hash))
     716           (vector-index (funcall (the function (nhash.find hash)) hash key)))
     717      (declare (fixnum vector-index))
     718      ;; Need to punt if vector changed because no way to know whether nhash.find was
     719      ;; using old or new vector.
     720      (when (eq vector (nhash.vector hash))
     721        (cond ((eql vector-index -1)
     722               (unless (%needs-rehashing-p vector)
     723                 (return-from lock-free-gethash (values default nil))))
     724              (t (let ((value (%svref vector (%i+ vector-index 1))))
     725                   (unless (eq value rehashing-value-marker)
     726                     (if (eq value free-hash-marker)
     727                       (return-from lock-free-gethash (values default nil))
     728                       (return-from lock-free-gethash (values value t)))))))))
     729    ;; We're here because the table needs rehashing or it was getting rehashed while we
     730    ;; were searching. Take care of it and try again.
     731    (lock-free-rehash hash)))
     732
     733(defun lock-free-remhash (key hash)
     734  (declare (optimize (speed 3) (safety 0) (debug 0)))
     735  (loop
     736    (let* ((vector (nhash.vector hash))
     737           (vector-index (funcall (the function (nhash.find hash)) hash key)))
     738      (declare (fixnum vector-index))
     739      ;; Need to punt if vector changed because no way to know whether nhash.find was
     740      ;; using old or new vector.
     741      (when (eq vector (nhash.vector hash))
     742        (cond ((eql vector-index -1)
     743               (unless (%needs-rehashing-p vector)
     744                 (return-from lock-free-remhash nil)))
     745              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
     746                   (unless (eq old-value rehashing-value-marker)
     747                     (when (eq old-value free-hash-marker)
     748                       (return-from lock-free-remhash nil))
     749                     (when (set-hash-value-conditional vector-index vector old-value free-hash-marker)
     750                       (return-from lock-free-remhash t)))))))
     751      ;; We're here because the table needs rehashing or it was getting rehashed while we
     752      ;; were searching.  Take care of it and try again.
     753      (lock-free-rehash hash))))
     754
     755(defun lock-free-clrhash (hash)
     756  (with-lock-context
     757    (without-interrupts
     758     (let ((lock (nhash.exclusion-lock hash)))
     759       (%lock-recursive-lock-object lock) ;; disallow rehashing.
     760       (loop
     761         with vector = (nhash.vector hash)
     762         for i1 fixnum from (%i+ $nhash.vector_overhead 1) below (uvsize vector) by 2
     763         do (setf (%svref vector i1) free-hash-marker))
     764       (%unlock-recursive-lock-object lock))))
     765  hash)
     766
     767(defun lock-free-puthash (key hash value)
     768  (declare (optimize (speed 3) (safety 0) (debug 0)))
     769  (when (eq key free-hash-marker)
     770    (error "Can't use ~s as a hash-table key" key))
     771  (when (or (eq value rehashing-value-marker)
     772            (eq value free-hash-marker))
     773    (error "Illegal value ~s for storing in a hash table" value))
     774  (loop
     775    (let* ((vector (nhash.vector  hash))
     776           (vector-index (funcall (nhash.find-new hash) hash key)))
     777      ;; Need to punt if vector changed because no way to know whether nhash.find-new was
     778      ;; using old or new vector.
     779      (when (eq vector (nhash.vector hash))
     780        (cond ((or (eql vector-index -1)
     781                   (eq (%svref vector vector-index) free-hash-marker))
     782               (unless (or (%needs-rehashing-p vector)
     783                           (%i<= (nhash.grow-threshold hash) 0))
     784                 ;; Note if the puthash fails, grow-threshold will end up too small. This
     785                 ;; just means we might rehash sooner than absolutely necessary, no real
     786                 ;; harm done (the most likely cause of failing is that somebody is
     787                 ;; already rehashing anyway).  DON'T try to incf it back on failure --
     788                 ;; that risks grow-threshold ending up too big (e.g. if somebody rehashes
     789                 ;; before the incf), which _could_ be harmful.
     790                 (atomic-decf (nhash.grow-threshold hash))
     791                 (if (set-hash-key-conditional vector-index vector free-hash-marker key)
     792                   (when (set-hash-value-conditional vector-index vector free-hash-marker value)
     793                     (return-from lock-free-puthash value)))))
     794              (t (let ((old-value (%svref vector (%i+ vector-index 1))))
     795                   (unless (eq old-value rehashing-value-marker)
     796                     (when (set-hash-value-conditional vector-index vector old-value value)
     797                       (return-from lock-free-puthash value))))))))
     798    ;; We're here because the table needs rehashing or it was getting rehashed while we
     799    ;; were searching, or no room for new entry, or somebody else claimed the key from
     800    ;; under us (that last case doesn't need to retry, but it's unlikely enough that
     801    ;; it's not worth checking for).  Take care of it and try again.
     802    (lock-free-rehash hash)))
     803
     804
     805(defun lock-free-count-entries (hash)
     806  ;; Other threads could be adding/removing entries while we count, some of
     807  ;; which will be included in the count (i.e. will be treated as if they
     808  ;; happened after counting) and some won't (i.e. will be treated as if
     809  ;; they happened before counting), but not necessarily in correlation
     810  ;; with their temporal relationship.
     811  (loop
     812    with vector = (nhash.vector hash)
     813    for i fixnum from $nhash.vector_overhead below (uvsize vector) by 2
     814    count (and (neq (%svref vector i) free-hash-marker)
     815               (let ((value (%svref vector (%i+ i 1))))
     816                 (when (eq value rehashing-value-marker)
     817                   ;; This table is being rehashed.  Wait for it to be
     818                   ;; done and try again.
     819                   (lock-free-rehash hash)
     820                   (return-from lock-free-count-entries (lock-free-count-entries hash)))
     821                 (neq value free-hash-marker)))))
     822
     823;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
    698824
    699825
     
    704830  (unless (typep hash 'hash-table)
    705831    (report-bad-arg hash 'hash-table))
     832  (when (hash-lock-free-p hash)
     833    (return-from gethash (lock-free-gethash key hash default)))
    706834  (let* ((value nil)
    707          (vector-key nil)
    708835         (gc-locked nil)
    709836         (readonly nil)
     
    711838    (with-lock-context
    712839      (without-interrupts
    713        (setq readonly (eq (read-lock-hash-table hash) :readonly))
    714        (let* ((vector (nhash.vector hash)))
    715          (if (and (eq key (nhash.vector.cache-key vector))
    716                   ;; Check twice: the GC might nuke the cached key/value pair
    717                   (progn (setq value (nhash.vector.cache-value vector))
    718                          (eq key (nhash.vector.cache-key vector))))
    719            (setq foundp t)
    720            (loop
    721              (let* ((vector-index (funcall (nhash.find hash) hash key)))
    722                (declare (fixnum vector-index))
    723                ;; Referencing both key and value here - and referencing
    724                ;; value first - is an attempt to compensate for the
    725                ;; possibility that the GC deletes a weak-on-key pair.
    726                (setq value (%svref vector (the fixnum (1+ vector-index)))
    727                      vector-key (%svref vector vector-index))
    728                (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
    729                                         (not (eq vector-key deleted-hash-key-marker))))
    730                       (when (nhash.owner hash)
    731                         (setf (nhash.vector.cache-key vector) vector-key
    732                               (nhash.vector.cache-value vector) value
    733                               (nhash.vector.cache-idx vector) (vector-index->index
    734                                                                vector-index)))
    735                       (return))
    736                      ((%needs-rehashing-p hash)
    737                       (%lock-gc-lock)
    738                       (setq gc-locked t)
    739                       (unless readonly
    740                         (let* ((lock (nhash.exclusion-lock hash)))
    741                           (when lock (%promote-rwlock lock))))
    742                       (when (%needs-rehashing-p hash)
    743                         (%rehash hash)))
    744                      (t (return)))))))
    745        (when gc-locked (%unlock-gc-lock))
    746        (unlock-hash-table hash readonly)))
     840        (setq readonly (eq (read-lock-hash-table hash) :readonly))
     841        (let* ((vector (nhash.vector hash)))
     842          (if (and (eq key (nhash.vector.cache-key vector))
     843                   ;; Check twice: the GC might nuke the cached key/value pair
     844                   (progn (setq value (nhash.vector.cache-value vector))
     845                          (eq key (nhash.vector.cache-key vector))))
     846            (setq foundp t)
     847            (loop
     848              (let* ((vector-index (funcall (nhash.find hash) hash key)))
     849                (declare (fixnum vector-index))
     850                (cond ((setq foundp (not (eql vector-index -1)))
     851                       ;; Referencing both key and value here - and referencing
     852                       ;; value first - is an attempt to compensate for the
     853                       ;; possibility that the GC deletes a weak-on-key pair.
     854                       (setq value (%svref vector (%i+ vector-index 1)))
     855                       (when (nhash.owner hash)
     856                         (setf (nhash.vector.cache-key vector)
     857                               (%svref vector vector-index)
     858                               (nhash.vector.cache-value vector)
     859                              value
     860                               (nhash.vector.cache-idx vector)
     861                               (vector-index->index (the fixnum vector-index))))
     862                       (return))
     863                      ((%needs-rehashing-p vector)
     864                       (%lock-gc-lock)
     865                       (setq gc-locked t)
     866                       (unless readonly
     867                         (let* ((lock (nhash.exclusion-lock hash)))
     868                           (when lock (%promote-rwlock lock))))
     869                       (when (%needs-rehashing-p vector)
     870                         (%rehash hash)))
     871                      (t (return)))))))
     872        (when gc-locked (%unlock-gc-lock))
     873        (unlock-hash-table hash readonly)))
    747874    (if foundp
    748875      (values value t)
     
    754881  (unless (typep hash 'hash-table)
    755882    (setq hash (require-type hash 'hash-table)))
     883  (when (hash-lock-free-p hash)
     884    (return-from remhash (lock-free-remhash key hash)))
    756885  (let* ((foundp nil))
    757886    (with-lock-context
     
    759888       (write-lock-hash-table hash)
    760889       (%lock-gc-lock)
    761        (when (%needs-rehashing-p hash)
    762          (%rehash hash))   
    763890       (let* ((vector (nhash.vector hash)))
     891         (when (%needs-rehashing-p vector)
     892           (%rehash hash))
    764893         (if (eq key (nhash.vector.cache-key vector))
    765894           (progn
    766              (setf (nhash.vector.cache-key vector) free-hash-key-marker
     895             (setf (nhash.vector.cache-key vector) free-hash-marker
    767896                   (nhash.vector.cache-value vector) nil)
    768897             (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
     
    770899               (setf (%svref vector (the fixnum (1+ vidx))) nil))
    771900             (incf (the fixnum (nhash.vector.deleted-count vector)))
    772              (decf (the fixnum (nhash.count hash)))
     901             (decf (the fixnum (nhash.vector.count vector)))
    773902             (setq foundp t))
    774            (let* ((vector-index (funcall (nhash.find hash) hash key))
    775                   (vector-key (%svref vector vector-index)))
     903           (let* ((vector-index (funcall (nhash.find hash) hash key)))
    776904             (declare (fixnum vector-index))
    777              (when (setq foundp (and (not (eq vector-key free-hash-key-marker))
    778                                      (not (eq vector-key deleted-hash-key-marker))))
     905             (unless (eql vector-index -1)
    779906               ;; always clear the cache cause I'm too lazy to call the
    780907               ;; comparison function and don't want to keep a possibly
    781908               ;; deleted key from being GC'd
    782                (setf (nhash.vector.cache-key vector) free-hash-key-marker
     909               (setf (nhash.vector.cache-key vector) free-hash-marker
    783910                     (nhash.vector.cache-value vector) nil)
    784911               ;; Update the count
    785912               (incf (the fixnum (nhash.vector.deleted-count vector)))
    786                (decf (the fixnum (nhash.count hash)))
    787                ;; Remove a cons from the free-alist if the table is finalizeable
    788                (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector))
    789                  (pop (the list (svref nhash.vector.free-alist vector))))
     913               (decf (the fixnum (nhash.vector.count vector)))
    790914               ;; Delete the value from the table.
    791915               (setf (%svref vector vector-index) deleted-hash-key-marker
    792                      (%svref vector (the fixnum (1+ vector-index))) nil))))
     916                     (%svref vector (the fixnum (1+ vector-index))) nil)
     917               (setq foundp t))))
    793918         (when (and foundp
    794                     (zerop (the fixnum (nhash.count hash))))
     919                    (zerop (the fixnum (nhash.vector.count vector))))
    795920           (do* ((i $nhash.vector_overhead (1+ i))
    796921                 (n (uvsize vector)))
    797922                ((= i n))
    798923             (declare (fixnum i n))
    799              (setf (%svref vector i) free-hash-key-marker))
     924             (setf (%svref vector i) free-hash-marker))
    800925           (setf (nhash.grow-threshold hash)
    801926                 (+ (nhash.vector.deleted-count vector)
     
    809934    foundp))
    810935
     936;;; what if somebody is mapping, growing, rehashing?
     937(defun clrhash (hash)
     938  "This removes all the entries from HASH-TABLE and returns the hash table
     939   itself."
     940  (unless (typep hash 'hash-table)
     941    (report-bad-arg hash 'hash-table))
     942  (when (hash-lock-free-p hash)
     943    (return-from clrhash (lock-free-clrhash hash)))
     944  (with-lock-context
     945    (without-interrupts
     946     (write-lock-hash-table hash)
     947     (let* ((vector (nhash.vector hash))
     948            (size (nhash.vector-size vector))
     949            (count (+ size size))
     950            (index $nhash.vector_overhead))
     951       (declare (fixnum size count index))
     952       (dotimes (i count)
     953         (setf (%svref vector index) free-hash-marker)
     954         (incf index))
     955       (incf (the fixnum (nhash.grow-threshold hash))
     956             (the fixnum (+ (the fixnum (nhash.vector.count vector))
     957                            (the fixnum (nhash.vector.deleted-count vector)))))
     958       (setf (nhash.vector.count vector) 0
     959             (nhash.vector.cache-key vector) free-hash-marker
     960             (nhash.vector.cache-value vector) nil
     961             (nhash.vector.finalization-alist vector) nil
     962             (nhash.vector.free-alist vector) nil
     963             (nhash.vector.weak-deletions-count vector) 0
     964             (nhash.vector.deleted-count vector) 0
     965             (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
     966                                                 (nhash.vector.flags vector))))
     967     (unlock-hash-table hash nil)
     968     hash)))
     969
     970
    811971(defun puthash (key hash default &optional (value default))
    812972  (declare (optimize (speed 3) (space 0)))
    813973  (unless (typep hash 'hash-table)
    814974    (report-bad-arg hash 'hash-table))
    815   (if (eq key (%unbound-marker))
    816     (error "Can't use ~s as a hash-table key" (%unbound-marker)))
     975  (when (hash-lock-free-p hash)
     976    (return-from puthash (lock-free-puthash key hash value)))
     977  (if (eq key free-hash-marker)
     978    (error "Can't use ~s as a hash-table key" key))
    817979  (with-lock-context
    818980    (without-interrupts
     
    822984        AGAIN
    823985          (%lock-gc-lock)
    824           (when (%needs-rehashing-p hash)
    825             (%rehash hash))
    826           (let ((vector (nhash.vector  hash)))     
     986          (let ((vector (nhash.vector hash)))
     987            (when (%needs-rehashing-p vector)
     988              (%rehash hash))
    827989            (when (eq key (nhash.vector.cache-key vector))
    828990              (let* ((idx (nhash.vector.cache-idx vector)))
     
    8391001                     (%set-hash-table-vector-key vector vector-index key)
    8401002                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
    841                      (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
     1003                     (incf (the fixnum (nhash.vector.count vector)))
    8421004                     ;; Adjust deleted-count
    8431005                     (when (> 0 (the fixnum
    8441006                                  (decf (the fixnum
    8451007                                          (nhash.vector.deleted-count vector)))))
    846                        (let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
    847                          (declare (fixnum weak-deletions))
    848                          (setf (nhash.vector.weak-deletions-count vector) 0)
    849                          (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
    850                          (decf (the fixnum (nhash.count hash)) weak-deletions))))
    851                     ((eq old-value free-hash-key-marker)
     1008                       (%normalize-hash-table-count hash)))
     1009                    ((eq old-value free-hash-marker)
    8521010                     (when (eql 0 (nhash.grow-threshold hash))
    8531011                       (%unlock-gc-lock)
    854                        (grow-hash-table hash)
     1012                       (%grow-hash-table hash)
    8551013                       (go AGAIN))
    8561014                     (%set-hash-table-vector-key vector vector-index key)
    8571015                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
    8581016                     (decf (the fixnum (nhash.grow-threshold hash)))
    859                      (incf (the fixnum (nhash.count hash))))
     1017                     (incf (the fixnum (nhash.vector.count vector))))
    8601018                    (t
    8611019                     ;; Key was already there, update value.
     
    8701028
    8711029(defun count-entries (hash)
    872   (let* ((vector (nhash.vector hash))
    873          (size (uvsize vector))
    874          (idx $nhash.vector_overhead)
    875          (count 0))
    876     (loop
    877       (when (neq (%svref vector idx) (%unbound-marker))
    878         (incf count))
    879       (when (>= (setq idx (+ idx 2)) size)
    880         (return count)))))
     1030  (if (hash-lock-free-p hash)
     1031    (lock-free-count-entries hash)
     1032    (let* ((vector (nhash.vector hash))
     1033           (size (uvsize vector))
     1034           (idx $nhash.vector_overhead)
     1035           (count 0))
     1036      (loop
     1037        (when (neq (%svref vector idx) free-hash-marker)
     1038          (incf count))
     1039        (when (>= (setq idx (+ idx 2)) size)
     1040          (return count))))))
    8811041
    8821042
     
    8971057    (%normalize-hash-table-count hash)
    8981058    (let* ((old-vector (nhash.vector hash))
    899            (old-size (nhash.count hash))
    900            (old-total-size (nhash.vector-size old-vector))
     1059           (old-size (nhash.vector.count old-vector))
     1060           (old-total-size (nhash.vector.size old-vector))
    9011061           (flags 0)
    9021062           (flags-sans-weak 0)
    903            (weak-flags)
    904            rehashF)
     1063           (weak-flags 0))
    9051064      (declare (fixnum old-total-size flags flags-sans-weak weak-flags))   
    906       ; well we knew lock was 0 when we called this - is it still 0?
    9071065      (when (> (nhash.vector.deleted-count old-vector) 0)
    9081066        ;; There are enough deleted entries. Rehash to get rid of them
     
    9161074        (progn
    9171075          (unwind-protect
    918             (let ((fwdnum (get-fwdnum))
    919                   (gc-count (gc-count))
     1076            (let ((gc-count (%get-gc-count))
    9201077                  vector)
    9211078              (setq flags (nhash.vector.flags old-vector)
    9221079                    flags-sans-weak (logand flags (logxor -1 $nhash_weak_flags_mask))
    923                     weak-flags (logand flags $nhash_weak_flags_mask)
    924                     rehashF (nhash.rehashF hash))         
    925               (setf (nhash.lock hash) (%ilogior (nhash.lock hash) $nhash.lock-while-growing) ; dont need
    926                     (nhash.rehashF hash) #'%am-growing
    927                     (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
     1080                    weak-flags (logand flags $nhash_weak_flags_mask))
     1081              (setf (nhash.vector.flags old-vector) flags-sans-weak)      ; disable GC weak stuff
    9281082              (%normalize-hash-table-count hash)
     1083              (when (> (nhash.vector.deleted-count old-vector) 0)
     1084                (return-from grow-hash-table (%rehash hash)))
    9291085              (setq vector (%cons-nhash-vector total-size 0))
    9301086              (do* ((index 0 (1+ index))
     
    9341090               
    9351091                 (let ((key (%svref old-vector vector-index)))
    936                    (unless (or (eq key free-hash-key-marker)
     1092                   (unless (or (eq key free-hash-marker)
    9371093                               (eq key deleted-hash-key-marker))
    9381094                     (let* ((new-index (%growhash-probe vector hash key))
     
    9461102                     (nhash.vector.free-alist vector)
    9471103                     (nhash.vector.free-alist old-vector)
     1104                     (nhash.vector.count vector) old-size
    9481105                     (nhash.vector.flags vector)
    9491106                     (logior weak-flags (the fixnum (nhash.vector.flags vector))))
     
    9511108                     (nhash.vector hash) vector
    9521109                     (nhash.vector.hash vector) hash
    953                      (nhash.vector.cache-key vector) (%unbound-marker)
     1110                     (nhash.vector.cache-key vector) free-hash-marker
    9541111                     (nhash.vector.cache-value vector) nil
    955                      (nhash.fixnum hash) fwdnum
    956                      (nhash.gc-count hash) gc-count
    957                      (nhash.grow-threshold hash) (- size (nhash.count hash)))
    958                (when (eq #'%am-growing (nhash.rehashF hash))
    959                  ;; if not changed to %maybe-rehash then contains no address based keys
    960                  (setf (nhash.rehashf hash) #'%no-rehash))
    961                (setq rehashF nil)       ; tell clean-up form we finished the loop
    962                (when (neq old-size (nhash.count hash))
    963                  (cerror "xx" "Somebody messed with count while growing")
    964                  (return-from grow-hash-table (grow-hash-table hash )))
    965                (when (minusp (nhash.grow-threshold hash))
    966                  (cerror "nn" "negative grow-threshold ~S ~s ~s ~s"
    967                          (nhash.grow-threshold hash) size total-size old-size))
     1112                     (nhash.vector.gc-count vector) gc-count
     1113                     (nhash.grow-threshold hash) (- size old-size))
     1114               (setq weak-flags nil)       ; tell clean-up form we finished the loop
    9681115               ;; If the old vector's in some static heap, zero it
    9691116               ;; so that less garbage is retained.
    970                (%init-misc 0 old-vector)))           
    971             (when rehashF
    972               (setf (nhash.rehashF hash) rehashF
    973                     (nhash.vector.flags old-vector)
     1117               (%init-misc 0 old-vector)))
     1118            (when weak-flags
     1119              (setf (nhash.vector.flags old-vector)
    9741120                    (logior weak-flags (the fixnum (nhash.vector.flags old-vector)))))))))))
    9751121
    9761122
    977 
    978 ;;; values of nhash.rehashF
    979 ;;; %no-rehash - do nothing
    980 ;;; %maybe-rehash - if doesnt need rehashing - if is rehashing 0 else nil
    981 ;                 if locked 0
    982 ;                 else rehash, return t
    983 ;;; %am-rehashing - 0
    984 ;;; %am-growing   - calls %maybe-rehash
    985 
    986 ;;; compute-hash-code funcalls it if addressp and maybe-rehash-p
    987 ;;;                  sets to maybe-rehash if addressp and update-maybe-rehash (ie from puthash)
    988 ;;; grow-hash-table sets to %am-growing when doing so, resets to original value when done
    989 ;;; rehash sets to %am-rehashing, then to original when done
    990 
    991 (defun %no-rehash (hash)
    992   (declare (%noforcestk)
    993            (optimize (speed 3) (safety 0))
    994            (ignore hash))
    995   nil)
    996 
    997 (defun %maybe-rehash (hash)
    998   (declare (optimize (speed 3) (safety 0)))
    999   (cond ((not (%needs-rehashing-p hash))
    1000          nil)
    1001         (t (loop
    1002              (%rehash hash)
    1003              (unless (%needs-rehashing-p hash)
    1004                (return))
    1005              ;(incf n3)
    1006              )
    1007            t)))
    1008 
    1009 (defun %am-rehashing (hash)
    1010   (declare (optimize (speed 3) (safety 0))
    1011            (ignore hash))
    1012   0)
    1013 
    1014 (defun %am-growing (hash)
    1015   (declare (optimize (speed 3) (safety 0)))
    1016   (%maybe-rehash hash))
    10171123
    10181124(defun general-hash-find (hash key)
     
    10251131;;;   index - the index in the vector for key (where it was or where
    10261132;;;           to insert if the current key at that index is deleted-hash-key-marker
    1027 ;;;           or free-hash-key-marker)
    1028 
    1029 
    1030 
    1031 (defun %hash-probe (hash key update-hash-flags)
     1133;;;           or free-hash-marker)
     1134
     1135
     1136
     1137(defun %hash-probe (hash key for-put-p)
    10321138  (declare (optimize (speed 3) (space 0)))
    10331139  (multiple-value-bind (hash-code index entries)
    1034                        (compute-hash-code hash key update-hash-flags)
     1140                       (compute-hash-code hash key for-put-p)
    10351141    (locally (declare (fixnum hash-code index entries))
    10361142      (let* ((compareF (nhash.compareF hash))
     
    10471153                          (setq vector-index (index->vector-index index)
    10481154                                table-key (%svref vector vector-index))
    1049                           (cond ((eq table-key free-hash-key-marker)
    1050                                  (return-it (or first-deleted-index
    1051                                                 vector-index)))
     1155                          (cond ((eq table-key free-hash-marker)
     1156                                 (return-it (if for-put-p
     1157                                              (or first-deleted-index
     1158                                                  vector-index)
     1159                                              -1)))
    10521160                                ((eq table-key deleted-hash-key-marker)
    10531161                                 (when (null first-deleted-index)
     
    10671175                                  (decf index entries))
    10681176                                (when (eql index initial-index)
    1069                                   (unless first-deleted-index
    1070                                     (error "No deleted entries in table"))
    1071                                   (return-it first-deleted-index))
     1177                                  (return-it (if for-put-p
     1178                                               (or first-deleted-index
     1179                                                   (error "Bug: no deleted entries in table"))
     1180                                               -1)))
    10721181                                (test-it ,predicate))))))
    10731182              (if (fixnump comparef)
     
    10981207         (table-key (%svref vector vector-index)))
    10991208    (declare (fixnum hash-code  entries vector-index))
    1100     (if (or (eq key table-key)
    1101             (eq table-key free-hash-key-marker))
     1209    (if (eq table-key key)
    11021210      vector-index
    1103       (let* ((secondary-hash (%svref secondary-keys-*-2
    1104                                      (logand 7 hash-code)))
    1105              (initial-index vector-index)             
    1106              (first-deleted-index (if (eq table-key deleted-hash-key-marker)
    1107                                     vector-index))
    1108              (count (+ entries entries))
    1109              (length (+ count $nhash.vector_overhead)))
    1110         (declare (fixnum secondary-hash initial-index count length))
    1111         (loop
    1112           (incf vector-index secondary-hash)
    1113           (when (>= vector-index length)
    1114             (decf vector-index count))
    1115           (setq table-key (%svref vector vector-index))
    1116           (when (= vector-index initial-index)
    1117             (return first-deleted-index))
    1118           (if (eq table-key key)
    1119             (return vector-index)
    1120             (if (eq table-key free-hash-key-marker)
    1121               (return (or first-deleted-index vector-index))
    1122               (if (and (null first-deleted-index)
    1123                        (eq table-key deleted-hash-key-marker))
    1124                 (setq first-deleted-index vector-index)))))))))
     1211      (if (eq table-key free-hash-marker)
     1212        -1
     1213        (let* ((secondary-hash (%svref secondary-keys-*-2
     1214                                       (logand 7 hash-code)))
     1215               (initial-index vector-index)             
     1216               (count (+ entries entries))
     1217               (length (+ count $nhash.vector_overhead)))
     1218          (declare (fixnum secondary-hash initial-index count length))
     1219          (loop
     1220            (incf vector-index secondary-hash)
     1221            (when (>= vector-index length)
     1222              (decf vector-index count))
     1223            (setq table-key (%svref vector vector-index))
     1224            (when (= vector-index initial-index)
     1225              (return -1))
     1226            (if (eq table-key key)
     1227              (return vector-index)
     1228              (when (eq table-key free-hash-marker)
     1229                (return -1)))))))))
    11251230
    11261231;;; As above, but note whether the key is in some way address-based
     
    11531258    (declare (fixnum hash-code vector-index))
    11541259    (if (or (eq key table-key)
    1155             (eq table-key free-hash-key-marker))
     1260            (eq table-key free-hash-marker))
    11561261      vector-index
    11571262      (let* ((secondary-hash (%svref secondary-keys-*-2
     
    11691274          (setq table-key (%svref vector vector-index))
    11701275          (when (= vector-index initial-index)
    1171             (return first-deleted-index))
     1276            (or first-deleted-index
     1277                (error "Bug: no deleted entries in table")))
    11721278          (if (eq table-key key)
    11731279            (return vector-index)
    1174             (if (eq table-key free-hash-key-marker)
     1280            (if (eq table-key free-hash-marker)
    11751281              (return (or first-deleted-index vector-index))
    11761282              (if (and (null first-deleted-index)
     
    11871293           (table-key (%svref vector vector-index)))
    11881294      (declare (fixnum hash-code entries vector-index))
    1189       (if (or (eql key table-key)
    1190               (eq table-key free-hash-key-marker))
     1295      (if (eql key table-key)
    11911296        vector-index
    1192         (let* ((secondary-hash (%svref secondary-keys-*-2
    1193                                        (logand 7 hash-code)))
    1194                (initial-index vector-index)
    1195                (first-deleted-index (if (eq table-key deleted-hash-key-marker)
    1196                                       vector-index))
    1197                (count (+ entries entries))
    1198                (length (+ count $nhash.vector_overhead)))
    1199           (declare (fixnum secondary-hash initial-index count length))
    1200           (loop
    1201             (incf vector-index secondary-hash)
    1202             (when (>= vector-index length)
    1203               (decf vector-index count))
    1204             (setq table-key (%svref vector vector-index))
    1205             (when (= vector-index initial-index)
    1206               (return first-deleted-index))
    1207           (if (eql table-key key)
    1208             (return vector-index)
    1209             (if (eq table-key free-hash-key-marker)
    1210               (return (or first-deleted-index vector-index))
    1211               (if (and (null first-deleted-index)
    1212                        (eq table-key deleted-hash-key-marker))
    1213                 (setq first-deleted-index vector-index))))))))
     1297        (if (eq table-key free-hash-marker)
     1298          -1
     1299          (let* ((secondary-hash (%svref secondary-keys-*-2
     1300                                         (logand 7 hash-code)))
     1301                 (initial-index vector-index)
     1302                 (count (+ entries entries))
     1303                 (length (+ count $nhash.vector_overhead)))
     1304            (declare (fixnum secondary-hash initial-index count length))
     1305            (loop
     1306              (incf vector-index secondary-hash)
     1307              (when (>= vector-index length)
     1308                (decf vector-index count))
     1309              (setq table-key (%svref vector vector-index))
     1310              (when (= vector-index initial-index)
     1311                (return -1))
     1312              (if (eql table-key key)
     1313                (return vector-index)
     1314                (when (eq table-key free-hash-marker)
     1315                  (return -1))))))))
    12141316    (eq-hash-find hash key)))
    12151317
     
    12241326      (declare (fixnum hash-code entries vector-index))
    12251327      (if (or (eql key table-key)
    1226               (eq table-key free-hash-key-marker))
     1328              (eq table-key free-hash-marker))
    12271329        vector-index
    12281330        (let* ((secondary-hash (%svref secondary-keys-*-2
     
    12441346            (if (eql table-key key)
    12451347              (return vector-index)
    1246               (if (eq table-key free-hash-key-marker)
     1348              (if (eq table-key free-hash-marker)
    12471349                (return (or first-deleted-index vector-index))
    12481350                (if (and (null first-deleted-index)
     
    12501352                  (setq first-deleted-index vector-index))))))))
    12511353    (eq-hash-find-for-put hash key)))
    1252 
    1253 ;;; Rehash.  Caller should have exclusive access to the hash table
    1254 ;;; and have disabled interrupts.
    1255 (defun %rehash (hash)
    1256   (let* ((vector (nhash.vector hash))
    1257          (flags (nhash.vector.flags vector))         )
    1258     (setf (nhash.vector.flags vector)
    1259           (logand flags $nhash-clear-key-bits-mask))
    1260     (do-rehash hash)))
    1261 
    12621354
    12631355(defun %make-rehash-bits (hash &optional (size (nhash.vector-size (nhash.vector hash))))
     
    12701362    (fill (the simple-bit-vector rehash-bits) 0)))
    12711363
    1272 (defun do-rehash (hash)
     1364;;; Rehash.  Caller should have exclusive access to the hash table
     1365;;; and have disabled interrupts.
     1366(defun %rehash (hash)
    12731367  (let* ((vector (nhash.vector hash))
     1368         (flags (nhash.vector.flags vector))
    12741369         (vector-index (- $nhash.vector_overhead 2))
    12751370         (size (nhash.vector-size vector))
    12761371         (rehash-bits (%make-rehash-bits hash size))
    12771372         (index -1))
    1278     (declare (fixnum size index vector-index))   
    1279     (setf (nhash.vector.cache-key vector) (%unbound-marker)
     1373    (declare (fixnum size index vector-index))
     1374    (setf (nhash.vector.flags vector)
     1375          (logand flags $nhash-clear-key-bits-mask))
     1376    (setf (nhash.vector.cache-key vector) free-hash-marker
    12801377          (nhash.vector.cache-value vector) nil)
    12811378    (%set-does-not-need-rehashing hash)
     
    12871384               (deleted (eq key deleted-hash-key-marker)))
    12881385          (unless
    1289             (when (or deleted (eq key free-hash-key-marker))
     1386            (when (or deleted (eq key free-hash-marker))
    12901387              (if deleted  ; one less deleted entry
    12911388                (let ((count (1- (nhash.vector.deleted-count vector))))
     
    12961393                      (setf (nhash.vector.weak-deletions-count vector) 0)
    12971394                      (incf (nhash.vector.deleted-count vector) wdc)
    1298                       (decf (nhash.count hash) wdc)))
     1395                      (decf (nhash.vector.count vector) wdc)))
    12991396                  (incf (nhash.grow-threshold hash))
    13001397                  ;; Change deleted to free
    1301                   (setf (%svref vector vector-index) free-hash-key-marker)))
     1398                  (setf (%svref vector vector-index) free-hash-marker)))
    13021399              t)
    13031400            (let* ((last-index index)
     
    13161413                        (when first ; or (eq last-index index) ?
    13171414                          (setq first nil)
    1318                           (setf (%svref vector vector-index) free-hash-key-marker)
    1319                           (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-key-marker))
     1415                          (setf (%svref vector vector-index) free-hash-marker)
     1416                          (setf (%svref vector (the fixnum (1+ vector-index))) free-hash-marker))
    13201417                        (%set-hash-table-vector-key vector found-vector-index key)
    13211418                        (setf (%svref vector (the fixnum (1+ found-vector-index))) value)                       
    1322                         (when (or (eq newkey free-hash-key-marker)
     1419                        (when (or (eq newkey free-hash-marker)
    13231420                                  (setq deleted (eq newkey deleted-hash-key-marker)))
    13241421                          (when deleted
     
    13301427                                  (setf (nhash.vector.weak-deletions-count vector) 0)
    13311428                                  (incf (nhash.vector.deleted-count vector) wdc)
    1332                                   (decf (nhash.count hash) wdc)))
     1429                                  (decf (nhash.vector.count vector) wdc)))
    13331430                              (incf (nhash.grow-threshold hash))))
    13341431                          (return))
     
    13361433                          (cerror "Delete one of the entries." "Duplicate key: ~s in ~s ~s ~s ~s ~s"
    13371434                                  key hash value newvalue index found-index)                       
    1338                           (decf (nhash.count hash))
     1435                          (decf (nhash.vector.count vector))
    13391436                          (incf (nhash.grow-threshold hash))
    13401437                          (return))
     
    13761473           (vector-key nil))
    13771474      (declare (fixnum vector-index))
    1378       (if (or (eq free-hash-key-marker
     1475      (if (or (eq free-hash-marker
    13791476                  (setq vector-key (%svref vector vector-index)))
    13801477              (eq deleted-hash-key-marker vector-key))
     
    13861483            (when (>= index entries)
    13871484              (setq index (- index entries)))
    1388             (when (or (eq free-hash-key-marker
     1485            (when (or (eq free-hash-marker
    13891486                          (setq vector-key (%svref vector (index->vector-index index))))
    13901487                      (eq deleted-hash-key-marker vector-key))
     
    16631760
    16641761
    1665 (defun get-fwdnum (&optional hash)
    1666   (let* ((res (%get-fwdnum)))
    1667     (if hash
    1668       (setf (nhash.fixnum hash) res))
    1669     res))
    1670 
    1671 (defun gc-count (&optional hash)
    1672    (let ((res (%get-gc-count)))
    1673     (if hash
    1674       (setf (nhash.gc-count hash) res)
    1675       res)))
    1676 
    1677 
    16781762(defun %cons-nhash-vector (size &optional (flags 0))
    16791763  (declare (fixnum size))
    1680   (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector (%unbound-marker))))
     1764  (let* ((vector (%alloc-misc (+ (+ size size) $nhash.vector_overhead) target::subtag-hash-vector free-hash-marker)))
     1765    (%init-nhash-vector vector flags)
     1766    vector))
     1767
     1768(defun %init-nhash-vector (vector flags)
     1769  (let ((size (vector-index->index (uvsize vector))))
     1770    (declare (fixnum size))
    16811771    (setf (nhash.vector.link vector) 0
    16821772          (nhash.vector.flags vector) flags
     1773          (nhash.vector.gc-count vector) (%get-gc-count)
    16831774          (nhash.vector.free-alist vector) nil
    16841775          (nhash.vector.finalization-alist vector) nil
     
    16861777          (nhash.vector.hash vector) nil
    16871778          (nhash.vector.deleted-count vector) 0
    1688           (nhash.vector.cache-key vector) (%unbound-marker)
     1779          (nhash.vector.count vector) 0
     1780          (nhash.vector.cache-key vector) free-hash-marker
    16891781          (nhash.vector.cache-value vector) nil
    16901782          (nhash.vector.cache-idx vector) nil
    16911783          (nhash.vector.size vector) size
    1692           (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size))
    1693     vector))
     1784          (nhash.vector.size-reciprocal vector) (floor (ash 1 (- target::nbits-in-word target::fixnumshift)) size))))
    16941785
    16951786(defun assert-hash-table-readonly (hash)
     
    17411832            (setf (nhash.owner hash) *current-process*)))
    17421833      (progn
    1743         (write-lock-hash-table hash)
    1744         (setf (nhash.exclusion-lock hash) nil
    1745               (nhash.owner hash) *current-process*)
     1834        (unless (hash-lock-free-p hash)
     1835          (write-lock-hash-table hash)
     1836          (setf (nhash.exclusion-lock hash) nil))
     1837        (setf (nhash.owner hash) *current-process*)
    17461838        t))))
    17471839
    17481840 
    1749  
    1750 
    1751 
    1752 (defun enumerate-hash-keys (hash out)
    1753   (unless (typep hash 'hash-table)
    1754     (report-bad-arg hash 'hash-table))
    1755   (with-lock-context
    1756     (without-interrupts
    1757      (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
    1758        (do* ((in (nhash.vector hash))
    1759              (in-idx $nhash.vector_overhead (+ in-idx 2))
    1760              (insize (uvsize in))
    1761              (outsize (length out))
    1762              (out-idx 0))
    1763             ((or (= in-idx insize)
    1764                  (= out-idx outsize))
    1765              (unlock-hash-table hash readonly)
    1766              out-idx)
    1767          (declare (fixnum in-idx insize out-idx outsize))
    1768          (let* ((val (%svref in in-idx)))
    1769            (unless (or (eq val free-hash-key-marker)
    1770                        (eq val deleted-hash-key-marker))
    1771              (setf (%svref out out-idx) val)
    1772              (incf out-idx))))))))
     1841;; ** TODO: for lock-free hash tables, we don't need to copy,
     1842;; we could map over the actual hash table vector, because it's
     1843;; always valid.
     1844(defun lock-free-enumerate-hash-keys-and-values (hash keys values)
     1845  (do* ((in (nhash.vector hash))
     1846        (in-idx $nhash.vector_overhead (+ in-idx 2))
     1847        (insize (uvsize in))
     1848        (outsize (length (or keys values)))
     1849        (out-idx 0))
     1850       ((or (= in-idx insize)
     1851            (= out-idx outsize))
     1852        out-idx)
     1853    (declare (fixnum in-idx insize out-idx outsize))
     1854    (let* ((key (%svref in in-idx)))
     1855      (unless (eq key free-hash-marker)
     1856        (let ((val (%svref in (%i+ in-idx 1))))
     1857          (when (eq val rehashing-value-marker)
     1858            ;; This table is being rehashed.  Wait to finish and try again
     1859            (lock-free-rehash hash)
     1860            (return-from lock-free-enumerate-hash-keys-and-values
     1861                         (lock-free-enumerate-hash-keys-and-values hash keys values)))
     1862          (unless (eq val free-hash-marker)
     1863            (when keys (setf (%svref keys out-idx) key))
     1864            (when values (setf (%svref values out-idx) val))
     1865            (incf out-idx)))))))
    17731866
    17741867(defun enumerate-hash-keys-and-values (hash keys values)
    17751868  (unless (typep hash 'hash-table)
    17761869    (report-bad-arg hash 'hash-table))
     1870  (when (hash-lock-free-p hash)
     1871    (return-from enumerate-hash-keys-and-values
     1872                 (lock-free-enumerate-hash-keys-and-values hash keys values)))
    17771873  (with-lock-context
    1778     (without-interrupts
    1779      (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
    1780        (do* ((in (nhash.vector hash))
    1781              (in-idx $nhash.vector_overhead (+ in-idx 2))
    1782              (insize (uvsize in))
    1783              (outsize (length keys))
    1784              (out-idx 0))
    1785             ((or (= in-idx insize)
    1786                  (= out-idx outsize))
    1787              (unlock-hash-table hash readonly)
    1788              out-idx)
    1789          (declare (fixnum in-idx insize out-idx outsize))
    1790          (let* ((key (%svref in in-idx)))
    1791            (unless (or (eq key free-hash-key-marker)
    1792                        (eq key deleted-hash-key-marker))
    1793              (setf (%svref keys out-idx) key)
    1794              (setf (%svref values out-idx) (%svref in (the fixnum (1+ in-idx))))
    1795              (incf out-idx))))))))
     1874      (without-interrupts
     1875       (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
     1876         (do* ((in (nhash.vector hash))
     1877               (in-idx $nhash.vector_overhead (+ in-idx 2))
     1878               (insize (uvsize in))
     1879               (outsize (length (or keys values)))
     1880               (out-idx 0))
     1881              ((or (= in-idx insize)
     1882                   (= out-idx outsize))
     1883               (unlock-hash-table hash readonly)
     1884               out-idx)
     1885           (declare (fixnum in-idx insize out-idx outsize))
     1886           (let* ((key (%svref in in-idx)))
     1887             (unless (or (eq key free-hash-marker)
     1888                         (eq key deleted-hash-key-marker))
     1889               (when keys
     1890                 (setf (%svref keys out-idx) key))
     1891               (when values
     1892                 (setf (%svref values out-idx) (%svref in (%i+ in-idx 1))))
     1893               (incf out-idx))))))))
     1894 
     1895(defun enumerate-hash-keys (hash out)
     1896  (enumerate-hash-keys-and-values hash out nil))
  • trunk/source/lib/hash.lisp

    r10425 r10731  
    9898;; about followed by alternating keys and values.  Empty slots have a
    9999;; key of (%UNBOUND-MARKER), deleted slots are denoted by a key of
    100 ;; (%SLOT-UNBOUND-MARKER).
     100;; (%SLOT-UNBOUND-MARKER), except in the case of "lock-free" hash
     101;; tables, which see below.
    101102;;
    102103;; Four bits in the nhash.vector.flags fixnum interact with the garbage
     
    108109;; The 32 bits of the fixnum at nhash.vector.flags look like:
    109110;;
    110 ;;     TK0C0000 00000000 WVF00000 00000000
     111;;     TTTTKEC0 00000000 000WVFZ0 00000000
    111112;;
    112113;;
     
    139140;;                               the nhash.vector.finalization-alist using cons cells
    140141;;                               from nhash.vector.free-alist
     142;; $nhash_keys_frozen_bit       "Z" in diagram above.
     143;;                               If set, GC will remove weak entries by setting the
     144;;                               value to (%slot-unbound-marker), leaving key unchanged.
    141145
    142146(in-package "CCL")
     
    164168
    165169
     170#+vaporware
    166171;;; Of course, the lisp version of this would be too slow ...
    167172(defun hash-table-finalization-list (hash-table)
     
    175180      (error "~S is not a finalizeable hash table" hash-table))))
    176181
     182#+vaporware
    177183(defun (setf hash-table-finalization-list) (value hash-table)
    178184  (unless (hash-table-p hash-table)
     
    241247(defmethod make-load-form ((hash hash-table) &optional env)
    242248  (declare (ignore env))
    243   (let ((rehashF (function-name (nhash.rehashF hash)))
    244         (keytransF (nhash.keytransF hash))
     249  (%normalize-hash-table-count hash)
     250  (let ((keytransF (nhash.keytransF hash))
    245251        (compareF (nhash.compareF hash))
    246252        (vector (nhash.vector hash))
    247253        (private (if (nhash.owner hash) '*current-process*))
    248         (count (nhash.count hash)))
     254        (lock-free-p (logtest $nhash.lock-free (the fixnum (nhash.lock hash)))))
    249255    (flet ((convert (f)
    250256             (if (or (fixnump f) (symbolp f))
     
    253259      (values
    254260       `(%cons-hash-table
    255          nil nil nil nil ,(nhash.grow-threshold hash) ,(nhash.rehash-ratio hash) ,(nhash.rehash-size hash) ,(nhash.address-based hash) nil nil ,private)
    256        `(%initialize-hash-table ,hash ',rehashF ,(convert keytransF) ,(convert compareF)
    257                                 ',vector ,count)))))
     261         nil nil nil ,(nhash.grow-threshold hash) ,(nhash.rehash-ratio hash) ,(nhash.rehash-size hash)
     262        nil nil ,private ,lock-free-p)
     263       `(%initialize-hash-table ,hash ,(convert keytransF) ,(convert compareF) ',vector)))))
    258264
    259265(defun needs-rehashing (hash)
    260266  (%set-needs-rehashing hash))
    261267
    262 (defun %initialize-hash-table (hash rehashF keytransF compareF vector count)
    263   (setf (nhash.rehashF hash) (symbol-function rehashF)
    264         (nhash.keytransF hash) keytransF
    265         (nhash.compareF hash) compareF
    266         (nhash.vector hash) vector
    267         (nhash.count hash) count)
     268(defun %initialize-hash-table (hash keytransF compareF vector)
     269  (setf (nhash.keytransF hash) keytransF
     270        (nhash.compareF hash) compareF)
    268271  (setf (nhash.find hash)
    269272        (case comparef
     
    276279          (-1 #'eql-hash-find-for-put)
    277280          (t #'general-hash-find-for-put)))
     281  (setf (nhash.vector hash) vector)
    278282  (%set-needs-rehashing hash))
    279283
     
    290294   (let* ((lock (nhash.exclusion-lock hash-table)))
    291295     (if lock
    292        (write-lock-rwlock lock)
    293296       (progn
    294          (unless (eq (nhash.owner hash-table) *current-process*)
    295            (error "Current process doesn't own hash-table ~s" hash-table))))
    296      (push hash-table *fcomp-locked-hash-tables*))))
     297         (if (hash-lock-free-p hash-table)
     298           ;; For lock-free hash tables, this only makes sure nobody is
     299           ;; rehashing the table.  It doesn't necessarily stop readers
     300           ;; or writers (unless they need to rehash).
     301           (grab-lock lock)
     302           (write-lock-rwlock lock))
     303         (push hash-table *fcomp-locked-hash-tables*))
     304       (unless (eq (nhash.owner hash-table) *current-process*)
     305         (error "Current process doesn't own hash-table ~s" hash-table))))))
    297306
    298307(defun fasl-unlock-hash-tables ()
    299308  (dolist (h *fcomp-locked-hash-tables*)
    300309    (let* ((lock (nhash.exclusion-lock h)))
    301       (if lock (unlock-rwlock lock)))))
     310      (if (hash-lock-free-p h)
     311        (release-lock lock)
     312        (unlock-rwlock lock)))))
    302313
    303314
  • trunk/source/library/lispequ.lisp

    r10644 r10731  
    12451245(def-accessors (hash-table) %svref
    12461246    nil                                 ; 'HASH-TABLE
    1247     nhash.rehashF                       ; function: rehashes if necessary
    12481247    nhash.keytransF                     ; transform key into (values primary addressp)
    12491248    nhash.compareF                      ; comparison function: 0 -> eq, -1 ->eql, else function
    12501249    nhash.rehash-bits                   ; bitset (array (unsigned-byte 32)) for rehash
    12511250    nhash.vector                        ; N <key,value> pairs; n relatively prime to & larger than all secondary keys
    1252     nhash.lock                          ; fixnum: bits for grow and rehash
    1253     nhash.count                         ; Number of entries
     1251    nhash.lock                          ; flag: non-zero if lock-free
    12541252    nhash.owner                         ; tcr of "owning" thread, else NIL.
    1255     nhash.fixnum                        ; fwdnum kernel-global
    1256     nhash.gc-count                      ; gc-count kernel-global
    12571253    nhash.grow-threshold                ; Max # entries before grow
    12581254    nhash.rehash-ratio                  ; inverted rehash-threshold
     
    12601256    nhash.puthash-count                 ; number of times table has been rehashed or grown
    12611257    nhash.exclusion-lock                ; read-write lock for access
    1262     nhash.rehash-lock                   ; exclusive lock for rehash
    1263     nhash.iterator                      ; current hash-table iterator
    1264     nhash.address-based                 ; hashes based on address
    12651258    nhash.find                          ; function: find vector-index
    12661259    nhash.find-new                      ; function: find vector-index on put
  • trunk/source/lisp-kernel/gc-common.c

    r10173 r10731  
    218218  Boolean
    219219    weak_on_value = ((hashp->flags & nhash_weak_value_mask) != 0);
     220  Boolean
     221    keys_frozen = ((hashp->flags & nhash_keys_frozen_mask) != 0);
    220222  bitvector markbits = GCmarkbits;
    221223  int tag;
     
    232234      if ((dnode < GCndnodes_in_area) &&
    233235          ! ref_bit(markbits, dnode)) {
    234         pairp[0] = slot_unbound;
    235         pairp[1] = lisp_nil;
     236        if (keys_frozen) {
     237          if (pairp[1] != slot_unbound) {
     238            pairp[1] = unbound;
     239          }
     240        }
     241        else {
     242          pairp[0] = slot_unbound;
     243          pairp[1] = lisp_nil;
     244        }
    236245        hashp->weak_deletions_count += (1<<fixnumshift);
    237246      }
  • trunk/source/lisp-kernel/ppc-constants32.h

    r10010 r10731  
    325325  LispObj link;                 /* If weak */
    326326  LispObj flags;                /* a fixnum; see below */
     327  LispObj gc_count;             /* gc-count kernel global */
    327328  LispObj free_alist;           /* preallocated conses for finalization_alist */
    328329  LispObj finalization_alist;   /* key/value alist for finalization */
    329330  LispObj weak_deletions_count; /* incremented when GC deletes weak pair */
    330331  LispObj hash;                 /* backpointer to hash-table */
    331   LispObj deleted_count;        /* number of deleted entries */
     332  LispObj deleted_count;        /* number of deleted entries [not maintained if lock-free] */
     333  LispObj count;                /* number of valid entries [not maintained if lock-free] */
    332334  LispObj cache_idx;            /* index of last cached pair */
    333335  LispObj cache_key;            /* value of last cached key */
     
    356358#define nhash_finalizable_mask fixnum_bitmask(10)
    357359
     360/* keys frozen, i.e. don't clobber keys, only values */
     361#define nhash_keys_frozen_mask fixnum_bitmask(9)
    358362
    359363/* Lfun bits */
  • trunk/source/lisp-kernel/ppc-constants64.h

    r10010 r10731  
    304304  LispObj link;                 /* If weak */
    305305  LispObj flags;                /* a fixnum; see below */
     306  LispObj gc_count;             /* gc-count kernel global */
    306307  LispObj free_alist;           /* preallocated conses for finalization_alist */
    307308  LispObj finalization_alist;   /* key/value alist for finalization */
    308309  LispObj weak_deletions_count; /* incremented when GC deletes weak pair */
    309310  LispObj hash;                 /* backpointer to hash-table */
    310   LispObj deleted_count;        /* number of deleted entries */
     311  LispObj deleted_count;        /* number of deleted entries [not maintained if lock-free] */
     312  LispObj count;                /* number of valid entries [not maintained if lock-free] */
    311313  LispObj cache_idx;            /* index of last cached pair */
    312314  LispObj cache_key;            /* value of last cached key */
     
    335337#define nhash_finalizable_mask fixnum_bitmask(10)
    336338
     339/* keys frozen, i.e. don't clobber keys, only values */
     340#define nhash_keys_frozen_mask fixnum_bitmask(9)
    337341
    338342/* Lfun bits */
     
    343347#define lfbits_optinit_mask fixnum_bitmask(14)
    344348#define lfbits_rest_mask fixnum_bitmask(15)
     349
    345350#define lfbits_aok_mask fixnum_bitmask(16)
    346351#define lfbits_lap_mask fixnum_bitmask(23)
  • trunk/source/lisp-kernel/ppc-exceptions.c

    r10623 r10731  
    18361836  egc_gvset,
    18371837  egc_rplaca,
    1838   egc_rplacd;
     1838  egc_rplacd,
     1839  egc_set_hash_key_conditional,
     1840  egc_set_hash_key_conditional_test;
    18391841
    18401842
     
    18581860    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
    18591861
    1860     if (program_counter >= &egc_store_node_conditional) {
     1862    if (program_counter >= &egc_set_hash_key_conditional) {
     1863      if ((program_counter < &egc_set_hash_key_conditional_test) ||
     1864          ((program_counter == &egc_set_hash_key_conditional_test) &&
     1865           (! (xpCCR(xp) & 0x20000000)))) {
     1866        return;
     1867      }
     1868      need_store = false;
     1869      root = xpGPR(xp,arg_x);
     1870      ea = (LispObj *) (root+xpGPR(xp,arg_y)+misc_data_offset);
     1871      need_memoize_root = true;
     1872    } else if (program_counter >= &egc_store_node_conditional) {
    18611873      if ((program_counter < &egc_store_node_conditional_test) ||
    18621874          ((program_counter == &egc_store_node_conditional_test) &&
  • trunk/source/lisp-kernel/ppc-spentry.s

    r10623 r10731  
    615615   cr0[EQ] bit is set, then the conditional store succeeded and
    616616   we have to atomically memoize the possible intergenerational
    617    reference.  Note that the local labels 4 and 5 are at or beyond
    618   'egc_write_barrier_end'
     617   reference.  Note that the local labels 4 and 5 are in the
     618   body of the next subprim (and at or beyond 'egc_write_barrier_end').
    619619
    620620   N.B: it's not possible to really understand what's going on just
     
    628628_spentry(store_node_conditional)
    629629C(egc_store_node_conditional):
    630         __(crclr 2)              /* 2 = cr0_EQ  */
    631630        __(cmplr(cr2,arg_z,arg_x))
    632631        __(vpop(temp0))
     
    6346331:      __(lrarx(temp1,arg_x,imm4))
    635634        __(cmpr(cr1,temp1,arg_y))
    636         __(bne cr1,3f)
     635        __(bne cr1,5f)
    637636        __(strcx(arg_z,arg_x,imm4))
    638637        .globl C(egc_store_node_conditional_test)
     
    651650        __(srr(imm3,imm3,imm2))
    652651        __(ref_global(imm2,refbits))
    653         __(bge 5f)
     652        __(bge 4f)
    654653        __(slri(imm0,imm0,word_shift))
    6556542:      __(lrarx(imm1,imm2,imm0))
     
    658657        __(bne- 2b)
    659658        __(isync)
    660         __(b 5f)
     659        __(b 4f)
     660
     661/* arg_z = new value, arg_y = expected old value, arg_x = hash-vector,
     662   vsp[0] = (boxed) byte-offset
     663   Interrupt-related issues are as in store_node_conditional, but
     664   we have to do more work to actually do the memoization.*/
     665_spentry(set_hash_key_conditional)
     666        .globl C(egc_set_hash_key_conditional)
     667C(egc_set_hash_key_conditional):
     668        __(cmplr(cr2,arg_z,arg_x))
     669        __(vpop(imm4))
     670        __(unbox_fixnum(imm4,imm4))
     6711:      __(lrarx(temp1,arg_x,imm4))
     672        __(cmpr(cr1,temp1,arg_y))
     673        __(bne cr1,5f)
     674        __(strcx(arg_z,arg_x,imm4))
     675        .globl C(egc_set_hash_key_conditional_test)
     676C(egc_set_hash_key_conditional_test):   
     677        __(bne 1b)
     678        __(isync)
     679        __(add imm0,imm4,arg_x)
     680        __(ref_global(imm2,heap_start))
     681        __(ref_global(imm1,oldspace_dnode_count))
     682        __(sub imm0,imm0,imm2)
     683        __(load_highbit(imm3))
     684        __(srri(imm0,imm0,dnode_shift))
     685        __(cmplr(imm0,imm1))
     686        __(extract_bit_shift_count(imm2,imm0))
     687        __(srri(imm0,imm0,bitmap_shift))
     688        __(srr(imm3,imm3,imm2))
     689        __(ref_global(imm2,refbits))
     690        __(bge 4f)
     691        __(slri(imm0,imm0,word_shift))
     6922:      __(lrarx(imm1,imm2,imm0))
     693        __(or imm1,imm1,imm3)
     694        __(strcx(imm1,imm2,imm0))
     695        __(bne- 2b)
     696        __(isync)
     697        /* Memoize hash table header */         
     698        __(ref_global(imm1,heap_start))
     699        __(sub imm0,arg_x,imm1)
     700        __(srri(imm0,imm0,dnode_shift))
     701        __(load_highbit(imm3))
     702        __(extract_bit_shift_count(imm4,imm0))
     703        __(srri(imm0,imm0,bitmap_shift))
     704        __(srr(imm3,imm3,imm4))
     705        __(slri(imm0,imm0,word_shift))
     706        __(ldrx(imm1,imm2,imm0))
     707        __(and. imm1,imm1,imm3)
     708        __(bne 4f)
     7093:      __(lrarx(imm1,imm2,imm0))
     710        __(or imm1,imm1,imm3)
     711        __(strcx(imm1,imm2,imm0))
     712        __(bne- 3b)
     713        __(isync)
    661714C(egc_write_barrier_end):
    662 3:      __(li imm0,RESERVATION_DISCHARGE)
     7154:      __(li arg_z,t_value)
     716        __(blr)
     7175:      __(li imm0,RESERVATION_DISCHARGE)
    663718        __(strcx(rzero,0,imm0))
    664 4:      __(li arg_z,nil_value)
    665         __(blr)
    666 5:      __(li arg_z,t_value)
    667         __(blr)
    668 
    669        
     719        __(li arg_z,nil_value)
     720        __(blr)
     721       
     722       
     723               
    670724_spentry(conslist)
    671725        __(li arg_z,nil_value)
     
    68826936        __(b _SPbind_interrupt_level)
    68836937
    6884 _spentry(unused_6)
    6885          __(b _SPbreakpoint)
    6886                        
    68876938       
    68886939
  • trunk/source/lisp-kernel/ppc-spjump.s

    r6518 r10731  
    175175        _spjump(poweropen_ffcall_return_registers)
    176176        _spjump(nmkunwind)
    177         _spjump(unused_6)
     177        _spjump(set_hash_key_conditional)
    178178        _spjump(unbind_interrupt_level)
    179179        _spjump(unbind)
  • trunk/source/lisp-kernel/x86-constants32.h

    r10585 r10731  
    287287  LispObj link;                 /* If weak */
    288288  LispObj flags;                /* a fixnum; see below */
     289  LispObj gc_count;             /* gc-count kernel global */
    289290  LispObj free_alist;           /* preallocated conses for finalization_alist */
    290291  LispObj finalization_alist;   /* key/value alist for finalization */
    291292  LispObj weak_deletions_count; /* incremented when GC deletes weak pair */
    292293  LispObj hash;                 /* backpointer to hash-table */
    293   LispObj deleted_count;        /* number of deleted entries */
     294  LispObj deleted_count;        /* number of deleted entries [not maintained if lock-free] */
     295  LispObj count;                /* number of valid entries [not maintained if lock-free] */
    294296  LispObj cache_idx;            /* index of last cached pair */
    295297  LispObj cache_key;            /* value of last cached key */
     
    318320#define nhash_finalizable_mask fixnum_bitmask(10)
    319321
     322/* keys frozen, i.e. don't clobber keys, only values */
     323#define nhash_keys_frozen_mask fixnum_bitmask(9)
    320324
    321325/* Lfun bits */
  • trunk/source/lisp-kernel/x86-constants64.h

    r10597 r10731  
    384384  LispObj link;                 /* If weak */
    385385  LispObj flags;                /* a fixnum; see below */
     386  LispObj gc_count;             /* gc-count kernel global */
    386387  LispObj free_alist;           /* preallocated conses for finalization_alist */
    387388  LispObj finalization_alist;   /* key/value alist for finalization */
    388389  LispObj weak_deletions_count; /* incremented when GC deletes weak pair */
    389390  LispObj hash;                 /* backpointer to hash-table */
    390   LispObj deleted_count;        /* number of deleted entries */
     391  LispObj deleted_count;        /* number of deleted entries [not maintained if lock-free] */
     392  LispObj count;                /* number of valid entries [not maintained if lock-free] */
    391393  LispObj cache_idx;            /* index of last cached pair */
    392394  LispObj cache_key;            /* value of last cached key */
     
    415417#define nhash_finalizable_mask fixnum_bitmask(10)
    416418
     419/* keys frozen, i.e. don't clobber keys, only values */
     420#define nhash_keys_frozen_mask fixnum_bitmask(9)
    417421
    418422/* Lfun bits */
  • trunk/source/lisp-kernel/x86-exceptions.c

    r10717 r10731  
    20572057
    20582058extern opcode egc_write_barrier_start, egc_write_barrier_end,
     2059  egc_set_hash_key_conditional, egc_set_hash_key_conditional_success_test,
     2060  egc_store_node_conditional_success_end,
    20592061  egc_store_node_conditional_success_test,egc_store_node_conditional,
    20602062  egc_set_hash_key, egc_gvset, egc_rplacd;
     
    22792281    Boolean need_store = true, need_check_memo = true, need_memoize_root = false;
    22802282
    2281     if (program_counter >= &egc_store_node_conditional) {
     2283    if (program_counter >= &egc_set_hash_key_conditional) {
     2284      if ((program_counter < &egc_set_hash_key_conditional_success_test) ||
     2285          ((program_counter == &egc_set_hash_key_conditional_success_test) &&
     2286           !(eflags_register(xp) & (1 << X86_ZERO_FLAG_BIT)))) {
     2287        /* Back up the PC, try again */
     2288        xpPC(xp) = (LispObj) &egc_set_hash_key_conditional;
     2289        return;
     2290      }
     2291      /* The conditional store succeeded.  Set the refbit, return to ra0 */
     2292      val = xpGPR(xp,Iarg_z);
     2293#ifdef X8664
     2294      root = xpGPR(xp,Iarg_x);
     2295      ea = (LispObj*)(root + (unbox_fixnum((signed_natural) xpGPR(xp,Itemp0))));
     2296#else
     2297      root = xpGPR(xp,Itemp1);
     2298      ea = (LispObj *)(root + misc_data_offset + xpGPR(xp,Itemp0));
     2299#endif
     2300      need_memoize_root = true;
     2301      need_store = false;
     2302      xpGPR(xp,Iarg_z) = t_value;
     2303    } else if (program_counter >= &egc_store_node_conditional) {
    22822304      if ((program_counter < &egc_store_node_conditional_success_test) ||
    22832305          ((program_counter == &egc_store_node_conditional_success_test) &&
     
    22872309        return;
    22882310      }
     2311      if (program_counter >= &egc_store_node_conditional_success_end) {
     2312        return;
     2313      }
     2314
    22892315      /* The conditional store succeeded.  Set the refbit, return to ra0 */
    22902316      val = xpGPR(xp,Iarg_z);
  • trunk/source/lisp-kernel/x86-spentry32.s

    r10583 r10731  
    18071807        __(lock)
    18081808        __(btsl %imm0,(%temp1))
     1809        .globl C(egc_store_node_conditional_success_end)
     1810C(egc_store_node_conditional_success_end):
     18112:      __(movl $t_value,%arg_z)
     1812        __(ret)
     18133:      __(movl $nil_value,%arg_z)
     1814        __(ret)
     1815_endsubp(store_node_conditional)
     1816
     1817        /* %temp0 = offset, %temp1 = object, %arg_y = old, %arg_z = new */
     1818_spentry(set_hash_key_conditional)
     1819        .globl C(egc_set_hash_key_conditional)
     1820C(egc_set_hash_key_conditional):
     1821        __(subl $misc_data_offset*fixnumone,%temp0) /* undo pre-added offset */
     1822        __(sarl $fixnumshift,%temp0)    /* will be fixnum-tagged */
     18230:      __(cmpl %arg_y,misc_data_offset(%temp1,%temp0))
     1824        __(movl misc_data_offset(%temp1,%temp0),%imm0)
     1825        __(jne 3f)
     1826        __(lock)
     1827        __(cmpxchgl %arg_z,misc_data_offset(%temp1,%temp0))
     1828        .globl C(egc_set_hash_key_conditional_success_test)
     1829C(egc_set_hash_key_conditional_success_test):
     1830        __(jne 0b)
     1831        __(leal misc_data_offset(%temp1,%temp0),%imm0)
     1832        __(subl lisp_global(heap_start),%imm0)
     1833        __(shrl $dnode_shift,%imm0)
     1834        __(cmpl lisp_global(oldspace_dnode_count),%imm0)
     1835        __(jae 2f)
     1836        __(ref_global(refbits,%temp0))
     1837        __(xorb $31,%imm0_b)
     1838        __(lock)
     1839        __(btsl %imm0,(%temp0))
     1840        /* Now memoize the address of the hash vector */
     1841        __(movl %temp1,%imm0)
     1842        __(subl lisp_global(heap_start),%imm0)
     1843        __(shrl $dnode_shift,%imm0)
     1844        __(xorb $31,%imm0_b)
     1845        __(lock)
     1846        __(btsl %imm0,(%temp0))
    18091847        .globl C(egc_write_barrier_end)
    18101848C(egc_write_barrier_end):
     
    45974635_spentry(unused_6)
    45984636        __(int $3)
    4599 Xspentry_end:           
     4637Xspentry_end:
    46004638_endsubp(unused_6)
    46014639        .data
  • trunk/source/lisp-kernel/x86-spentry64.s

    r10676 r10731  
    18791879        __(lock)
    18801880        __(btsq %imm0,(%temp1))
     1881        .globl C(egc_store_node_conditional_success_end)
     1882C(egc_store_node_conditional_success_end):
     18832:      __(movl $t_value,%arg_z_l)
     1884        __(ret)
     18853:      __(movl $nil_value,%arg_z_l)
     1886        __(ret)
     1887_endsubp(store_node_conditional)
     1888                               
     1889        _spentry(set_hash_key_conditional)
     1890        .globl C(egc_set_hash_key_conditional)
     1891C(egc_set_hash_key_conditional):
     1892        __(unbox_fixnum(%temp0,%imm1))
     18930:      __(movq (%arg_x,%imm1),%temp1)
     1894        __(cmpq %arg_y,%temp1)
     1895        __(movq %temp1,%imm0)
     1896        __(jne 3f)
     1897        __(lock)
     1898        __(cmpxchgq %arg_z,(%arg_x,%imm1))
     1899        .globl C(egc_set_hash_key_conditional_success_test)
     1900C(egc_set_hash_key_conditional_success_test):
     1901        __(jne 0b)
     1902        __(lea (%arg_x,%imm1),%imm0)
     1903        __(subq lisp_global(heap_start),%imm0)
     1904        __(shrq $dnode_shift,%imm0)
     1905        __(cmpq lisp_global(oldspace_dnode_count),%imm0)
     1906        __(ref_global(refbits,%temp1))
     1907        __(jae 2f)
     1908        __(xorb $63,%imm0_b)
     1909        __(lock)
     1910        __(btsq %imm0,(%temp1))
     1911        /* Now memoize the address of the hash vector   */
     1912        __(movq %arg_x,%imm0)
     1913        __(subq lisp_global(heap_start),%imm0)
     1914        __(shrq $dnode_shift,%imm0)
     1915        __(xorb $63,%imm0_b)
     1916        __(lock)
     1917        __(btsq %imm0,(%temp1))
    18811918        .globl C(egc_write_barrier_end)
    18821919C(egc_write_barrier_end):
     
    188519223:      __(movl $nil_value,%arg_z_l)
    18861923        __(ret)
    1887 _endsubp(store_node_conditional)
    1888                                
     1924_endsubp(set_hash_key_conditional)
     1925
     1926       
     1927
     1928
    18891929_spentry(setqsym)
    18901930        __(btq $sym_vbit_const,symbol.flags(%arg_y))
     
    50325072_endsubp(breakpoint)
    50335073
    5034                
    5035 
    5036 
    5037 _spentry(unused_5)
    5038         __(int $3)
    5039 _endsubp(unused_5)
    5040 
    50415074
    50425075        __ifdef([DARWIN])
     
    51195152        __endif
    51205153       
    5121 _spentry(unused_6)
     5154_spentry(unused_5)
    51225155        __(int $3)
    51235156Xspentry_end:           
    5124 _endsubp(unused_6)
     5157_endsubp(unused_5)
    51255158       
    51265159        .data
  • trunk/source/lisp-kernel/x86-spjump32.s

    r10088 r10731  
    173173        _spjump(ffcall_return_registers)
    174174        _spjump(aset1)
    175         _spjump(unused_6)
     175        _spjump(set_hash_key_conditional)
    176176        _spjump(unbind_interrupt_level)
    177177        _spjump(unbind)
  • trunk/source/lisp-kernel/x86-spjump64.s

    r6530 r10731  
    173173        _spjump(ffcall_return_registers)
    174174        _spjump(unused_5)
    175         _spjump(unused_6)
     175        _spjump(set_hash_key_conditional)
    176176        _spjump(unbind_interrupt_level)
    177177        _spjump(unbind)
  • trunk/source/xdump/faslenv.lisp

    r10323 r10731  
    4343(defconstant $fasl-file-id #xff00)
    4444(defconstant $fasl-file-id1 #xff01)
    45 (defconstant $fasl-vers #x53)
    46 (defconstant $fasl-min-vers #x53)
     45(defconstant $fasl-vers #x54)
     46(defconstant $fasl-min-vers #x54)
    4747(defconstant $faslend #xff)
    4848(defconstant $fasl-buf-len 2048)
  • trunk/source/xdump/hashenv.lisp

    r10268 r10731  
    2525
    2626
    27 ;;; undistinguished values of nhash.lock
    28 (defconstant $nhash.lock-while-growing #x10000)
    29 (defconstant $nhash.lock-while-rehashing #x20000)
    30 (defconstant $nhash.lock-grow-or-rehash #x30000)
    31 (defconstant $nhash.lock-map-count-mask #xffff)
    32 (defconstant $nhash.lock-not-while-rehashing #x-20001)
     27(defconstant $nhash.lock-free #x80000)
    3328
    3429; The hash.vector cell contains a vector with some longwords of overhead
    3530; followed by alternating keys and values.
    36 ; A key of $undefined denotes an empty or deleted value
    37 ; The value will be $undefined for empty values, or NIL for deleted values.
    3831;; If you change anything here, also update the kernel def in XXX-constantsNN.h
    3932(def-accessors () %svref
    4033  nhash.vector.link                     ; GC link for weak vectors
    4134  nhash.vector.flags                    ; a fixnum of flags
     35  nhash.vector.gc-count                 ; gc-count kernel global
    4236  nhash.vector.free-alist               ; empty alist entries for finalization
    4337  nhash.vector.finalization-alist       ; deleted out key/value pairs put here
    4438  nhash.vector.weak-deletions-count     ; incremented when the GC deletes an element
    4539  nhash.vector.hash                     ; back-pointer
    46   nhash.vector.deleted-count            ; number of deleted entries
     40  nhash.vector.deleted-count            ; number of deleted entries [not maintained if lock-free]
     41  nhash.vector.count                    ; number of valid entries [not maintained if lock-free]
    4742  nhash.vector.cache-idx                ; index of last cached key/value pair
    4843  nhash.vector.cache-key                ; cached key
     
    5550; number of longwords of overhead in nhash.vector.
    5651; Must be a multiple of 2 or INDEX parameters in LAP code will not be tagged as fixnums.
    57 (defconstant $nhash.vector_overhead 12)
     52(defconstant $nhash.vector_overhead 14)
    5853
    5954(defconstant $nhash_weak_bit 12)        ; weak hash table
    6055(defconstant $nhash_weak_value_bit 11)  ; weak on value vice key if this bit set
    6156(defconstant $nhash_finalizeable_bit 10)
     57(defconstant $nhash_keys_frozen_bit 9)  ; GC must not change key slots when deleting
    6258(defconstant $nhash_weak_flags_mask
    63   (bitset $nhash_weak_bit (bitset $nhash_weak_value_bit (bitset $nhash_finalizeable_bit 0))))
     59  (bitset $nhash_keys_frozen_bit (bitset $nhash_weak_bit (bitset $nhash_weak_value_bit (bitset $nhash_finalizeable_bit 0)))))
     60
    6461
    6562(defconstant $nhash_track_keys_bit 28)  ; request GC to track relocation of keys.
     
    6865                                        ; in ephemeral space
    6966(defconstant $nhash_component_address_bit 25) ; a hash code was computed from a key's component
     67
    7068
    7169
Note: See TracChangeset for help on using the changeset viewer.