Changeset 15428


Ignore:
Timestamp:
Jul 30, 2012, 9:23:16 PM (7 years ago)
Author:
gb
Message:

Reinstate the *OPTIMIZED-DEPENDENTS* stuff, which reverts some
CLOS optimizations incrementally. Do so because our test suite
expects some of this to happen incrementally, presumably because
our customer (who agreed to use a new mechanism involving CERROR)
expected it to be reverted incrementally.

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

Legend:

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

    r15427 r15428  
    3030(defun disable-clos-optimizations (operation operand)
    3131  (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)
     32    (cerror "Peform the requested operation after disabling CLOS optimizations.~&To reenable CLOS optimizations, call ~s."
     33            (make-condition 'simple-error
     34                           :format-control "CLOS optimizations are in effect, so it isn't safe to ~a ~s."
     35                           :format-arguments (list operation operand))
     36            (cons 'snap-reader-methods *clos-optimizations-active*))
    3437    (setq *clos-optimizations-active* nil)
    3538    (pessimize-clos)
  • trunk/source/level-1/l1-clos.lisp

    r15427 r15428  
    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)))))))
    297316
    298317(defun update-slots (class eslotds)
     
    313332                 old-wrapper)
    314333                (t
     334                 (unoptimize-dependents class)
    315335                 (make-instances-obsolete class)
    316336                 (%cons-wrapper class)))))
     
    21212141;;; Try to replace gf dispatch with something faster in f.
    21222142(defun %snap-reader-method (f &key (redefinable t))
    2123   (declare (ignore redefinable))
    21242143  (when (slot-boundp f 'methods)
    21252144    (let* ((methods (generic-function-methods f)))
     
    21472166              ;; of the alist pairs - are small, positive fixnums.
    21482167              (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alist)
     2168                (when redefinable
     2169                  (loop for (c . nil) in alist
     2170                        do (note-class-dependent c f)))
    21492171                (clear-gf-dispatch-table dt)
    21502172                (let* ((argnum (%gf-dispatch-table-argnum dt)))
     
    25002522;;; involving reader methods.
    25012523
    2502 (defun snap-reader-methods (&key known-sealed-world
     2524(defun snap-reader-methods (&rest args
     2525                                  &key known-sealed-world
    25032526                                 (check-conflicts t)
    25042527                                 (optimize-make-instance t))
     
    25082531    (values nil nil 0)
    25092532    (progn
    2510       (setq *clos-optimizations-active* t)
     2533      (setq *clos-optimizations-active* args)
    25112534      (when optimize-make-instance
    25122535        (optimize-named-class-make-instance-methods))
Note: See TracChangeset for help on using the changeset viewer.