Changeset 7512 for branches/working-0710


Ignore:
Timestamp:
Oct 25, 2007, 12:02:25 AM (12 years ago)
Author:
gb
Message:

New implementation of SNAP-READER-METHODS; should catch more cases, some
of which may matter.

File:
1 edited

Legend:

Unmodified
Added
Removed
  • branches/working-0710/ccl/level-1/l1-clos.lisp

    r7496 r7512  
    17511751          (override-one-method-one-arg-dcode gf (car methods)))))))
    17521752
    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))))
     1753
    17701754
    17711755;;; dcode for a GF with a single reader method which accesses
     
    17831767      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    17841768
    1785 ;;; We know that all of the methods are SIMPLE-READER-METHODs that
    1786 ;;; access the slot NAME.  If there's exactly one such method and
    1787 ;;; the class it specializes on has no subclasses, set the GF's
    1788 ;;; dcode to SINGLETON-READER-DCODE.
    1789 (defun maybe-make-singleton-reader-dcode (gf name methods)
    1790   (unless (cdr methods)
    1791     (let* ((m (car methods))
    1792            (class (car (method-specializers m))))
    1793       (unless (class-direct-subclasses class)
    1794        (let* ((eslotd (find-slotd name (class-slots class)))
    1795               (location (if eslotd (slot-definition-location eslotd))))
    1796          (when (typep location 'fixnum)
    1797            (let* ((dt (gf.dispatch-table gf)))
    1798              (clear-gf-dispatch-table dt)
    1799              (setf (%svref dt %gf-dispatch-table-first-data) class
    1800                    (%svref dt (1+ %gf-dispatch-table-first-data)) location
    1801                    (gf.dcode gf) #'singleton-reader-dcode))))))))
    1802 
    1803 
    1804 ;;; Skip generic function dispatch if all of the GF's methods are
    1805 ;;; STANDARD-READER-METHODs that access the same slot name.  Using
    1806 ;;; the wrapper's slot-id->slotd function will incidentally handle
    1807 ;;; the case of updating obsolete instances; since we assume that
    1808 ;;; we're running in a closed CLOS universe, there shouldn't be any
    1809 ;;; such instances.
    1810 (defun reader-dcode (dt instance)
     1769;;; Dcode for a GF whose methods are all reader-methods which access a
     1770;;; slot in one or more classes which have multiple subclasses, all of
     1771;;; which (by luck or design) have the same slot-definition location.
     1772(defun reader-constant-location-dcode (dt instance)
    18111773  (declare (optimize (speed 3) (safety 0)))
    1812   (let* ((slot-id (%gf-dispatch-table-first-data dt))
    1813          (wrapper (if (eq (typecode instance) target::subtag-instance)
    1814                     (instance.class-wrapper instance)))
    1815          (slotd (if wrapper
    1816                   (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
    1817          (location (if slotd
    1818                      (%slot-ref (instance.slots slotd) 9))))
     1774  (let* ((classes (%svref dt %gf-dispatch-table-first-data))
     1775         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
     1776    (if (memq (if (eq (typecode instance) target::subtag-instance)
     1777              (%class-of-instance instance))
     1778            classes)
     1779      (%slot-ref (instance.slots instance) location)
     1780      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1781
     1782;;; Similar to the case above, but we use an alist to map classes
     1783;;; to their non-constant locations.
     1784(defun reader-variable-location-dcode (dt instance)
     1785  (declare (optimize (speed 3) (safety 0)))
     1786  (let* ((alist (%svref dt %gf-dispatch-table-first-data))
     1787         (location (cdr
     1788                    (assq
     1789                     (if (eq (typecode instance) target::subtag-instance)
     1790                       (%class-of-instance instance))
     1791                     alist))))
    18191792    (if location
    1820       (if (consp location)
    1821         (cdr location)
    1822         (%slot-ref (instance.slots instance) location))
     1793      (%slot-ref (instance.slots instance) location)
    18231794      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    18241795
     1796(defun class-and-slot-location-alist (classes slot-name)
     1797  (let* ((alist nil))
     1798    (labels ((add-class (c)
     1799               (unless (assq c alist)
     1800                 (push (cons c (slot-definition-location (find-slotd slot-name (class-slots c)))) alist)
     1801                 (dolist (sub (class-direct-subclasses c))
     1802                   (add-class sub)))))
     1803      (dolist (class classes) (add-class class))
     1804      ;; Building the alist the way that we have should often approximate
     1805      ;; this ordering; the idea is that leaf classes are more likely to
     1806      ;; be instantiated than non-leaves.
     1807      (sort alist (lambda (c1 c2)
     1808                    (< (length (class-direct-subclasses c1))
     1809                       (length (class-direct-subclasses c2))))
     1810            :key #'car))))
     1811
     1812
    18251813;;; Try to replace gf dispatch with something faster in f.
    1826 (defun %snap-reader-method (f check-conflict-hash)
     1814(defun %snap-reader-method (f)
    18271815  (when (slot-boundp f 'methods)
    18281816    (let* ((methods (generic-function-methods f)))
     
    18361824                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
    18371825                       (cdr methods))
    1838             (or (maybe-make-singleton-reader-dcode f name methods)
    1839                 (unless (and check-conflict-hash
    1840                              (check-slot-conflict-for-reader-methods
    1841                               name check-conflict-hash methods))
    1842                   (let* ((id (ensure-slot-id name))
    1843                          (dt (gf.dispatch-table f)))
    1844                     (clear-gf-dispatch-table dt)
    1845                     (setf (gf.dcode f) #'reader-dcode
    1846                           (%gf-dispatch-table-first-data dt) id)))
    1847                 (values nil :conflict))))))))
     1826            ;; All methods are *STANDARD-READER-METHODS* that
     1827            ;; access the same slot name.  Build an alist of
     1828            ;; mapping all subclasses of all classes on which those
     1829            ;; methods are specialized to the effective slot's
     1830            ;; location in that subclass.
     1831            (let* ((classes (mapcar #'(lambda (m) (car (method-specializers m)))
     1832                                    methods))
     1833                   (alist (class-and-slot-location-alist classes name))
     1834                   (loc (cdar alist))
     1835                   (dt (gf.dispatch-table f)))
     1836              ;; Only try to handle the case where all slots have
     1837              ;; :allocation :instance (and all locations - the CDRs
     1838              ;; of the alist pairs - are small, positive fixnums.
     1839              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
     1840                (clear-gf-dispatch-table dt)
     1841                (cond ((null (cdr alist))
     1842                       ;; Method is only applicable to a single class.
     1843                       (destructuring-bind (class . location) (car alist)
     1844                         (setf (%svref dt %gf-dispatch-table-first-data) class
     1845                               (%svref dt (1+ %gf-dispatch-table-first-data)) location
     1846                               (gf.dcode f) #'singleton-reader-dcode)))
     1847                      ((dolist (other (cdr alist) t)
     1848                         (unless (eq (cdr other) loc)
     1849                           (return)))
     1850                       ;; All classes have the slot in the same location,
     1851                       ;; by luck or design.
     1852                       (setf (%svref dt %gf-dispatch-table-first-data)
     1853                             (mapcar #'car alist)
     1854                             (%svref dt (1+ %gf-dispatch-table-first-data))
     1855                             loc
     1856                             (gf.dcode f) #'reader-constant-location-dcode))
     1857                      (t
     1858                       ;; Multiple classes; the slot's location varies.
     1859                       (setf (%svref dt %gf-dispatch-table-first-data)
     1860                             alist
     1861                             
     1862                             (gf.dcode f) #'reader-variable-location-dcode)))))))))))                       
     1863
    18481864
    18491865;;; Iterate over all known GFs; try to optimize their dcode in cases
     
    18511867
    18521868(defun snap-reader-methods (&key known-sealed-world (check-conflicts t))
     1869  (declare (ignore check-conflicts))
    18531870  (unless known-sealed-world
    18541871    (cerror "Proceed, if it's known that no new classes or methods will be defined."
    18551872            "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
    18561873  (let* ((ngf 0)
    1857          (nwin 0)
    1858          (nconflict 0)
    1859          (check-conflicts-hash (and check-conflicts (make-slot-name-to-class-hash))))
    1860   (dolist (f (population.data %all-gfs%))
    1861     (incf ngf)
    1862     (multiple-value-bind (win conflict)
    1863         (%snap-reader-method f check-conflicts-hash)
    1864       (if win
    1865         (incf nwin)
    1866         (if (eq conflict :conflict)
    1867           (incf nconflict)))))
    1868   (values ngf nwin nconflict)))
     1874         (nwin 0))
     1875    (dolist (f (population.data %all-gfs%))
     1876      (incf ngf)
     1877      (when (%snap-reader-method f)
     1878        (incf nwin)))
     1879    (values ngf nwin 0)))
Note: See TracChangeset for help on using the changeset viewer.