new protocol function GENERALIZER-EQUAL-HASH-KEY

We need arbitrary generalizer objects, not least so as to have
composable specializer functions (if we want generic functions
which can have more than one extended specializer class, we need
to be sure that our generalizers won't stomp on each other).

But that means that cacheing effective methods depends totally on
interning generalizers, which is a bit lame, unless we ask the
extended specializer implementor to provide a subkey to be used
in the key to the emf cache.  This new protocol function is a hook
for exactly that purpose.

(Minimally update the cons specializer example: it's still bad, in
that it uses symbols as the generalizer for conses, but the protocol
in principle at least doesn't leak now.)

diff --git a/cons-specializer.lisp b/cons-specializer.lisp
index 3922a6abd59c09c4f6daf1321fd3f129bd8a621b..4540b5f195fbaa41b4d6fb8374739313c638ec20 100644 (file)
--- a/cons-specializer.lisp
+++ b/cons-specializer.lisp
@@ -9,7 +9,6 @@
 
 (define-extended-specializer cons (gf car)
   (make-instance 'cons-specializer :car car))
-
 (defmethod sb-pcl:unparse-specializer-using-class
     ((gf cons-generic-function) (specializer cons-specializer))
   `(cons ,(%car specializer)))
@@ -17,6 +16,9 @@
     ((s1 cons-specializer) (s2 cons-specializer))
   (eql (%car s1) (%car s2)))
 
+(defmethod generalizer-equal-hash-key ((gf cons-generic-function) (g symbol))
+  g)
+
 (defmethod generalizer-of-using-class ((gf cons-generic-function) arg)
   (typecase arg
     ((cons symbol) (car arg))

diff --git a/specializable.lisp b/specializable.lisp
index c9f34adbae1669883e6dadd3a0871cbedf8ca916..c69f78606ee0cdfa6e45d4295b4e0f7fa1b701aa 100644 (file)
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -13,6 +13,7 @@
 
            "GENERALIZER-OF-USING-CLASS"
            "COMPUTE-APPLICABLE-METHODS-USING-GENERALIZERS"
+           "GENERALIZER-EQUAL-HASH-KEY"
            
            "DEFINE-EXTENDED-SPECIALIZER"))
 
@@ -109,17 +110,23 @@
       (error "Too few arguments to generic function ~S." gf))
     (subseq args 0 number-required)))
 
+(defgeneric generalizer-equal-hash-key (generic-function generalizer))
+(defmethod generalizer-equal-hash-key
+    ((gf specializable-generic-function) (g class))
+  (sb-pcl::class-wrapper g))
+
 ;;; FIXME: in some kind of order, the discriminating function needs to handle:
 ;;; - argument count checking;
 ;;; - keyword argument validity;
 ;;; - DONE flushing the emf cache on method addition/removal
-;;; - flushing the cache on class redefinition;
+;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
 ;;; - cache thread-safety.
 (defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
   (lambda (&rest args)
     (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
                                  (required-portion gf args)))
-          (emfun (gethash generalizers (emf-table gf) nil)))
+           (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers))
+          (emfun (gethash keys (emf-table gf) nil)))
       (if emfun
          (sb-pcl::invoke-emf emfun args)
          (slow-method-lookup gf args generalizers)))))
@@ -133,8 +140,9 @@
       (compute-applicable-methods-using-generalizers gf generalizers)
     (if definitivep
        (let* ((emfun
-               (compute-effective-method-function gf applicable-methods)))
-         (setf (gethash generalizers (emf-table gf)) emfun)
+               (compute-effective-method-function gf applicable-methods))
+               (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+         (setf (gethash keys (emf-table gf)) emfun)
          (sb-pcl::invoke-emf emfun args))
        (sb-pcl::invoke-emf (compute-effective-method-function
                              gf (sb-mop:compute-applicable-methods gf args))
@@ -227,7 +235,7 @@
       (let ((cpl (sb-mop:class-precedence-list generalizer)))
        (if (find s2 (cdr (member s1 cpl)))
            '<
-           nil))))
+            '>))))
 (defmethod specializer<
     ((gf specializable-generic-function) (s1 sb-mop:eql-specializer) (s2 sb-mop:eql-specializer) generalizer)
   (declare (ignore generalizer))