Oct 22, 2007, 11:25:54 AM (14 years ago)

SNAP-READER-METHODS in a "sealed" CLOS environment.

1 edited


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

    r7488 r7491  
    17501750        (when (eql 1 (length methods))
    17511751          (override-one-method-one-arg-dcode gf (car methods)))))))
     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%))
     1767;;; dcode for a GF with a single reader method which accesses
     1768;;; a slot in a class that has no subclasses (that restriction
     1769;;; makes typechecking simpler and also ensures that the slot's
     1770;;; location is correct.)
     1771(defun singleton-reader-dcode (dt instance)
     1772  (declare (optimize (speed 3) (safety 0)))
     1773  (let* ((class (%svref dt %gf-dispatch-table-first-data))
     1774         (location (%svref dt (1+ %gf-dispatch-table-first-data))))
     1775    (if (eq (if (eq (typecode instance) target::subtag-instance)
     1776              (%class-of-instance instance))
     1777            class)
     1778      (%slot-ref (instance.slots instance) location)
     1779      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1781;;; We know that all of the methods are SIMPLE-READER-METHODs that
     1782;;; access the slot NAME.  If there's exactly one such method and
     1783;;; the class it specializes on has no subclasses, set the GF's
     1784;;; dcode to SINGLETON-READER-DCODE.
     1785(defun maybe-make-singleton-reader-dcode (gf name methods)
     1786  (unless (cdr methods)
     1787    (let* ((m (car methods))
     1788           (class (car (method-specializers m))))
     1789      (unless (class-direct-subclasses class)
     1790       (let* ((eslotd (find-slotd name (class-slots class)))
     1791              (location (if eslotd (slot-definition-location eslotd))))
     1792         (when (typep location 'fixnum)
     1793           (let* ((dt (gf.dispatch-table gf)))
     1794             (clear-gf-dispatch-table dt)
     1795             (setf (%svref dt %gf-dispatch-table-first-data) class
     1796                   (%svref dt (1+ %gf-dispatch-table-first-data)) location
     1797                   (gf.dcode gf) #'singleton-reader-dcode))))))))
     1800;;; Skip generic function dispatch if all of the GF's methods are
     1801;;; STANDARD-READER-METHODs that access the same slot name.  Using
     1802;;; the wrapper's slot-id->slotd function will incidentally handle
     1803;;; the case of updating obsolete instances; since we assume that
     1804;;; we're running in a closed CLOS universe, there shouldn't be any
     1805;;; such instances.
     1806(defun reader-dcode (dt instance)
     1807  (declare (optimize (speed 3) (safety 0)))
     1808  (let* ((slot-id (%gf-dispatch-table-first-data dt))
     1809         (wrapper (if (eq (typecode instance) target::subtag-instance)
     1810                    (instance.class-wrapper instance)))
     1811         (slotd (if wrapper
     1812                  (funcall (%wrapper-slot-id->slotd wrapper) instance slot-id)))
     1813         (location (if slotd
     1814                     (%slot-ref (instance.slots slotd) 9))))
     1815    (if location
     1816      (if (consp location)
     1817        (cdr location)
     1818        (%slot-ref (instance.slots instance) location))
     1819      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1821;;; Try to replace gf dispatch with something faster in f.
     1822(defun %snap-reader-method (f check-conflict)
     1823  (when (slot-boundp f 'methods)
     1824    (let* ((methods (generic-function-methods f)))
     1825      (when (and methods
     1826                 (every (lambda (m) (eq (class-of m) *standard-reader-method-class*)) methods)
     1827                 (every (lambda (m) (subtypep (class-of (car (method-specializers m))) *standard-class-class*)) methods)
     1828                 (every (lambda (m) (null (method-qualifiers m))) methods))
     1829        (let* ((m0 (car methods))
     1830               (name (slot-definition-name (accessor-method-slot-definition m0))))
     1831          (when (every (lambda (m)
     1832                         (eq name (slot-definition-name (accessor-method-slot-definition m))))
     1833                       (cdr methods))
     1834            (or (maybe-make-singleton-reader-dcode f name methods)
     1835                (unless (and check-conflict
     1836                             (check-slot-conflict-for-reader-methods name methods))
     1837                  (let* ((id (ensure-slot-id name))
     1838                         (dt (gf.dispatch-table f)))
     1839                    (clear-gf-dispatch-table dt)
     1840                    (setf (gf.dcode f) #'reader-dcode
     1841                          (%gf-dispatch-table-first-data dt) id)))
     1842                (values nil :confluct))))))))
     1844;;; Iterate over all known GFs; try to optimize their dcode in cases
     1845;;; involving reader methods.
     1847(defun snap-reader-methods (&key known-sealed-world (check-conflicts t))
     1848  (unless sealed-world
     1849    (cerror "Proceed, if it's known that no new classes or methods will be defined."
     1850            "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
     1851  (let* ((ngf 0)
     1852         (nwin 0)
     1853         (nconflict 0))
     1854  (dolist (f (population.data %all-gfs%))
     1855    (incf ngf)
     1856    (multiple-value-bind (win conflict)
     1857        (%snap-reader-method f check-conflicts)
     1858      (if win
     1859        (incf nwin)
     1860        (if (eq conflict :conflict)
     1861          (incf nconflict)))))
     1862  (values ngf nwin nconflict)))
Note: See TracChangeset for help on using the changeset viewer.