Changeset 15427


Ignore:
Timestamp:
Jul 30, 2012, 3:33:49 PM (7 years ago)
Author:
gb
Message:

Disable CLOS optimizations before (re-)defining classes, generic functions.
Seems to fix ticket:976 in the trunk.

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

Legend:

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

    r15400 r15427  
    2424(in-package "CCL")
    2525
     26
     27
     28(defstatic *clos-optimizations-active* nil)
     29
     30(defun disable-clos-optimizations (operation operand)
     31  (when *clos-optimizations-active*
     32    (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)."
     33            "CLOS optimizations are in effect, so it isn't safe to ~a ~s." operation operand)
     34    (setq *clos-optimizations-active* nil)
     35    (pessimize-clos)
     36    t))
    2637
    2738;;; Early accessors.  These functions eventually all get replaced with
     
    646657                   &allow-other-keys)
    647658  (declare (dynamic-extent keys))
     659  (disable-clos-optimizations 'ensure-generic-function function-name)
    648660  (when gfc-p
    649661    (if (symbolp generic-function-class)
     
    667679        (lambda-list nil ll-p)
    668680        name)
     681  (disable-clos-optimizations 'ensure-generic-function function-name)
    669682  (when gfc-p
    670683    (if (symbolp generic-function-class)
     
    867880  (%add-standard-method-to-standard-gf gf method))
    868881
    869 ;; Redefined in l1-clos.lisp
    870 (fset 'maybe-remove-make-instance-optimization
    871       (nlambda bootstrapping-maybe-remove-make-instance-optimization (gfn method)
    872         (declare (ignore gfn method))
    873         nil))
     882
    874883
    875884(defun %add-standard-method-to-standard-gf (gfn method)
     
    882891         (qualifiers (%method-qualifiers method)))
    883892    (remove-obsoleted-combined-methods method dt specializers)
    884     (maybe-remove-make-instance-optimization gfn method)
    885893    (apply #'invalidate-initargs-vector-for-gf gfn specializers)
    886894    (dolist (m methods)
  • trunk/source/level-1/l1-clos.lisp

    r15266 r15427  
    295295(defvar *update-slots-preserve-existing-wrapper* nil)
    296296
    297 (defvar *optimized-dependents* (make-hash-table :test 'eq :weak :key)
    298   "Hash table mapping a class to a list of all objects that have been optimized to
    299    depend in some way on the layout of the class")
    300 
    301 (defun note-class-dependent (class gf)
    302   (pushnew gf (gethash class *optimized-dependents*)))
    303 
    304 (defun unoptimize-dependents (class)
    305   (pessimize-make-instance-for-class-name (%class-name class))
    306   (loop for obj in (gethash class *optimized-dependents*)
    307         do (etypecase obj
    308              (standard-generic-function
    309               (let* ((dt (%gf-dispatch-table obj))
    310                      (argnum (%gf-dispatch-table-argnum dt)))
    311                 (when (< argnum 0)
    312                   (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
    313                         (%gf-dcode obj) (%gf-dispatch-table-gf dt)
    314                         (%gf-dispatch-table-gf dt) obj)
    315                   (clear-gf-dispatch-table dt)))))))
    316297
    317298(defun update-slots (class eslotds)
     
    332313                 old-wrapper)
    333314                (t
    334                  (unoptimize-dependents class)
    335315                 (make-instances-obsolete class)
    336316                 (%cons-wrapper class)))))
     
    835815;;; This defines a new class.
    836816(defmethod ensure-class-using-class ((class null) name &rest keys &key &allow-other-keys)
     817  (disable-clos-optimizations "define new class" name)
    837818  (multiple-value-bind (metaclass initargs)
    838819      (ensure-class-metaclass-and-initargs class keys)
     
    841822
    842823(defmethod ensure-class-using-class ((class forward-referenced-class) name &rest keys &key &allow-other-keys)
     824  (disable-clos-optimizations "define new class" name)
    843825  (multiple-value-bind (metaclass initargs)
    844826      (ensure-class-metaclass-and-initargs class keys)
     
    861843;;; Redefine an existing (not forward-referenced) class.
    862844(defmethod ensure-class-using-class ((class class) name &rest keys &key)
     845  (disable-clos-optimizations "redefine existing class" name) 
    863846  (multiple-value-bind (metaclass initargs)
    864847      (ensure-class-metaclass-and-initargs class keys)
     
    21382121;;; Try to replace gf dispatch with something faster in f.
    21392122(defun %snap-reader-method (f &key (redefinable t))
     2123  (declare (ignore redefinable))
    21402124  (when (slot-boundp f 'methods)
    21412125    (let* ((methods (generic-function-methods f)))
     
    21632147              ;; of the alist pairs - are small, positive fixnums.
    21642148              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
    2165                 (when redefinable
    2166                   (loop for (c . nil) in alist
    2167                         do (note-class-dependent c f)))
    21682149                (clear-gf-dispatch-table dt)
    21692150                (let* ((argnum (%gf-dispatch-table-argnum dt)))
     
    25132494           %find-classes%))
    25142495
    2515 ;; Redefined from bootstrapping verison in l1-clos-boot.lisp
    2516 ;; Remove the make-instance optimization if the user is adding
    2517 ;; a method on initialize-instance, allocate-instance, or shared-initialize
    2518 (defun maybe-remove-make-instance-optimization (gfn method)
    2519   (when (or (eq gfn #'allocate-instance)
    2520             (eq gfn #'initialize-instance)
    2521             (eq gfn #'shared-initialize))
    2522     (let ((specializer (car (method-specializers method))))
    2523       (when (typep specializer 'class)
    2524         (labels ((clear (class)
    2525                    (pessimize-make-instance-for-class-name (class-name class))
    2526                    (dolist (sub (%class-direct-subclasses class))
    2527                      (clear sub))))
    2528           (clear specializer))))))
     2496
     2497
    25292498
    25302499;;; Iterate over all known GFs; try to optimize their dcode in cases
     
    25362505  (declare (ignore check-conflicts)
    25372506           (ignore known-sealed-world))
    2538   (when optimize-make-instance
    2539     (optimize-named-class-make-instance-methods))
    2540   (let* ((ngf 0)
    2541          (nwin 0))
    2542     (dolist (f (population.data %all-gfs%))
    2543       (incf ngf)
    2544       (when (%snap-reader-method f)
    2545         (incf nwin)))
    2546     (values ngf nwin 0)))
     2507  (if *clos-optimizations-active*
     2508    (values nil nil 0)
     2509    (progn
     2510      (setq *clos-optimizations-active* t)
     2511      (when optimize-make-instance
     2512        (optimize-named-class-make-instance-methods))
     2513      (let* ((ngf 0)
     2514             (nwin 0))
     2515        (dolist (f (population.data %all-gfs%))
     2516          (incf ngf)
     2517          (when (%snap-reader-method f)
     2518            (incf nwin)))
     2519        (values ngf nwin 0)))))
     2520
     2521
     2522   
    25472523
    25482524(defun register-non-dt-dcode-function (f)
Note: See TracChangeset for help on using the changeset viewer.