[Openmcl-cvs-notifications] r11364 - /trunk/source/level-1/l1-clos.lisp

[gz at clozure.com]

Author: gz
Date: Sat Nov 15 09:26:39 2008
New Revision: 11364

Log:
Keep track of reader methods that have been snapped and unsnap them wheneve=
r slots are redefined

Modified:
    trunk/source/level-1/l1-clos.lisp

Modified: trunk/source/level-1/l1-clos.lisp
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=3D=
=3D=3D=3D
--- trunk/source/level-1/l1-clos.lisp (original)
+++ trunk/source/level-1/l1-clos.lisp Sat Nov 15 09:26:39 2008
@@ -301,6 +301,19 @@
 =

 (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 opti=
mized to
+   depend in some way on the layout of the class")
+
+(defun note-class-dependent (class gf)
+  (pushnew gf (gethash class *optimized-dependents*)))
+
+;; Yeah, yeah, when/if this gets more general can use generic functions.
+(defun unoptimize-dependents (class)
+  (loop for obj in (gethash class *optimized-dependents*)
+        do (etypecase obj
+             (standard-generic-function (compute-dcode obj)))))
+
 (defun update-slots (class eslotds)
   (let* ((instance-slots (extract-slotds-with-allocation :instance eslotds=
))
          (new-ordering
@@ -320,6 +333,8 @@
                 (t
                  (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
           (%wrapper-class-slots new-wrapper) (%class-get class :class-slot=
s)
@@ -2002,9 +2017,8 @@
           (unique class))))))
 =

 =

-
 ;;; Try to replace gf dispatch with something faster in f.
-(defun %snap-reader-method (f)
+(defun %snap-reader-method (f &key (redefinable t))
   (when (slot-boundp f 'methods)
     (let* ((methods (generic-function-methods f)))
       (when (and methods
@@ -2030,6 +2044,9 @@
               ;; :allocation :instance (and all locations - the CDRs
               ;; of the alist pairs - are small, positive fixnums.
               (when (every (lambda (pair) (typep (cdr pair) 'fixnum)) alis=
t)
+                (when redefinable
+                  (loop for (c . nil) in alist
+                        do (note-class-dependent c f)))
                 (clear-gf-dispatch-table dt)
                 (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-stan=
dard
                 (cond ((null (cdr alist))