Changeset 7496 for branches/working-0710


Ignore:
Timestamp:
Oct 22, 2007, 9:15:41 PM (12 years ago)
Author:
wws
Message:

Speed up conflict checking in snap-reader-methods, and fix a typo that
made it misreport the number of conflicts as 0.

If ccl::continue-from-readonly-hashtable-lock-error* is true, the
error on attempting to modify a read-only hash table will be
continuable, and continuing will make the hash table writeble. The
default for ccl::*continue-from-readonly-hashtable-lock-error* is nil,
so you have to set it to true in order to see the continue option, and
then you get BOLD CAPS AND EXCLAMATION POINTS IN YOUR FACE!

I actually ran into this just now, and boy was it annoying.

Location:
branches/working-0710/ccl
Files:
2 edited

Legend:

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

    r7482 r7496  
    568568
    569569
    570 
     570(defvar *continue-from-readonly-hashtable-lock-error* nil)
     571
     572(defun signal-read-only-hash-table-error (hash write-p)
     573  (cond (*continue-from-readonly-hashtable-lock-error*
     574         (cerror "Make the hash-table writable. DANGEROUS! CONTINUE ONLY IF YOU KNOW WHAT YOU'RE DOING!"
     575                 "Hash-table ~s is readonly" hash)
     576         (assert-hash-table-writeable hash)
     577         (lock-hash-table hash write-p))
     578        (t (error "Hash-table ~s is readonly" hash))))
    571579
    572580(defun lock-hash-table (hash write-p)
    573581  (if (nhash.read-only hash)
    574582    (if write-p
    575       (error "Hash-table ~s is readonly" hash)
     583        (signal-read-only-hash-table-error hash write-p)
    576584      :readonly)
    577585    (let* ((lock (nhash.exclusion-lock hash)))
     
    17131721         (unlock-hash-table hash nil)
    17141722         t))))
     1723
     1724;; This is dangerous, if multiple threads are accessing a read-only
     1725;; hash table. Use it responsibly.
     1726(defun assert-hash-table-writeable (hash)
     1727  (unless (hash-table-p hash)
     1728    (report-bad-arg hash 'hash-table))
     1729  (when (nhash.read-only hash)
     1730    (setf (nhash.read-only hash) nil)
     1731    t))
  • branches/working-0710/ccl/level-1/l1-clos.lisp

    r7492 r7496  
    17511751          (override-one-method-one-arg-dcode gf (car methods)))))))
    17521752
    1753 ;;; of any class that the reader methods METHODs specialize on.
    1754 ;;; Return T if there's such class, NIL otherwise.
    1755 (defun check-slot-conflict-for-reader-methods (name reader-methods)
    1756   (maphash (lambda (class-name info)
    1757              (declare (ignore class-name))
    1758              (let* ((class (cdr info)))
    1759                (when (typep class 'standard-class)
    1760                  (when (find-slotd name (class-direct-slots class))
    1761                    (when (dolist (method reader-methods t)
    1762                            (when (subtypep class (car (method-specializers method)))
    1763                              (return nil)))
    1764                      (return-from check-slot-conflict-for-reader-methods t))))))
    1765            %find-classes%))
     1753(defun make-slot-name-to-class-hash ()
     1754  (let ((hash (make-hash-table :test 'eq)))
     1755    (maphash (lambda (class-name info)
     1756               (declare (ignore class-name))
     1757               (let ((class (cdr info)))
     1758                 (when (typep class 'standard-class)
     1759                   (dolist (slotd (class-direct-slots class))
     1760                     (push class (gethash (%slot-definition-name slotd) hash))))))
     1761             %find-classes%)
     1762    hash))
     1763
     1764(defun check-slot-conflict-for-reader-methods (name hash reader-methods)
     1765  (dolist (class (gethash name hash))
     1766    (when (dolist (method reader-methods t)
     1767            (when (subtypep class (car (method-specializers method)))
     1768              (return nil)))
     1769      (return-from check-slot-conflict-for-reader-methods t))))
    17661770
    17671771;;; dcode for a GF with a single reader method which accesses
     
    18201824
    18211825;;; Try to replace gf dispatch with something faster in f.
    1822 (defun %snap-reader-method (f check-conflict)
     1826(defun %snap-reader-method (f check-conflict-hash)
    18231827  (when (slot-boundp f 'methods)
    18241828    (let* ((methods (generic-function-methods f)))
     
    18331837                       (cdr methods))
    18341838            (or (maybe-make-singleton-reader-dcode f name methods)
    1835                 (unless (and check-conflict
    1836                              (check-slot-conflict-for-reader-methods name methods))
     1839                (unless (and check-conflict-hash
     1840                             (check-slot-conflict-for-reader-methods
     1841                              name check-conflict-hash methods))
    18371842                  (let* ((id (ensure-slot-id name))
    18381843                         (dt (gf.dispatch-table f)))
     
    18401845                    (setf (gf.dcode f) #'reader-dcode
    18411846                          (%gf-dispatch-table-first-data dt) id)))
    1842                 (values nil :confluct))))))))
     1847                (values nil :conflict))))))))
    18431848
    18441849;;; Iterate over all known GFs; try to optimize their dcode in cases
     
    18511856  (let* ((ngf 0)
    18521857         (nwin 0)
    1853          (nconflict 0))
     1858         (nconflict 0)
     1859         (check-conflicts-hash (and check-conflicts (make-slot-name-to-class-hash))))
    18541860  (dolist (f (population.data %all-gfs%))
    18551861    (incf ngf)
    18561862    (multiple-value-bind (win conflict)
    1857         (%snap-reader-method f check-conflicts)
     1863        (%snap-reader-method f check-conflicts-hash)
    18581864      (if win
    18591865        (incf nwin)
Note: See TracChangeset for help on using the changeset viewer.