Changeset 7688


Ignore:
Timestamp:
Nov 20, 2007, 3:02:44 PM (12 years ago)
Author:
gb
Message:

New locking/lock-tracking stuff; new MAPHASH interface.

File:
1 edited

Legend:

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

    r7511 r7688  
    160160  (declaim (inline compute-hash-code))
    161161  (declaim (inline eq-hash-find eq-hash-find-for-put))
    162   (declaim (inline lock-hash-table unlock-hash-table)))
     162  (declaim (inline read-lock-hash-table write-lock-hash-table unlock-hash-table)))
    163163
    164164(defun %cons-hash-table (rehash-function keytrans-function compare-function vector
     
    570570(defvar *continue-from-readonly-hashtable-lock-error* nil)
    571571
    572 (defun signal-read-only-hash-table-error (hash write-p)
     572(defun signal-read-only-hash-table-error (hash)
    573573  (cond (*continue-from-readonly-hashtable-lock-error*
    574574         (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
    575575                 "Hash-table ~s is readonly" hash)
    576576         (assert-hash-table-writeable hash)
    577          (lock-hash-table hash write-p))
     577         (write-lock-hash-table hash))
    578578        (t (error "Hash-table ~s is readonly" hash))))
    579579
    580 (defun lock-hash-table (hash write-p)
    581   (if (nhash.read-only hash)
    582     (if write-p
    583         (signal-read-only-hash-table-error hash write-p)
    584       :readonly)
    585     (let* ((lock (nhash.exclusion-lock hash)))
    586       (if lock
    587         (write-lock-rwlock lock)
    588         (progn (unless (eq (nhash.owner hash) *current-process*)
    589                  (error "Not owner of hash table ~s" hash)))))))
    590 
    591 (defun lock-hash-table-for-map (hash)
     580(defun read-lock-hash-table (hash)
    592581  (if (nhash.read-only hash)
    593582    :readonly
    594583    (let* ((lock (nhash.exclusion-lock hash)))
    595584      (if lock
     585        (read-lock-rwlock lock)
     586        (unless (eq (nhash.owner hash) *current-process*)
     587          (error "Not owner of hash table ~s" hash))))))
     588
     589(defun write-lock-hash-table (hash)
     590  (if (nhash.read-only hash)
     591    (signal-read-only-hash-table-error hash)
     592    (let* ((lock (nhash.exclusion-lock hash)))
     593      (if lock
    596594        (write-lock-rwlock lock)
    597         (progn (unless (eq (nhash.owner hash) *current-process*)
    598                  (error "Not owner of hash table ~s" hash)))))))
     595        (unless (eq (nhash.owner hash) *current-process*)
     596          (error "Not owner of hash table ~s" hash))))))
    599597
    600598
     
    612610  (unless (hash-table-p hash)
    613611    (report-bad-arg hash 'hash-table))
    614   (without-interrupts
    615    (lock-hash-table hash t)
    616    (let* ((vector (nhash.vector hash))
    617           (size (nhash.vector-size vector))
    618           (count (+ size size))
    619           (index $nhash.vector_overhead))
    620      (declare (fixnum size count index))
    621      (dotimes (i count)
    622        (setf (%svref vector index) (%unbound-marker))
    623        (incf index))
    624      (incf (the fixnum (nhash.grow-threshold hash))
    625            (the fixnum (+ (the fixnum (nhash.count hash))
    626                           (the fixnum (nhash.vector.deleted-count vector)))))
    627      (setf (nhash.count hash) 0
    628            (nhash.vector.cache-key vector) (%unbound-marker)
    629            (nhash.vector.cache-value vector) nil
    630            (nhash.vector.finalization-alist vector) nil
    631            (nhash.vector.free-alist vector) nil
    632            (nhash.vector.weak-deletions-count vector) 0
    633            (nhash.vector.deleted-count vector) 0
    634            (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
    635                                                (nhash.vector.flags vector))))
    636    (unlock-hash-table hash nil)
    637    hash))
     612  (with-lock-context
     613    (without-interrupts
     614     (write-lock-hash-table hash)
     615     (let* ((vector (nhash.vector hash))
     616            (size (nhash.vector-size vector))
     617            (count (+ size size))
     618            (index $nhash.vector_overhead))
     619       (declare (fixnum size count index))
     620       (dotimes (i count)
     621         (setf (%svref vector index) (%unbound-marker))
     622         (incf index))
     623       (incf (the fixnum (nhash.grow-threshold hash))
     624             (the fixnum (+ (the fixnum (nhash.count hash))
     625                            (the fixnum (nhash.vector.deleted-count vector)))))
     626       (setf (nhash.count hash) 0
     627             (nhash.vector.cache-key vector) (%unbound-marker)
     628             (nhash.vector.cache-value vector) nil
     629             (nhash.vector.finalization-alist vector) nil
     630             (nhash.vector.free-alist vector) nil
     631             (nhash.vector.weak-deletions-count vector) 0
     632             (nhash.vector.deleted-count vector) 0
     633             (nhash.vector.flags vector) (logand $nhash_weak_flags_mask
     634                                                 (nhash.vector.flags vector))))
     635     (unlock-hash-table hash nil)
     636     hash)))
    638637
    639638(defun index->vector-index (index)
     
    700699         (readonly nil)
    701700         (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))
     701    (with-lock-context
     702      (without-interrupts
     703       (setq readonly (eq #+notyet (read-lock-hash-table hash)
     704                          #-notyet (if (nhash.read-only hash)
     705                                     :readonly
     706                                     (write-lock-hash-table hash))
     707                          :readonly))
     708       (let* ((vector (nhash.vector hash)))
     709         (if (and (eq key (nhash.vector.cache-key vector))
     710                  ;; Check twice: the GC might nuke the cached key/value pair
     711                  (progn (setq value (nhash.vector.cache-value vector))
     712                         (eq key (nhash.vector.cache-key vector))))
     713           (setq foundp t)
     714           (loop
     715             (let* ((vector-index (funcall (nhash.find hash) hash key)))
     716               (declare (fixnum vector-index))
     717               ;; Referencing both key and value here - and referencing
     718               ;; value first - is an attempt to compensate for the
     719               ;; possibility that the GC deletes a weak-on-key pair.
     720               (setq value (%svref vector (the fixnum (1+ vector-index)))
     721                     vector-key (%svref vector vector-index))
     722               (cond ((setq foundp (and (not (eq vector-key free-hash-key-marker))
     723                                        (not (eq vector-key deleted-hash-key-marker))))
     724                      #+no
     725                      (setf (nhash.vector.cache-key vector) vector-key
     726                            (nhash.vector.cache-value vector) value
     727                            (nhash.vector.cache-idx vector) (vector-index->index
     728                                                             vector-index))
     729                      (return))
     730                     ((%needs-rehashing-p hash)
     731                      (setq gc-locked t)
     732                      (%lock-gc-lock)
     733                      (%rehash hash))
     734                     (t (return)))))))
     735       (when gc-locked (%unlock-gc-lock))
     736       (unlock-hash-table hash readonly)))
    733737    (if foundp
    734738      (values value t)
     
    741745    (setq hash (require-type hash 'hash-table)))
    742746  (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))))
    772              (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator)))
    773                   ((null iterator))
    774                (unless (= (the fixnum (hti.index iterator))
    775                           (the fixnum (vector-index->index vector-index)))
    776                  (unlock-hash-table hash nil)
    777                  (%unlock-gc-lock)
    778                  (error "Can't remove key ~s during iteration on hash-table ~s"
    779                         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
     747    (with-lock-context
     748      (without-interrupts
     749       (write-lock-hash-table hash)
     750       (%lock-gc-lock)
     751       (when (%needs-rehashing-p hash)
     752         (%rehash hash))   
     753       (let* ((vector (nhash.vector hash)))
     754         (if (eq key (nhash.vector.cache-key vector))
     755           (progn
    783756             (setf (nhash.vector.cache-key vector) free-hash-key-marker
    784757                   (nhash.vector.cache-value vector) nil)
    785              ;; Update the count
     758             (let ((vidx (index->vector-index (nhash.vector.cache-idx vector))))
     759               (setf (%svref vector vidx) deleted-hash-key-marker)
     760               (setf (%svref vector (the fixnum (1+ vidx))) nil))
    786761             (incf (the fixnum (nhash.vector.deleted-count vector)))
    787762             (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))
     763             (setq foundp t))
     764           (let* ((vector-index (funcall (nhash.find hash) hash key))
     765                  (vector-key (%svref vector vector-index)))
     766             (declare (fixnum vector-index))
     767             (when (setq foundp (and (not (eq vector-key free-hash-key-marker))
     768                                     (not (eq vector-key deleted-hash-key-marker))))
     769               ;; always clear the cache cause I'm too lazy to call the
     770               ;; comparison function and don't want to keep a possibly
     771               ;; deleted key from being GC'd
     772               (setf (nhash.vector.cache-key vector) free-hash-key-marker
     773                     (nhash.vector.cache-value vector) nil)
     774               ;; Update the count
     775               (incf (the fixnum (nhash.vector.deleted-count vector)))
     776               (decf (the fixnum (nhash.count hash)))
     777               ;; Remove a cons from the free-alist if the table is finalizeable
     778               (when (logbitp $nhash_finalizeable_bit (nhash.vector.flags vector))
     779                 (pop (the list (svref nhash.vector.free-alist vector))))
     780               ;; Delete the value from the table.
     781               (setf (%svref vector vector-index) deleted-hash-key-marker
     782                     (%svref vector (the fixnum (1+ vector-index))) nil))))
     783         (when (and foundp
     784                    (zerop (the fixnum (nhash.count hash))))
     785           (do* ((i $nhash.vector_overhead (1+ i))
     786                 (n (uvsize vector)))
     787                ((= i n))
     788             (declare (fixnum i n))
     789             (setf (%svref vector i) free-hash-key-marker))
     790           (setf (nhash.grow-threshold hash)
     791                 (+ (nhash.vector.deleted-count vector)
     792                    (nhash.vector.weak-deletions-count vector)
     793                    (nhash.grow-threshold hash))
     794                 (nhash.vector.deleted-count vector) 0
     795                 (nhash.vector.weak-deletions-count vector) 0)))
     796       ;; Return T if we deleted something
     797       (%unlock-gc-lock)
     798       (unlock-hash-table hash nil)))
    810799    foundp))
    811800
     
    814803  (unless (hash-table-p hash)
    815804    (report-bad-arg hash 'hash-table))
    816   (without-interrupts
    817    (block protected
    818      (tagbody
    819         (lock-hash-table hash t)
     805  (with-lock-context
     806    (without-interrupts
     807     (block protected
     808       (tagbody
     809          (write-lock-hash-table hash)
    820810        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))
     811          (%lock-gc-lock)
     812          (when (%needs-rehashing-p hash)
     813            (%rehash hash))
     814          (let ((vector (nhash.vector  hash)))     
     815            (when (eq key (nhash.vector.cache-key vector))
     816              (let* ((idx (nhash.vector.cache-idx vector)))
     817                (declare (fixnum idx))
     818                (setf (%svref vector (the fixnum (1+ (the fixnum (index->vector-index idx)))))
     819                      value)
     820                (setf (nhash.vector.cache-value vector) value)
     821                (return-from protected)))               
     822            (let* ((vector-index (funcall (nhash.find-new hash) hash key))
     823                   (old-value (%svref vector vector-index)))
     824              (declare (fixnum vector-index))
     825
     826              (cond ((eq old-value deleted-hash-key-marker)
     827                     (%set-hash-table-vector-key vector vector-index key)
     828                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
     829                     (setf (nhash.count hash) (the fixnum (1+ (the fixnum (nhash.count hash)))))
     830                     ;; Adjust deleted-count
     831                     (when (> 0 (the fixnum
     832                                  (decf (the fixnum
     833                                          (nhash.vector.deleted-count vector)))))
     834                       (let ((weak-deletions (nhash.vector.weak-deletions-count vector)))
     835                         (declare (fixnum weak-deletions))
     836                         (setf (nhash.vector.weak-deletions-count vector) 0)
     837                         (incf (the fixnum (nhash.vector.deleted-count vector)) weak-deletions)
     838                         (decf (the fixnum (nhash.count hash)) weak-deletions))))
     839                    ((eq old-value free-hash-key-marker)
     840                     (when (eql 0 (nhash.grow-threshold hash))
     841                       (%unlock-gc-lock)
     842                       (grow-hash-table hash)
     843                       (go AGAIN))
     844                     (%set-hash-table-vector-key vector vector-index key)
     845                     (setf (%svref vector (the fixnum (1+ vector-index))) value)
     846                     (decf (the fixnum (nhash.grow-threshold hash)))
     847                     (incf (the fixnum (nhash.count hash))))
     848                    (t
     849                     ;; Key was already there, update value.
     850                     (setf (%svref vector (the fixnum (1+ vector-index))) value)))
     851              (setf (nhash.vector.cache-idx vector) (vector-index->index vector-index)
     852                    (nhash.vector.cache-key vector) key
     853                    (nhash.vector.cache-value vector) value)))))
     854     (%unlock-gc-lock)
     855     (unlock-hash-table hash nil)))
    878856  value)
    879857
     
    17091687    (report-bad-arg hash 'hash-table))
    17101688  (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)
     1689      (with-lock-context
     1690        (without-interrupts
     1691         (write-lock-hash-table hash)
     1692         (let* ((flags (nhash.vector.flags (nhash.vector hash))))
     1693           (declare (fixnum flags))
     1694           (when (or (logbitp $nhash_track_keys_bit flags)
     1695                     (logbitp $nhash_component_address_bit flags))
     1696             (format t "~&Hash-table ~s uses address-based hashing and can't yet be made read-only for that reason." hash)
     1697             (unlock-hash-table hash nil)
     1698             (return-from assert-hash-table-readonly nil))
     1699           (setf (nhash.read-only hash) t)
    17181700           (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))))
     1701           t)))))
    17231702
    17241703;; This is dangerous, if multiple threads are accessing a read-only
     
    17351714    (report-bad-arg hash 'hash-table))
    17361715  (nhash.read-only hash))
     1716
     1717(defun enumerate-hash-keys (hash out)
     1718  (unless (hash-table-p hash)
     1719    (report-bad-arg hash 'hash-table))
     1720  (with-lock-context
     1721    (without-interrupts
     1722     (let* ((readonly (eq (read-lock-hash-table hash) :readonly)))
     1723       (do* ((in (nhash.vector hash))
     1724             (in-idx $nhash.vector_overhead (+ in-idx 2))
     1725             (insize (uvsize in))
     1726             (outsize (length out))
     1727             (out-idx 0))
     1728            ((or (= in-idx insize)
     1729                 (= out-idx outsize))
     1730             (unlock-hash-table hash readonly)
     1731             out-idx)
     1732         (declare (fixnum in-idx insize out-idx outsize))
     1733         (let* ((val (%svref in in-idx)))
     1734           (unless (or (eq val free-hash-key-marker)
     1735                       (eq val deleted-hash-key-marker))
     1736             (setf (%svref out out-idx) val)
     1737             (incf out-idx))))))))
Note: See TracChangeset for help on using the changeset viewer.