From: Christophe Rhodes <csr21@cantab.net>
Date: Mon, 16 Dec 2013 16:30:05 +0000 (+0000)
Subject: new protocol function GENERALIZER-EQUAL-HASH-KEY
X-Git-Tag: els2014-submission~22
X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=commitdiff_plain;h=4f8b7a9cbde446b6576f81178534abe8b47659a1

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 3922a6a..4540b5f 100644
--- 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 c9f34ad..c69f786 100644
--- 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))