Changeset 7864


Ignore:
Timestamp:
Dec 10, 2007, 12:10:40 PM (13 years ago)
Author:
gb
Message:

Don't just do MEMQ on a long list of classes in optimized reader dcode;
try a few other approaches.

File:
1 edited

Legend:

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

    r7848 r7864  
    17851785      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    17861786
     1787;;; Dcode for a GF whose methods are all reader-methods which access a
     1788;;; slot in one or more classes which have multiple subclasses, all of
     1789;;; which (by luck or design) have the same slot-definition location.
     1790;;; The number of classes is for which the method is applicable is
     1791;;; large, but all are subclasses of a single class
     1792(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
     1793  (declare (optimize (speed 3) (safety 0)))
     1794  (let* ((defining-class (%svref dt %gf-dispatch-table-first-data))
     1795         (location (%svref dt (1+ %gf-dispatch-table-first-data)))
     1796         (class (if (eq (typecode instance) target::subtag-instance)
     1797                  (%class-of-instance instance))))
     1798    (if (and class (memq defining-class (%inited-class-cpl class)))
     1799      (%slot-ref (instance.slots instance) location)
     1800      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1801
     1802;;; Dcode for a GF whose methods are all reader-methods which access a
     1803;;; slot in one or more classes which have multiple subclasses, all of
     1804;;; which (by luck or design) have the same slot-definition location.
     1805;;; The number of classes is for which the method is applicable is
     1806;;; large, but all are subclasses of one of a (small) set of defining classes.
     1807(defun reader-constant-location-inherited-from-multiple-classes-dcode (dt instance)
     1808  (declare (optimize (speed 3) (safety 0)))
     1809  (let* ((location (%svref dt (1+ %gf-dispatch-table-first-data)))
     1810         (class (if (eq (typecode instance) target::subtag-instance)
     1811                  (%class-of-instance instance)))
     1812         (cpl (if class (%inited-class-cpl class))))
     1813    (if (dolist (defining-class (%svref dt %gf-dispatch-table-first-data))
     1814          (when (memq defining-class cpl) (return t)))
     1815      (%slot-ref (instance.slots instance) location)
     1816      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     1817
     1818
    17871819;;; Similar to the case above, but we use an alist to map classes
    17881820;;; to their non-constant locations.
     
    18191851            :key #'car))))
    18201852
     1853;;; Return a list of all classes in CLASS-LIST that aren't subclasses
     1854;;; of any other class in the list.
     1855(defun remove-subclasses-from-class-list (class-list)
     1856  (if (null (cdr class-list))
     1857    class-list
     1858    (collect ((unique))
     1859      (dolist (class class-list (unique))
     1860        (when (dolist (other class-list t)
     1861                (unless (eq class other)
     1862                  (when (subtypep class other) (return nil))))
     1863          (unique class))))))
    18211864
    18221865;;; Try to replace gf dispatch with something faster in f.
     
    18591902                       ;; All classes have the slot in the same location,
    18601903                       ;; by luck or design.
    1861                        (setf (%svref dt %gf-dispatch-table-first-data)
    1862                              (mapcar #'car alist)
    1863                              (%svref dt (1+ %gf-dispatch-table-first-data))
    1864                              loc
    1865                              (gf.dcode f) #'reader-constant-location-dcode))
     1904                       (cond
     1905                         ((< (length alist) 10)
     1906                          ;; Only a small number of classes, just do MEMQ
     1907                          (setf (%svref dt %gf-dispatch-table-first-data)
     1908                                (mapcar #'car alist)
     1909                                (%svref dt (1+ %gf-dispatch-table-first-data))
     1910                                loc
     1911                                (gf.dcode f) #'reader-constant-location-dcode))
     1912                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
     1913                          ;; Lots of classes, all subclasses of a single class
     1914                          (setf (%svref dt %gf-dispatch-table-first-data)
     1915                                (car classes)
     1916                                (%svref dt (1+ %gf-dispatch-table-first-data))
     1917                                loc
     1918                                (gf.dcode f)
     1919                                #'reader-constant-location-inherited-from-single-class-dcode))
     1920                         (t
     1921                          ;; Multple classes.  We should probably check
     1922                          ;; to see they're disjoint
     1923                          (setf (%svref dt %gf-dispatch-table-first-data)
     1924                                classes
     1925                                (%svref dt (1+ %gf-dispatch-table-first-data))
     1926                                loc
     1927                                (gf.dcode f)
     1928                                #'reader-constant-location-inherited-from-multiple-classes-dcode))))
    18661929                      (t
    18671930                       ;; Multiple classes; the slot's location varies.
Note: See TracChangeset for help on using the changeset viewer.