- Timestamp:
- Nov 18, 2007, 11:57:02 PM (17 years ago)
- File:
-
- 1 edited
-
branches/working-0711/ccl/level-0/l0-hash.lisp (modified) (7 diffs)
Legend:
- Unmodified
- Added
- Removed
-
branches/working-0711/ccl/level-0/l0-hash.lisp
r7624 r7679 612 612 (unless (hash-table-p hash) 613 613 (report-bad-arg hash 'hash-table)) 614 (with-lock-context 614 615 (without-interrupts 615 616 (lock-hash-table hash t) … … 635 636 (nhash.vector.flags vector)))) 636 637 (unlock-hash-table hash nil) 637 hash)) 638 hash))) 638 639 639 640 (defun index->vector-index (index) … … 700 701 (readonly nil) 701 702 (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))) 733 735 (if foundp 734 736 (values value t) … … 741 743 (setq hash (require-type hash 'hash-table))) 742 744 (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 772 754 (do* ((iterator (nhash.iterator hash) (hti.prev-iterator iterator))) 773 755 ((null iterator)) 774 756 (unless (= (the fixnum (hti.index iterator)) 775 (the fixnum ( vector-index->index vector-index)))757 (the fixnum (nhash.vector.cache-idx vector))) 776 758 (unlock-hash-table hash nil) 777 759 (%unlock-gc-lock) 778 760 (error "Can't remove key ~s during iteration on hash-table ~s" 779 761 key hash))) 780 ;; always clear the cache cause I'm too lazy to call the781 ;; comparison function and don't want to keep a possibly782 ;; deleted key from being GC'd783 762 (setf (nhash.vector.cache-key vector) free-hash-key-marker 784 763 (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)) 786 767 (incf (the fixnum (nhash.vector.deleted-count vector))) 787 768 (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))) 810 813 foundp)) 811 814 … … 814 817 (unless (hash-table-p hash) 815 818 (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) 820 824 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-count853 (when (> 0 (the fixnum854 (decf (the fixnum855 (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 (t871 ;; 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) key875 (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))) 878 882 value) 879 883 … … 1709 1713 (report-bad-arg hash 'hash-table)) 1710 1714 (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) 1718 1726 (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))))) 1723 1728 1724 1729 ;; This is dangerous, if multiple threads are accessing a read-only … … 1735 1740 (report-bad-arg hash 'hash-table)) 1736 1741 (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.
