Changeset 14860

Timestamp:

Jul 2, 2011, 3:37:33 AM (13 years ago)

Author:

Gary Byers

Message:

In CLEAR-GF-CACHE, don't do anything if the dispatch table's
ARGNUM slot has a negative value.

In %SNAP-READER-METHOD, if the gf's dispatch table's argnum
is non-negative, complement it and store the gf's dcode in
the dt's GENERIC-FUNCTION slot.

In PESSIMIZE-CLOS, if a GF's dispatch-table's argnum is negative,
complement it and set the gf's dcode to the value saved in the
dispatch-table's GENERIC-FUNCTION slot. (We can't use COMPUTE-DCODE
to restore the GF's dcode, since it calls slot accessors, possibly
including the one that we're modifying in a non-atomic way.)

It's not clear that PESSIMIZE-CLOS has to deal with anything but
snapped reader methods; DCODE-FOR-UNIVERSALLY-APPLICABLE-SINGLETON
looks like it was half-finished. If we do things like that, we may
need to adopt and follow similar conventions to allow it to be undone,

Location:

trunk/source/level-1

Files:

• l1-clos.lisp (modified) (2 diffs)
• l1-dcode.lisp (modified) (1 diff)

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

@@ -2137 +2137 @@
                         do (note-class-dependent c f)))
                 (clear-gf-dispatch-table dt)
-                (setf (%gf-dispatch-table-argnum dt) -1) ;mark as non-standard
+                (let* ((argnum (%gf-dispatch-table-argnum dt)))
+                  (unless (< argnum 0)
+                    (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
+                          (%gf-dispatch-table-gf dt) (%gf-dcode f))))
+                    
                 (cond ((null (cdr alist))
                        ;; Method is only applicable to a single class.
@@ -2531 +2535 @@
   ;; 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))))
+    (let* ((dt (%gf-dispatch-table f))
+           (argnum (%gf-dispatch-table-argnum dt)))
+      (when (< argnum 0)
+        (let* ((dcode (%gf-dispatch-table-gf dt)))
+          (setf (%gf-dispatch-table-argnum dt) (lognot argnum)
+                (%gf-dispatch-table-gf dt) f
+                (%gf-dcode f) dcode)
+        (clear-gf-dispatch-table dt))))))
 
 ;;; If there's a single method (with standard method combination) on

trunk/source/level-1/l1-dcode.lisp

@@ -182 +182 @@
 (defun clear-gf-cache (gf)
   #-bccl (unless t (typep gf 'standard-generic-function) 
-           (report-bad-arg gf 'standard-generic-function))
+                 (report-bad-arg gf 'standard-generic-function))
   (let ((dt (%gf-dispatch-table gf)))
-    (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*)
-      (clear-gf-dispatch-table dt)
-      (let ((new (make-gf-dispatch-table)))
-        (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt))
-        (setf (%gf-dispatch-table-precedence-list new)
-              (%gf-dispatch-table-precedence-list dt))
-        (setf (%gf-dispatch-table-gf new) gf)
-        (setf (%gf-dispatch-table-keyvect new)
-              (%gf-dispatch-table-keyvect dt))
-        (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt))
-        (setf (%gf-dispatch-table gf) new)))))
+    (unless (< (%gf-dispatch-table-argnum dt) 0) ;reader-method optimization
+      (if (eq (%gf-dispatch-table-size dt) *min-gf-dispatch-table-size*)
+        (clear-gf-dispatch-table dt)
+        (let ((new (make-gf-dispatch-table)))
+          (setf (%gf-dispatch-table-methods new) (%gf-dispatch-table-methods dt))
+          (setf (%gf-dispatch-table-precedence-list new)
+                (%gf-dispatch-table-precedence-list dt))
+          (setf (%gf-dispatch-table-gf new) gf)
+          (setf (%gf-dispatch-table-keyvect new)
+                (%gf-dispatch-table-keyvect dt))
+          (setf (%gf-dispatch-table-argnum new) (%gf-dispatch-table-argnum dt))
+          (setf (%gf-dispatch-table gf) new))))))
 
 (defun %gf-dispatch-table-store-conditional (dt index new)