Changeset 11410

Timestamp:

Nov 19, 2008, 2:32:53 AM (12 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:

branches/working-0711/ccl/level-1

Files:

• l1-clos-boot.lisp (modified) (1 diff)
• l1-clos.lisp (modified) (11 diffs)

branches/working-0711/ccl/level-1/l1-clos-boot.lisp

@@ -1318 +1318 @@
           (find-class name errorp environment)))))
 
+(fset 'pessimize-make-instance-for-class-name ;; redefined later
+      (qlfun bootstrapping-pessimize-make-instance-for-class-name (name) name))
+
 (defun update-class-proper-names (name old-class new-class)
+  (when name
+    (pessimize-make-instance-for-class-name name))
   (when (and old-class
              (not (eq old-class new-class))

branches/working-0711/ccl/level-1/l1-clos.lisp

@@ -309 +309 @@
   (pushnew gf (gethash class *optimized-dependents*)))
 
-;; Yeah, yeah, when/if this gets more general can use generic functions.
 (defun unoptimize-dependents (class)
+  (pessimize-make-instance-for-class-name (%class-name class))
   (loop for obj in (gethash class *optimized-dependents*)
         do (etypecase obj
-             (standard-generic-function (compute-dcode obj)))))
+             (standard-generic-function
+              (clear-gf-dispatch-table (%gf-dispatch-table obj))
+              (compute-dcode obj)))))
 
 (defun update-slots (class eslotds)
@@ -332 +334 @@
                  old-wrapper)
                 (t
+                 (unoptimize-dependents class)
                  (make-instances-obsolete class)
                  (%cons-wrapper class)))))
-    (when old-wrapper
-      (unoptimize-dependents class))
     (setf (%class-slots class) eslotds)
     (setf (%wrapper-instance-slots new-wrapper) new-ordering
@@ -794 +795 @@
   (let ((cell (find-class-cell class-name nil)))
     (when cell
-      (setf (class-cell-instantiate cell) '%make-instance))))
+      (init-class-cell-instantiator cell))))
+
+(defun init-class-cell-instantiator (cell)
+  (when cell
+    (setf (class-cell-instantiate cell) '%make-instance)
+    (setf (class-cell-extra cell) nil)))
 
 ;;; Redefine an existing (not forward-referenced) class.
@@ -802 +808 @@
     (unless (eq (class-of class) metaclass)
       (error "Can't change metaclass of ~s to ~s." class metaclass))
-    (pessimize-make-instance-for-class-name name)
     (apply #'reinitialize-instance class initargs)
     (setf (find-class name) class)))
@@ -808 +813 @@
 
 (defun ensure-class (name &rest keys &key &allow-other-keys)
-  (declare (special *sealed-clos-world*))
-  (if *sealed-clos-world*
-    (error "Class (re)definition is not allowed in this environment")
-    (apply #'ensure-class-using-class (find-class name nil) name keys)))
+  (declare (dynamic-extent keys))
+  (apply #'ensure-class-using-class (find-class name nil) name keys))
 
 (defparameter *defclass-redefines-improperly-named-classes-pedantically* 
@@ -821 +824 @@
 
 (defun ensure-class-for-defclass (name &rest keys &key &allow-other-keys)
-  (declare (special *sealed-clos-world*))
-  (if *sealed-clos-world*
-    (error "Class (re)definition is not allowed in this environment")
-    (progn
-      (record-source-file name 'class)
-      ;; Maybe record source-file information for accessors as well
-      ;; We should probably record them as "accessors of the class", since
-      ;; there won't be any other explicit defining form associated with
-      ;; them.
-      (let* ((existing-class (find-class name nil)))
-        (when (and *defclass-redefines-improperly-named-classes-pedantically* 
-                   existing-class 
-                   (not (eq (class-name existing-class) name)))
-          ;; Class isn't properly named; act like it didn't exist
-          (setq existing-class nil))
-        (apply #'ensure-class-using-class existing-class name keys)))))
+  (declare (dynamic-extent keys))
+  (record-source-file name 'class)
+  (let* ((existing-class (find-class name nil)))
+    (when (and *defclass-redefines-improperly-named-classes-pedantically* 
+               existing-class 
+               (not (eq (class-name existing-class) name)))
+      ;; Class isn't properly named; act like it didn't exist
+      (setq existing-class nil))
+    (apply #'ensure-class-using-class existing-class name keys)))
 
 
@@ -2371 +2367 @@
 
 (defun optimize-make-instance-for-class-cell (cell)
-  (setf (class-cell-instantiate cell) '%make-instance)
+  (init-class-cell-instantiator cell)
   (let* ((lambda (make-instantiate-lambda-for-class-cell cell)))
     (when lambda
@@ -2397 +2393 @@
             (eq gfn #'initialize-instance)
             (eq gfn #'shared-initialize))
-    (let* ((specializer (car (method-specializers method)))
-           (cell (and (typep specializer 'class)
-                      (gethash (class-name specializer) %find-classes%))))
-      (when cell
-        (setf (class-cell-instantiate cell) '%make-instance)))))            
+    (let ((specializer (car (method-specializers method))))
+      (when (typep specializer 'class)
+        (labels ((clear (class)
+                   (pessimize-make-instance-for-class-name (class-name class))
+                   (dolist (sub (%class-direct-subclasses class))
+                     (clear sub))))
+          (clear specializer))))))
 
 ;;; Iterate over all known GFs; try to optimize their dcode in cases
@@ -2410 +2408 @@
                                  (optimize-make-instance t))
   (declare (ignore check-conflicts)
-           (special *sealed-clos-world*))
-  (unless known-sealed-world
-    (cerror "Proceed, if it's known that no new classes or methods will be defined."
-            "Optimizing reader methods in this way is only safe if it's known that no new classes or methods will be defined."))
+           (ignore known-sealed-world))
   (when optimize-make-instance
     (optimize-named-class-make-instance-methods))
@@ -2422 +2417 @@
       (when (%snap-reader-method f)
         (incf nwin)))
-    (setq *sealed-clos-world* t)
     (values ngf nwin 0)))
 
@@ -2437 +2431 @@
 
 (defun pessimize-clos ()
-  (declare (special *sealed-clos-world*))
-  (when *sealed-clos-world*
-    ;; Undo MAKE-INSTANCE optimization
-    (maphash (lambda (class-name class-cell)
-               (declare (ignore class-name))
-               (setf (class-cell-instantiate class-cell) '%make-instance))
-             %find-classes%)
-    ;; Un-snap reader methods, undo other GF optimizations.
-    (dolist (f (population-data %all-gfs%))
-      (let* ((dt (%gf-dispatch-table f)))
-        (clear-gf-dispatch-table dt)
-        (compute-dcode f)))
-    (setq *sealed-clos-world* nil)
-    t))
+  ;; Undo MAKE-INSTANCE optimization
+  (maphash (lambda (class-name class-cell)
+             (declare (ignore class-name))
+             (init-class-cell-instantiator class-cell))
+           %find-classes%)
+  ;; Un-snap reader methods, undo other GF optimizations.
+  (dolist (f (population-data %all-gfs%))
+    (let* ((dt (%gf-dispatch-table f)))
+      (clear-gf-dispatch-table dt)
+      (compute-dcode f))))
 
 ;;; If there's a single method (with standard method combination) on