Changeset 7755


Ignore:
Timestamp:
Nov 26, 2007, 11:35:13 AM (12 years ago)
Author:
gb
Message:

Try to optimize some cases of MAKE-INSTANCE.

File:
1 edited

Legend:

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

    r7624 r7755  
    18671867
    18681868
     1869;;; Return a lambda form or NIL.
     1870(defun make-instantiate-lambda-for-class-cell (cell)
     1871  (let* ((class (class-cell-class cell)))
     1872    (when (and (typep class 'standard-class)
     1873               (null (cdr (compute-applicable-methods #'allocate-instance (list class))))
     1874               (let* ((proto (class-prototype class)))
     1875                 (and (null (cdr (compute-applicable-methods #'initialize-instance (list proto))))
     1876                      (null (cdr (compute-applicable-methods #'shared-initialize (list proto t)))))))
     1877      (let* ((slotds (sort (copy-list (class-slots class)) #'< :key #'slot-definition-location))
     1878             (default-initargs (class-default-initargs class)))
     1879        ;; Punt if any slot has multiple initargs
     1880        (when (dolist (slot slotds t)
     1881                (when (cdr (slot-definition-initargs slot))
     1882                  (return nil)))
     1883          (collect ((keys)
     1884                    (binds)
     1885                    (forms))
     1886            (dolist (slot slotds)
     1887              (let* ((initarg (car (slot-definition-initargs slot)))
     1888                     (initfunction (slot-definition-initfunction slot))
     1889                     (initform (slot-definition-initform slot))
     1890                     (name (slot-definition-name slot))
     1891                     (initial-value-form (if initfunction
     1892                                           (if (self-evaluating-p initform)
     1893                                             initform
     1894                                             `(funcall ,initfunction))
     1895                                           `(%slot-unbound-marker)))
     1896                     (type (slot-definition-type slot)))
     1897                (if initarg
     1898                  (keys (list
     1899                         (list initarg name)
     1900                         (let* ((default (assq initarg default-initargs)))
     1901                           (if default
     1902                             (destructuring-bind (form function)
     1903                                 (cdr default)
     1904                               (if (self-evaluating-p form)
     1905                                 form
     1906                                 `(funcall ,function)))
     1907                             initial-value-form))))
     1908                  (binds (list name initial-value-form)))
     1909                (if (eq type t)
     1910                  (forms name)
     1911                  (forms `(require-type ,name ',type)))))
     1912            (let* ((cell (make-symbol "CLASS-CELL"))
     1913                   (slots (make-symbol "SLOTS"))
     1914                   (instance (make-symbol "INSTANCE")))
     1915              (binds `(,slots (gvector :slot-vector nil ,@(forms))))
     1916              (binds `(,instance (gvector :instance 0 (class-cell-extra ,cell) ,slots)))
     1917              `(lambda (,cell &key ,@(keys))
     1918                (let* (,@(binds))
     1919                  (setf (instance.hash ,instance) (strip-tag-to-fixnum ,instance)
     1920                        (%svref ,slots 0) ,instance))))))))))
     1921
     1922(defun optimize-make-instance-for-class-cell (cell)
     1923  (setf (class-cell-instantiate cell) '%make-instance)
     1924  (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
     1925    (when lambda
     1926      (setf (class-cell-instantiate cell) (compile nil lambda)
     1927            (class-cell-extra cell) (%class.own-wrapper
     1928                                     (class-cell-class cell)))
     1929      t)))
     1930
     1931(defun optimize-make-instance-for-class-name (class-name)
     1932  (optimize-make-instance-for-class-cell (find-class-cell class-name t)))
     1933
     1934(defun optimize-named-class-make-instance-methods ()
     1935  (maphash (lambda (class-name class-cell)
     1936             (handler-case (optimize-make-instance-for-class-cell class-cell)
     1937               (error (c)
     1938                      (warn "error optimizing make-instance for ~s:~&~a"
     1939                            class-name c))))
     1940           %find-classes%))
     1941
    18691942;;; Iterate over all known GFs; try to optimize their dcode in cases
    18701943;;; involving reader methods.
     
    18821955        (incf nwin)))
    18831956    (values ngf nwin 0)))
     1957
Note: See TracChangeset for help on using the changeset viewer.