Changeset 7491 for branches/working-0710


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

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

File:
1 edited

Legend:

Unmodified
Added
Removed
  • 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)))))))
     1752
     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%))
     1766
     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))))
     1780
     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))))))))
     1798
     1799
     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))))
     1820
     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))))))))
     1843
     1844;;; Iterate over all known GFs; try to optimize their dcode in cases
     1845;;; involving reader methods.
     1846
     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.