Index: /trunk/source/level-1/l1-clos-boot.lisp =================================================================== --- /trunk/source/level-1/l1-clos-boot.lisp (revision 15426) +++ /trunk/source/level-1/l1-clos-boot.lisp (revision 15427) @@ -24,4 +24,15 @@ (in-package "CCL") + + +(defstatic *clos-optimizations-active* nil) + +(defun disable-clos-optimizations (operation operand) + (when *clos-optimizations-active* + (cerror "Peform the requested operation after disabling CLOS optimizations.~&To reenable CLOS optimizations, call (CCL::SNAP-READER-METHODS :KNOWN-SEALED-WORLD T :OPTIMIZE-MAKE-INSTANCE T)." + "CLOS optimizations are in effect, so it isn't safe to ~a ~s." operation operand) + (setq *clos-optimizations-active* nil) + (pessimize-clos) + t)) ;;; Early accessors. These functions eventually all get replaced with @@ -646,4 +657,5 @@ &allow-other-keys) (declare (dynamic-extent keys)) + (disable-clos-optimizations 'ensure-generic-function function-name) (when gfc-p (if (symbolp generic-function-class) @@ -667,4 +679,5 @@ (lambda-list nil ll-p) name) + (disable-clos-optimizations 'ensure-generic-function function-name) (when gfc-p (if (symbolp generic-function-class) @@ -867,9 +880,5 @@ (%add-standard-method-to-standard-gf gf method)) -;; Redefined in l1-clos.lisp -(fset 'maybe-remove-make-instance-optimization - (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method) - (declare (ignore gfn method)) - nil)) + (defun %add-standard-method-to-standard-gf (gfn method) @@ -882,5 +891,4 @@ (qualifiers (%method-qualifiers method))) (remove-obsoleted-combined-methods method dt specializers) - (maybe-remove-make-instance-optimization gfn method) (apply #'invalidate-initargs-vector-for-gf gfn specializers) (dolist (m methods) Index: /trunk/source/level-1/l1-clos.lisp =================================================================== --- /trunk/source/level-1/l1-clos.lisp (revision 15426) +++ /trunk/source/level-1/l1-clos.lisp (revision 15427) @@ -295,23 +295,4 @@ (defvar *update-slots-preserve-existing-wrapper* nil) -(defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key) - "Hash table mapping a class to a list of all objects that have been optimized to - depend in some way on the layout of the class") - -(defun note-class-dependent (class gf) - (pushnew gf (gethash class *optimized-dependents*))) - -(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 - (let* ((dt (%gf-dispatch-table obj)) - (argnum (%gf-dispatch-table-argnum dt))) - (when (< argnum 0) - (setf (%gf-dispatch-table-argnum dt) (lognot argnum) - (%gf-dcode obj) (%gf-dispatch-table-gf dt) - (%gf-dispatch-table-gf dt) obj) - (clear-gf-dispatch-table dt))))))) (defun update-slots (class eslotds) @@ -332,5 +313,4 @@ old-wrapper) (t - (unoptimize-dependents class) (make-instances-obsolete class) (%cons-wrapper class))))) @@ -835,4 +815,5 @@ ;;; This defines a new class. (defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys) + (disable-clos-optimizations "define new class" name) (multiple-value-bind (metaclass initargs) (ensure-class-metaclass-and-initargs class keys) @@ -841,4 +822,5 @@ (defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys) + (disable-clos-optimizations "define new class" name) (multiple-value-bind (metaclass initargs) (ensure-class-metaclass-and-initargs class keys) @@ -861,4 +843,5 @@ ;;; Redefine an existing (not forward-referenced) class. (defmethod ensure-class-using-class ((class class) name &rest keys &key) + (disable-clos-optimizations "redefine existing class" name) (multiple-value-bind (metaclass initargs) (ensure-class-metaclass-and-initargs class keys) @@ -2138,4 +2121,5 @@ ;;; Try to replace gf dispatch with something faster in f. (defun %snap-reader-method (f &key (redefinable t)) + (declare (ignore redefinable)) (when (slot-boundp f 'methods) (let* ((methods (generic-function-methods f))) @@ -2163,7 +2147,4 @@ ;; of the alist pairs - are small, positive fixnums. (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist) - (when redefinable - (loop for (c . nil) in alist - do (note-class-dependent c f))) (clear-gf-dispatch-table dt) (let* ((argnum (%gf-dispatch-table-argnum dt))) @@ -2513,18 +2494,6 @@ %find-classes%)) -;; Redefined from bootstrapping verison in l1-clos-boot.lisp -;; Remove the make-instance optimization if the user is adding -;; a method on initialize-instance, allocate-instance, or shared-initialize -(defun maybe-remove-make-instance-optimization (gfn method) - (when (or (eq gfn #'allocate-instance) - (eq gfn #'initialize-instance) - (eq gfn #'shared-initialize)) - (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 @@ -2536,13 +2505,20 @@ (declare (ignore check-conflicts) (ignore known-sealed-world)) - (when optimize-make-instance - (optimize-named-class-make-instance-methods)) - (let* ((ngf 0) - (nwin 0)) - (dolist (f (population.data %all-gfs%)) - (incf ngf) - (when (%snap-reader-method f) - (incf nwin))) - (values ngf nwin 0))) + (if *clos-optimizations-active* + (values nil nil 0) + (progn + (setq *clos-optimizations-active* t) + (when optimize-make-instance + (optimize-named-class-make-instance-methods)) + (let* ((ngf 0) + (nwin 0)) + (dolist (f (population.data %all-gfs%)) + (incf ngf) + (when (%snap-reader-method f) + (incf nwin))) + (values ngf nwin 0))))) + + + (defun register-non-dt-dcode-function (f)