Changeset 11409


Ignore:
Timestamp:
Nov 19, 2008, 2:30:26 AM (11 years ago)
Author:
gz
Message:

undo make-instance optimizations when class slots change and when classes are renamed. Get rid of *sealed-clos-world* because all the optimizations should now be safe

Location:
trunk/source/level-1
Files:
2 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-clos-boot.lisp

    r10942 r11409  
    13181318          (find-class name errorp environment)))))
    13191319
     1320(fset 'pessimize-make-instance-for-class-name ;; redefined later
     1321      (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name))
     1322
    13201323(defun update-class-proper-names (name old-class new-class)
     1324  (when name
     1325    (pessimize-make-instance-for-class-name name))
    13211326  (when (and old-class
    13221327             (not (eq old-class new-class))
  • trunk/source/level-1/l1-clos.lisp

    r11399 r11409  
    309309  (pushnew gf (gethash class *optimized-dependents*)))
    310310
    311 ;; Yeah, yeah, when/if this gets more general can use generic functions.
    312311(defun unoptimize-dependents (class)
     312  (pessimize-make-instance-for-class-name (%class-name class))
    313313  (loop for obj in (gethash class *optimized-dependents*)
    314314        do (etypecase obj
    315              (standard-generic-function (compute-dcode obj)))))
     315             (standard-generic-function
     316              (clear-gf-dispatch-table (%gf-dispatch-table obj))
     317              (compute-dcode obj)))))
    316318
    317319(defun update-slots (class eslotds)
     
    332334                 old-wrapper)
    333335                (t
     336                 (unoptimize-dependents class)
    334337                 (make-instances-obsolete class)
    335338                 (%cons-wrapper class)))))
    336     (when old-wrapper
    337       (unoptimize-dependents class))
    338339    (setf (%class-slots class) eslotds)
    339340    (setf (%wrapper-instance-slots new-wrapper) new-ordering
     
    794795  (let ((cell (find-class-cell class-name nil)))
    795796    (when cell
    796       (setf (class-cell-instantiate cell) '%make-instance))))
     797      (init-class-cell-instantiator cell))))
     798
     799(defun init-class-cell-instantiator (cell)
     800  (when cell
     801    (setf (class-cell-instantiate cell) '%make-instance)
     802    (setf (class-cell-extra cell) nil)))
    797803
    798804;;; Redefine an existing (not forward-referenced) class.
     
    802808    (unless (eq (class-of class) metaclass)
    803809      (error "Can't change metaclass of ~s to ~s." class metaclass))
    804     (pessimize-make-instance-for-class-name name)
    805810    (apply #'reinitialize-instance class initargs)
    806811    (setf (find-class name) class)))
     
    808813
    809814(defun ensure-class (name &rest keys &key &allow-other-keys)
    810   (declare (special *sealed-clos-world*))
    811   (if *sealed-clos-world*
    812     (error "Class (re)definition is not allowed in this environment")
    813     (apply #'ensure-class-using-class (find-class name nil) name keys)))
     815  (declare (dynamic-extent keys))
     816  (apply #'ensure-class-using-class (find-class name nil) name keys))
    814817
    815818(defparameter *defclass-redefines-improperly-named-classes-pedantically*
     
    821824
    822825(defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
    823   (declare (special *sealed-clos-world*))
    824   (if *sealed-clos-world*
    825     (error "Class (re)definition is not allowed in this environment")
    826     (progn
    827       (record-source-file name 'class)
    828       ;; Maybe record source-file information for accessors as well
    829       ;; We should probably record them as "accessors of the class", since
    830       ;; there won't be any other explicit defining form associated with
    831       ;; them.
    832       (let* ((existing-class (find-class name nil)))
    833         (when (and *defclass-redefines-improperly-named-classes-pedantically*
    834                    existing-class
    835                    (not (eq (class-name existing-class) name)))
    836           ;; Class isn't properly named; act like it didn't exist
    837           (setq existing-class nil))
    838         (apply #'ensure-class-using-class existing-class name keys)))))
     826  (declare (dynamic-extent keys))
     827  (record-source-file name 'class)
     828  (let* ((existing-class (find-class name nil)))
     829    (when (and *defclass-redefines-improperly-named-classes-pedantically*
     830               existing-class
     831               (not (eq (class-name existing-class) name)))
     832      ;; Class isn't properly named; act like it didn't exist
     833      (setq existing-class nil))
     834    (apply #'ensure-class-using-class existing-class name keys)))
    839835
    840836
     
    23712367
    23722368(defun optimize-make-instance-for-class-cell (cell)
    2373   (setf (class-cell-instantiate cell) '%make-instance)
     2369  (init-class-cell-instantiator cell)
    23742370  (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
    23752371    (when lambda
     
    23972393            (eq gfn #'initialize-instance)
    23982394            (eq gfn #'shared-initialize))
    2399     (let* ((specializer (car (method-specializers method)))
    2400            (cell (and (typep specializer 'class)
    2401                       (gethash (class-name specializer) %find-classes%))))
    2402       (when cell
    2403         (setf (class-cell-instantiate cell) '%make-instance)))))           
     2395    (let ((specializer (car (method-specializers method))))
     2396      (when (typep specializer 'class)
     2397        (labels ((clear (class)
     2398                   (pessimize-make-instance-for-class-name (class-name class))
     2399                   (dolist (sub (%class-direct-subclasses class))
     2400                     (clear sub))))
     2401          (clear specializer))))))
    24042402
    24052403;;; Iterate over all known GFs; try to optimize their dcode in cases
     
    24102408                                 (optimize-make-instance t))
    24112409  (declare (ignore check-conflicts)
    2412            (special *sealed-clos-world*))
    2413   (unless known-sealed-world
    2414     (cerror "Proceed, if it's known that no new classes or methods will be defined."
    2415             "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
     2410           (ignore known-sealed-world))
    24162411  (when optimize-make-instance
    24172412    (optimize-named-class-make-instance-methods))
     
    24222417      (when (%snap-reader-method f)
    24232418        (incf nwin)))
    2424     (setq *sealed-clos-world* t)
    24252419    (values ngf nwin 0)))
    24262420
     
    24372431
    24382432(defun pessimize-clos ()
    2439   (declare (special *sealed-clos-world*))
    2440   (when *sealed-clos-world*
    2441     ;; Undo MAKE-INSTANCE optimization
    2442     (maphash (lambda (class-name class-cell)
    2443                (declare (ignore class-name))
    2444                (setf (class-cell-instantiate class-cell) '%make-instance))
    2445              %find-classes%)
    2446     ;; Un-snap reader methods, undo other GF optimizations.
    2447     (dolist (f (population-data %all-gfs%))
    2448       (let* ((dt (%gf-dispatch-table f)))
    2449         (clear-gf-dispatch-table dt)
    2450         (compute-dcode f)))
    2451     (setq *sealed-clos-world* nil)
    2452     t))
     2433  ;; Undo MAKE-INSTANCE optimization
     2434  (maphash (lambda (class-name class-cell)
     2435             (declare (ignore class-name))
     2436             (init-class-cell-instantiator class-cell))
     2437           %find-classes%)
     2438  ;; Un-snap reader methods, undo other GF optimizations.
     2439  (dolist (f (population-data %all-gfs%))
     2440    (let* ((dt (%gf-dispatch-table f)))
     2441      (clear-gf-dispatch-table dt)
     2442      (compute-dcode f))))
    24532443
    24542444;;; If there's a single method (with standard method combination) on
Note: See TracChangeset for help on using the changeset viewer.