From eddd81f4652db72a085f7c8dfe2ca04b7c4de829 Mon Sep 17 00:00:00 2001
From: Andy Wingo <wingo@pobox.com>
Date: Fri, 2 Sep 2011 13:17:19 +0200
Subject: [PATCH] fix some cache consistency issues with goops and extended
 generics

* module/oop/goops.scm (extended-by!, not-extended-by!)
  (upgrade-accessor, merge-generics): Invalidate the method cache after
  munging "extends" or "methods" fields.
  (invalidate-method-cache!): A new wrapper around
  %invalidate-method-cache!, that will also invalidate the caches of
  "extended-by" generics.
  (internal-add-method!, remove-class-accessors!): Use the new
  invalidate-method-cache!.
---
 module/oop/goops.scm | 30 ++++++++++++++++++++++--------
 1 file changed, 22 insertions(+), 8 deletions(-)

diff --git a/module/oop/goops.scm b/module/oop/goops.scm
index e1908abf0..e4424f382 100644
--- a/module/oop/goops.scm
+++ b/module/oop/goops.scm
@@ -366,13 +366,15 @@
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (cons eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define (not-extended-by! gfs eg)
   (for-each (lambda (gf)
 	      (slot-set! gf 'extended-by
 			 (delq! eg (slot-ref gf 'extended-by))))
-	    gfs))
+	    gfs)
+  (invalidate-method-cache! eg))
 
 (define* (ensure-generic old-definition #:optional name)
   (cond ((is-a? old-definition <generic>) old-definition)
@@ -441,6 +443,7 @@
 		(slot-set! method 'generic-function gws))
 	      methods)
     (slot-set! gws 'methods methods)
+    (invalidate-method-cache! gws)
     gws))
 
 ;;;
@@ -605,15 +608,25 @@
 		methods)
 	      (loop (cdr l)))))))
 
+(define (method-n-specializers m)
+  (length* (slot-ref m 'specializers)))
+
+(define (calculate-n-specialized gf)
+  (fold (lambda (m n) (max n (method-n-specializers m)))
+        0
+        (generic-function-methods gf)))
+
+(define (invalidate-method-cache! gf)
+  (%invalidate-method-cache! gf)
+  (slot-set! gf 'n-specialized (calculate-n-specialized gf))
+  (for-each (lambda (gf) (invalidate-method-cache! gf))
+            (slot-ref gf 'extended-by)))
+
 (define internal-add-method!
   (method ((gf <generic>) (m <method>))
     (slot-set! m  'generic-function gf)
     (slot-set! gf 'methods (compute-new-list-of-methods gf m))
-    (let ((specializers (slot-ref m 'specializers)))
-      (slot-set! gf 'n-specialized
-                 (max (length* specializers)
-                      (slot-ref gf 'n-specialized))))
-    (%invalidate-method-cache! gf)
+    (invalidate-method-cache! gf)
     (add-method-in-classes! m)
     *unspecified*))
 
@@ -839,6 +852,7 @@
 	 (slot-set! val2
 		    'extended-by
 		    (cons gf (delq! gf (slot-ref val2 'extended-by))))
+         (invalidate-method-cache! gf)
 	 var)))
 
 (module-define! duplicate-handlers 'merge-generics merge-generics)
@@ -1022,7 +1036,7 @@
 		    ;; remove the method from its GF
 		    (slot-set! gf 'methods
 			       (delq1! m (slot-ref gf 'methods)))
-		    (%invalidate-method-cache! gf)
+		    (invalidate-method-cache! gf)
 		    ;; remove the method from its specializers
 		    (remove-method-in-classes! m))))
 	    (class-direct-methods c)))