Changeset 7679


Ignore:
Timestamp:
Nov 19, 2007, 7:57:02 AM (12 years ago)
Author:
gb
Message:

Use WITH-LOCK-CONTEXT. Define ENUMERATE-HASH-KEYS.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0711/ccl/level-0/l0-hash.lisp

    r7624 r7679  
    612612  (unless (hash-table-p hash)
    613613    (report-bad-arg hash 'hash-table))
     614  (with-lock-context
    614615  (without-interrupts
    615616   (lock-hash-table hash t)
     
    635636                                               (nhash.vector.flags vector))))
    636637   (unlock-hash-table hash nil)
    637    hash))
     638   hash)))
    638639
    639640(defun index->vector-index (index)
     
    700701         (readonly nil)
    701702         (foundp nil))
    702     (without-interrupts
    703      (setq readonly (eq (lock-hash-table hash nil) :readonly))
    704      (let* ((vector (nhash.vector hash)))
    705        (if (and (eq key (nhash.vector.cache-key vector))
    706                 ;; Check twice: the GC might nuke the cached key/value pair
    707                 (progn (setq value (nhash.vector.cache-value vector))
    708                        (eq key (nhash.vector.cache-key vector))))
    709          (setq foundp t)
    710          (loop
    711            (let* ((vector-index (funcall (nhash.find hash) hash key)))
    712              (declare (fixnum vector-index))
    713              ;; Referencing both key and value here - and referencing
    714              ;; value first - is an attempt to compensate for the
    715              ;; possibility that the GC deletes a weak-on-key pair.
    716              (setq value (%svref vector (the fixnum (1+ vector-index)))
    717                    vector-key (%svref vector vector-index))
    718              (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
    719                                       (not (eq vector-key deleted-hash-key-marker))))
    720                     #+no
    721                     (setf (nhash.vector.cache-key vector) vector-key
    722                           (nhash.vector.cache-value vector) value
    723                           (nhash.vector.cache-idx vector) (vector-index->index
    724                                                            vector-index))
    725                     (return))
    726                ((%needs-rehashing-p hash)
    727                 (setq gc-locked t)
    728                 (%lock-gc-lock)
    729                 (%rehash hash))
    730                (t (return)))))))
    731      (when gc-locked (%unlock-gc-lock))
    732      (unlock-hash-table hash readonly))
     703    (with-lock-context
     704      (without-interrupts
     705       (setq readonly (eq (lock-hash-table hash nil) :readonly))
     706       (let* ((vector (nhash.vector hash)))
     707         (if (and (eq key (nhash.vector.cache-key vector))
     708                  ;; Check twice: the GC might nuke the cached key/value pair
     709                  (progn (setq value (nhash.vector.cache-value vector))
     710                         (eq key (nhash.vector.cache-key vector))))
     711           (setq foundp t)
     712           (loop
     713             (let* ((vector-index (funcall (nhash.find hash) hash key)))
     714               (declare (fixnum vector-index))
     715               ;; Referencing both key and value here - and referencing
     716               ;; value first - is an attempt to compensate for the
     717               ;; possibility that the GC deletes a weak-on-key pair.
     718               (setq value (%svref vector (the fixnum (1+ vector-index)))
     719                     vector-key (%svref vector vector-index))
     720               (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
     721                                        (not (eq vector-key deleted-hash-key-marker))))
     722                      #+no
     723                      (setf (nhash.vector.cache-key vector) vector-key
     724                            (nhash.vector.cache-value vector) value
     725                            (nhash.vector.cache-idx vector) (vector-index->index
     726                                                             vector-index))
     727                      (return))
     728                     ((%needs-rehashing-p hash)
     729                      (setq gc-locked t)
     730                      (%lock-gc-lock)
     731                      (%rehash hash))
     732                     (t (return)))))))
     733       (when gc-locked (%unlock-gc-lock))
     734       (unlock-hash-table hash readonly)))
    733735    (if foundp
    734736      (values value t)
     
    741743    (setq hash (require-type hash 'hash-table)))
    742744  (let* ((foundp nil))
    743     (without-interrupts
    744      (lock-hash-table hash t)
    745      (%lock-gc-lock)
    746      (when (%needs-rehashing-p hash)
    747        (%rehash hash))   
    748      (let* ((vector (nhash.vector hash)))
    749        (if (eq key (nhash.vector.cache-key vector))
    750          (progn
    751            (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
    752                 ((null iterator))
    753              (unless (= (the fixnum (hti.index iterator))
    754                         (the fixnum (nhash.vector.cache-idx vector)))
    755                (unlock-hash-table hash nil)
    756                (%unlock-gc-lock)
    757                (error "Can't remove key ~s during iteration on hash-table ~s"
    758                       key hash)))
    759            (setf (nhash.vector.cache-key vector) free-hash-key-marker
    760                  (nhash.vector.cache-value vector) nil)
    761            (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
    762              (setf (%svref vector vidx) deleted-hash-key-marker)
    763              (setf (%svref vector (the fixnum (1+ vidx))) nil))
    764            (incf (the fixnum (nhash.vector.deleted-count vector)))
    765            (decf (the fixnum (nhash.count hash)))
    766            (setq foundp t))
    767          (let* ((vector-index (funcall (nhash.find hash) hash key))
    768                 (vector-key (%svref vector vector-index)))
    769            (declare (fixnum vector-index))
    770            (when (setq foundp (and (not (eq vector-key free-hash-key-marker))
    771                                    (not (eq vector-key deleted-hash-key-marker))))
     745    (with-lock-context
     746      (without-interrupts
     747       (lock-hash-table hash t)
     748       (%lock-gc-lock)
     749       (when (%needs-rehashing-p hash)
     750         (%rehash hash))   
     751       (let* ((vector (nhash.vector hash)))
     752         (if (eq key (nhash.vector.cache-key vector))
     753           (progn
    772754             (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
    773755                  ((null iterator))
    774756               (unless (= (the fixnum (hti.index iterator))
    775                           (the fixnum (vector-index->index vector-index)))
     757                          (the fixnum (nhash.vector.cache-idx vector)))
    776758                 (unlock-hash-table hash nil)
    777759                 (%unlock-gc-lock)
    778760                 (error "Can't remove key ~s during iteration on hash-table ~s"
    779761                        key hash)))
    780              ;; always clear the cache cause I'm too lazy to call the
    781              ;; comparison function and don't want to keep a possibly
    782              ;; deleted key from being GC'd
    783762             (setf (nhash.vector.cache-key vector) free-hash-key-marker
    784763                   (nhash.vector.cache-value vector) nil)
    785              ;; Update the count
     764             (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
     765               (setf (%svref vector vidx) deleted-hash-key-marker)
     766               (setf (%svref vector (the fixnum (1+ vidx))) nil))
    786767             (incf (the fixnum (nhash.vector.deleted-count vector)))
    787768             (decf (the fixnum (nhash.count hash)))
    788              ;; Remove a cons from the free-alist if the table is finalizeable
    789              (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector))
    790                (pop (the list (svref nhash.vector.free-alist vector))))
    791              ;; Delete the value from the table.
    792              (setf (%svref vector vector-index) deleted-hash-key-marker
    793                    (%svref vector (the fixnum (1+ vector-index))) nil))))
    794        (when (and foundp
    795                 (zerop (the fixnum (nhash.count hash))))
    796          (do* ((i $nhash.vector_overhead (1+ i))
    797                (n (uvsize vector)))
    798               ((= i n))
    799            (declare (fixnum i n))
    800            (setf (%svref vector i) free-hash-key-marker))
    801          (setf (nhash.grow-threshold hash)
    802                (+ (nhash.vector.deleted-count vector)
    803                   (nhash.vector.weak-deletions-count vector)
    804                   (nhash.grow-threshold hash))
    805                (nhash.vector.deleted-count vector) 0
    806                (nhash.vector.weak-deletions-count vector) 0)))
    807      ;; Return T if we deleted something
    808      (%unlock-gc-lock)
    809      (unlock-hash-table hash nil))
     769             (setq foundp t))
     770           (let* ((vector-index (funcall (nhash.find hash) hash key))
     771                  (vector-key (%svref vector vector-index)))
     772             (declare (fixnum vector-index))
     773             (when (setq foundp (and (not (eq vector-key free-hash-key-marker))
     774                                     (not (eq vector-key deleted-hash-key-marker))))
     775               (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
     776                    ((null iterator))
     777                 (unless (= (the fixnum (hti.index iterator))
     778                            (the fixnum (vector-index->index vector-index)))
     779                   (unlock-hash-table hash nil)
     780                   (%unlock-gc-lock)
     781                   (error "Can't remove key ~s during iteration on hash-table ~s"
     782                          key hash)))
     783               ;; always clear the cache cause I'm too lazy to call the
     784               ;; comparison function and don't want to keep a possibly
     785               ;; deleted key from being GC'd
     786               (setf (nhash.vector.cache-key vector) free-hash-key-marker
     787                     (nhash.vector.cache-value vector) nil)
     788               ;; Update the count
     789               (incf (the fixnum (nhash.vector.deleted-count vector)))
     790               (decf (the fixnum (nhash.count hash)))
     791               ;; Remove a cons from the free-alist if the table is finalizeable
     792               (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector))
     793                 (pop (the list (svref nhash.vector.free-alist vector))))
     794               ;; Delete the value from the table.
     795               (setf (%svref vector vector-index) deleted-hash-key-marker
     796                     (%svref vector (the fixnum (1+ vector-index))) nil))))
     797         (when (and foundp
     798                    (zerop (the fixnum (nhash.count hash))))
     799           (do* ((i $nhash.vector_overhead (1+ i))
     800                 (n (uvsize vector)))
     801                ((= i n))
     802             (declare (fixnum i n))
     803             (setf (%svref vector i) free-hash-key-marker))
     804           (setf (nhash.grow-threshold hash)
     805                 (+ (nhash.vector.deleted-count vector)
     806                    (nhash.vector.weak-deletions-count vector)
     807                    (nhash.grow-threshold hash))
     808                 (nhash.vector.deleted-count vector) 0
     809                 (nhash.vector.weak-deletions-count vector) 0)))
     810       ;; Return T if we deleted something
     811       (%unlock-gc-lock)
     812       (unlock-hash-table hash nil)))
    810813    foundp))
    811814
     
    814817  (unless (hash-table-p hash)
    815818    (report-bad-arg hash 'hash-table))
    816   (without-interrupts
    817    (block protected
    818      (tagbody
    819         (lock-hash-table hash t)
     819  (with-lock-context
     820    (without-interrupts
     821     (block protected
     822       (tagbody
     823          (lock-hash-table hash t)
    820824        AGAIN
    821         (%lock-gc-lock)
    822         (when (%needs-rehashing-p hash)
    823           (%rehash hash))
    824         (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
    825              ((null iterator))
    826           (let* ((vector (hti.vector iterator))
    827                  (index (index->vector-index (hti.index iterator)))
    828                  (test (hash-table-test hash)))
    829             (declare (fixnum index))
    830             (when (and (< index (the fixnum (uvsize vector)))
    831                        (not (funcall test (%svref vector index) key)))
    832               (unlock-hash-table hash nil)
    833               (%unlock-gc-lock)
    834               (error "Can't add key ~s during iteration on hash-table ~s"
    835                      key hash))))
    836         (let ((vector (nhash.vector  hash)))     
    837           (when (eq key (nhash.vector.cache-key vector))
    838             (let* ((idx (nhash.vector.cache-idx vector)))
    839               (declare (fixnum idx))
    840               (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
    841                     value)
    842               (setf (nhash.vector.cache-value vector) value)
    843               (return-from protected)))               
    844           (let* ((vector-index (funcall (nhash.find-new hash) hash key))
    845                  (old-value (%svref vector vector-index)))
    846             (declare (fixnum vector-index))
    847 
    848             (cond ((eq old-value deleted-hash-key-marker)
    849                    (%set-hash-table-vector-key vector vector-index key)
    850                    (setf (%svref vector (the fixnum (1+ vector-index))) value)
    851                    (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
    852                    ;; Adjust deleted-count
    853                    (when (> 0 (the fixnum
    854                                 (decf (the fixnum
    855                                         (nhash.vector.deleted-count vector)))))
    856                      (let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
    857                        (declare (fixnum weak-deletions))
    858                        (setf (nhash.vector.weak-deletions-count vector) 0)
    859                        (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
    860                        (decf (the fixnum (nhash.count hash)) weak-deletions))))
    861                   ((eq old-value free-hash-key-marker)
    862                    (when (eql 0 (nhash.grow-threshold hash))
    863                      (%unlock-gc-lock)
    864                      (grow-hash-table hash)
    865                      (go AGAIN))
    866                    (%set-hash-table-vector-key vector vector-index key)
    867                    (setf (%svref vector (the fixnum (1+ vector-index))) value)
    868                    (decf (the fixnum (nhash.grow-threshold hash)))
    869                    (incf (the fixnum (nhash.count hash))))
    870                   (t
    871                    ;; Key was already there, update value.
    872                    (setf (%svref vector (the fixnum (1+ vector-index))) value)))
    873             (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
    874                   (nhash.vector.cache-key vector) key
    875                   (nhash.vector.cache-value vector) value)))))
    876    (%unlock-gc-lock)
    877    (unlock-hash-table hash nil))
     825          (%lock-gc-lock)
     826          (when (%needs-rehashing-p hash)
     827            (%rehash hash))
     828          (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
     829               ((null iterator))
     830            (let* ((vector (hti.vector iterator))
     831                   (index (index->vector-index (hti.index iterator)))
     832                   (test (hash-table-test hash)))
     833              (declare (fixnum index))
     834              (when (and (< index (the fixnum (uvsize vector)))
     835                         (not (funcall test (%svref vector index) key)))
     836                (unlock-hash-table hash nil)
     837                (%unlock-gc-lock)
     838                (error "Can't add key ~s during iteration on hash-table ~s"
     839                       key hash))))
     840          (let ((vector (nhash.vector  hash)))     
     841            (when (eq key (nhash.vector.cache-key vector))
     842              (let* ((idx (nhash.vector.cache-idx vector)))
     843                (declare (fixnum idx))
     844                (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
     845                      value)
     846                (setf (nhash.vector.cache-value vector) value)
     847                (return-from protected)))               
     848            (let* ((vector-index (funcall (nhash.find-new hash) hash key))
     849                   (old-value (%svref vector vector-index)))
     850              (declare (fixnum vector-index))
     851
     852              (cond ((eq old-value deleted-hash-key-marker)
     853                     (%set-hash-table-vector-key vector vector-index key)
     854                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
     855                     (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
     856                     ;; Adjust deleted-count
     857                     (when (> 0 (the fixnum
     858                                  (decf (the fixnum
     859                                          (nhash.vector.deleted-count vector)))))
     860                       (let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
     861                         (declare (fixnum weak-deletions))
     862                         (setf (nhash.vector.weak-deletions-count vector) 0)
     863                         (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
     864                         (decf (the fixnum (nhash.count hash)) weak-deletions))))
     865                    ((eq old-value free-hash-key-marker)
     866                     (when (eql 0 (nhash.grow-threshold hash))
     867                       (%unlock-gc-lock)
     868                       (grow-hash-table hash)
     869                       (go AGAIN))
     870                     (%set-hash-table-vector-key vector vector-index key)
     871                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
     872                     (decf (the fixnum (nhash.grow-threshold hash)))
     873                     (incf (the fixnum (nhash.count hash))))
     874                    (t
     875                     ;; Key was already there, update value.
     876                     (setf (%svref vector (the fixnum (1+ vector-index))) value)))
     877              (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
     878                    (nhash.vector.cache-key vector) key
     879                    (nhash.vector.cache-value vector) value)))))
     880     (%unlock-gc-lock)
     881     (unlock-hash-table hash nil)))
    878882  value)
    879883
     
    17091713    (report-bad-arg hash 'hash-table))
    17101714  (or (nhash.read-only hash)
    1711       (without-interrupts
    1712        (lock-hash-table hash t)
    1713        (let* ((flags (nhash.vector.flags (nhash.vector hash))))
    1714          (declare (fixnum flags))
    1715          (when (or (logbitp $nhash_track_keys_bit flags)
    1716                    (logbitp $nhash_component_address_bit flags))
    1717            (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
     1715      (with-lock-context
     1716        (without-interrupts
     1717         (lock-hash-table hash t)
     1718         (let* ((flags (nhash.vector.flags (nhash.vector hash))))
     1719           (declare (fixnum flags))
     1720           (when (or (logbitp $nhash_track_keys_bit flags)
     1721                     (logbitp $nhash_component_address_bit flags))
     1722             (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
     1723             (unlock-hash-table hash nil)
     1724             (return-from assert-hash-table-readonly nil))
     1725           (setf (nhash.read-only hash) t)
    17181726           (unlock-hash-table hash nil)
    1719            (return-from assert-hash-table-readonly nil))
    1720          (setf (nhash.read-only hash) t)
    1721          (unlock-hash-table hash nil)
    1722          t))))
     1727           t)))))
    17231728
    17241729;; This is dangerous, if multiple threads are accessing a read-only
     
    17351740    (report-bad-arg hash 'hash-table))
    17361741  (nhash.read-only hash))
     1742
     1743(defun enumerate-hash-keys (hash out)
     1744  (unless (hash-table-p hash)
     1745    (report-bad-arg hash 'hash-table))
     1746  (with-lock-context
     1747    (without-interrupts
     1748     (let* ((readonly (eq (lock-hash-table hash nil) :readonly)))
     1749       (do* ((in (nhash.vector hash))
     1750             (in-idx $nhash.vector_overhead (+ in-idx 2))
     1751             (insize (uvsize in))
     1752             (outsize (length out))
     1753             (out-idx 0))
     1754            ((or (= in-idx insize)
     1755                 (= out-idx outsize))
     1756             (unlock-hash-table hash readonly)
     1757             out-idx)
     1758         (declare (fixnum in-idx insize out-idx outsize))
     1759         (let* ((val (%svref in in-idx)))
     1760           (unless (or (eq val free-hash-key-marker)
     1761                       (eq val deleted-hash-key-marker))
     1762             (setf (%svref out out-idx) val)
     1763             (incf out-idx))))))))
     1764 
Note: See TracChangeset for help on using the changeset viewer.