Changeset 9422


Ignore:
Timestamp:
May 9, 2008, 10:04:53 AM (11 years ago)
Author:
gb
Message:

Use bitvectors in some of the optimized-reader-dcode functions.

Define *UNIQUE-READER-DCODE-FUNCTIONS*, defaults to T. Some of the
optimized reader dcode functions might perform better if they're
compiled in a way that avoids using the dispatch table to pass
parameters.

INSTANCE-CLASS-WRAPPER is now a non-generic function.

Define REGISTER-NON-DT-DCODE-FUNCTION, use it to define specialized
dcode functions. Define exactly one such function, which causes the
method-function to be called directly if (a) there's only one method
defined on a GF and (b) it's universally applicable. (There are
a handful of such methods in CCL, over 100 in a customer's application,
but don't know how often they're called.)

File:
1 edited

Legend:

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

    r9390 r9422  
    636636      (let* ((wrapper (%class-own-wrapper class)))
    637637        (when wrapper
    638           (setf (%wrapper-cpl wrapper) cpl)))))
     638          (setf (%wrapper-cpl wrapper) cpl
     639                (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl))))))
    639640  (unless finalizep
    640641    (dolist (sub (%class-direct-subclasses class))
     
    727728
    728729(defmethod initialize-instance :before ((class class) &key &allow-other-keys)
     730  (setf (%class-ordinal class) (%next-class-ordinal))
    729731  (setf (%class.ctype class) (make-class-ctype class)))
    730732
     
    12441246                        (setf (%class-own-wrapper class) (%cons-wrapper class))))
    12451247           (cpl (compute-cpl class)))
    1246       (setf (%wrapper-cpl wrapper) cpl))))
     1248      (setf (%class.cpl class) cpl)
     1249      (setf (%wrapper-cpl wrapper) cpl
     1250            (%wrapper-cpl-bits wrapper) (make-cpl-bits cpl)))))
    12471251             
    12481252
     
    17141718
    17151719
    1716 (defmethod instance-class-wrapper ((instance funcallable-standard-object))
    1717   (gf.instance.class-wrapper  instance))
     1720
    17181721
    17191722(defun set-funcallable-instance-function (funcallable-instance function)
     
    18231826            (override-one-method-one-arg-dcode gf (car methods))))))))
    18241827
     1828(defparameter *unique-reader-dcode-functions* t)
     1829
    18251830;;; dcode for a GF with a single reader method which accesses
    18261831;;; a slot in a class that has no subclasses (that restriction
     
    18571862(defun reader-constant-location-inherited-from-single-class-dcode (dt instance)
    18581863  (declare (optimize (speed 3) (safety 0)))
    1859   (let* ((defining-class (%svref dt %gf-dispatch-table-first-data))
    1860          (location (%svref dt (1+ %gf-dispatch-table-first-data)))
    1861          (cpl (let* ((wrapper
    1862                       (if (eq (typecode instance) target::subtag-instance)
    1863                         (instance.class-wrapper instance))))
    1864                 (when wrapper (or (%wrapper-cpl wrapper)
    1865                                   (%inited-class-cpl
    1866                                    (%wrapper-class wrapper)))))))
    1867     (if (memq defining-class cpl)
    1868       (%slot-ref (instance.slots instance) location)
     1864  (let* ((defining-class-ordinal (%svref dt %gf-dispatch-table-first-data))
     1865         (bits  (let* ((wrapper
     1866                        (if (eq (typecode instance) target::subtag-instance)
     1867                          (instance.class-wrapper instance))))
     1868                  (when wrapper (or (%wrapper-cpl-bits wrapper)
     1869                                    (make-cpl-bits (%inited-class-cpl
     1870                                                    (%wrapper-class wrapper))))))))
     1871    (declare (fixnum defining-class-ordinal))
     1872    (if (and bits
     1873             (< defining-class-ordinal (the fixnum (uvsize bits)))
     1874             (not (eql 0 (sbit bits defining-class-ordinal))))
     1875      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
    18691876      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
    18701877(register-dcode-proto #'reader-constant-location-inherited-from-single-class-dcode *gf-proto-one-arg*)
     1878
     1879;;; It may be faster to make individual functions that take their
     1880;;; "parameters" (defining class ordinal, slot location) as constants.
     1881;;; It may not be.  Use *unique-reader-dcode-functions* to decide
     1882;;; whether or not to do so.
     1883(defun make-reader-constant-location-inherited-from-single-class-dcode
     1884    (defining-class-ordinal location gf)
     1885  (if *unique-reader-dcode-functions*
     1886    (let* ((gf-name (function-name gf)))
     1887      (values
     1888       (%make-function
     1889        `(slot-reader for ,gf-name)
     1890        `(lambda (instance)
     1891          (locally (declare (optimize (speed 3) (safety 0)))
     1892            (let* ((bits (let* ((wrapper
     1893                                 (if (eq (typecode instance) target::subtag-instance)
     1894                                   (instance.class-wrapper instance))))
     1895                           (when wrapper (or (%wrapper-cpl-bits wrapper)
     1896                                             (make-cpl-bits (%inited-class-cpl
     1897                                                             (%wrapper-class wrapper))))))))
     1898              (if (and bits
     1899                       (< ,defining-class-ordinal (the fixnum (uvsize bits)))
     1900                       (not (eql 0 (sbit bits ,defining-class-ordinal))))
     1901                (%slot-ref (instance.slots instance) ,location)
     1902                (no-applicable-method (function ,gf-name) instance)))))
     1903        nil)
     1904       #'funcallable-trampoline))
     1905    (let* ((dt (gf.dispatch-table gf)))
     1906      (setf (%svref dt %gf-dispatch-table-first-data)
     1907            defining-class-ordinal
     1908            (%svref dt (1+ %gf-dispatch-table-first-data))
     1909            location)
     1910      (values
     1911       (dcode-for-gf gf #'reader-constant-location-inherited-from-single-class-dcode)
     1912       (cdr (assq #'reader-constant-location-inherited-from-single-class-dcode dcode-proto-alist))))))
    18711913
    18721914;;; Dcode for a GF whose methods are all reader-methods which access a
     
    18791921  (let* ((wrapper (if (eq (typecode instance) target::subtag-instance)
    18801922                    (instance.class-wrapper instance)))
    1881          (cpl (if wrapper (or (%wrapper-cpl wrapper) (%inited-class-cpl (%wrapper-class wrapper))))))
    1882     (if (dolist (defining-class (%svref dt %gf-dispatch-table-first-data))
    1883           (when (memq defining-class cpl) (return t)))
     1923         (bits (if wrapper (or (%wrapper-cpl-bits wrapper)
     1924                               (make-cpl-bits (%inited-class-cpl (%wrapper-class wrapper))))))
     1925         (nbits (if bits (uvsize bits) 0)))
     1926    (declare (fixnum nbits))
     1927    (if (dolist (ordinal (%svref dt %gf-dispatch-table-first-data))
     1928          (declare (fixnum ordinal))
     1929          (when (and (< ordinal nbits)
     1930                     (not (eql 0 (sbit bits ordinal))))
     1931            (return t)))
    18841932      (%slot-ref (instance.slots instance) (%svref dt (1+ %gf-dispatch-table-first-data)))
    18851933      (no-applicable-method (%gf-dispatch-table-gf dt) instance))))
     
    19862034                         ((null (cdr (setq classes (remove-subclasses-from-class-list classes))))
    19872035                          ;; Lots of classes, all subclasses of a single class
    1988                           (setf (%svref dt %gf-dispatch-table-first-data)
    1989                                 (car classes)
    1990                                 (%svref dt (1+ %gf-dispatch-table-first-data))
    1991                                 loc
    1992                                 (gf.dcode f)
    1993                                 (dcode-for-gf f #'reader-constant-location-inherited-from-single-class-dcode)))
     2036                          (multiple-value-bind (dcode trampoline)
     2037                              (make-reader-constant-location-inherited-from-single-class-dcode (%class-ordinal (car classes)) loc f)
     2038                            (break "dcode = ~s, tramp = ~s" dcode trampoline)
     2039                            (setf (gf.dcode f) dcode)
     2040                            (replace-function-code f trampoline)))
    19942041                         (t
    19952042                          ;; Multple classes.  We should probably check
    19962043                          ;; to see they're disjoint
    19972044                          (setf (%svref dt %gf-dispatch-table-first-data)
    1998                                 classes
     2045                                (mapcar #'%class-ordinal classes)
    19992046                                (%svref dt (1+ %gf-dispatch-table-first-data))
    20002047                                loc
     
    23362383    (values ngf nwin 0)))
    23372384
     2385(defun register-non-dt-dcode-function (f)
     2386  (flet ((symbol-or-function-name (x)
     2387           (etypecase x
     2388             (symbol x)
     2389             (function (function-name x)))))
     2390    (let* ((already (member (symbol-or-function-name f) *non-dt-dcode-functions* :key #'symbol-or-function-name)))
     2391      (if already
     2392        (setf (car already) f)
     2393        (push f *non-dt-dcode-functions*))
     2394      f)))
     2395
    23382396(defun pessimize-clos ()
    23392397  (declare (special *sealed-clos-world*))
     
    23512409    (setq *sealed-clos-world* nil)
    23522410    t))
     2411
     2412;;; If there's a single method (with standard method combination) on
     2413;;; GF and all of that method's arguments are specialized to the T
     2414;;; class - and if the method doesn't accept &key - we can just have
     2415;;; the generic function call the method-function
     2416(defun dcode-for-universally-applicable-singleton (gf)
     2417  (when (eq (generic-function-method-combination gf)
     2418            *standard-method-combination*)
     2419    (let* ((methods (generic-function-methods gf))
     2420           (method (car methods)))
     2421      (when (and method
     2422                 (null (cdr methods))
     2423                 (null (method-qualifiers method))
     2424                 (not (logbitp $lfbits-keys-bit (lfun-bits (method-function method))))
     2425                 (dolist (spec (method-specializers method) t)
     2426                   (unless (eq spec *t-class*)
     2427                     (return nil))))
     2428        (method-function method)))))
     2429
     2430(register-non-dt-dcode-function #'dcode-for-universally-applicable-singleton)
Note: See TracChangeset for help on using the changeset viewer.