X-Git-Url: http://christophe.rhodes.io/gitweb/?p=specializable.git;a=blobdiff_plain;f=specializable.lisp;fp=specializable.lisp;h=e556db4caff1e2a2f0818c97ed64802111a4c097;hp=bf04833d243debab1e1e6092d69ad7ff3536789f;hb=45b462c73d230a864be17e9bd701b5a421e635c1;hpb=f5a9f1d7f4c9253aef7f2510dbcf083e3c89a14b

diff --git a/specializable.lisp b/specializable.lisp
index bf04833..e556db4 100644
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -46,7 +46,9 @@
 (defclass specializable-generic-function (standard-generic-function)
   ((extended-specializers :initform (make-hash-table :test 'equal)
                           :reader generic-function-extended-specializers)
-   (emf-table :initform (make-hash-table :test 'equal) :reader emf-table))
+   (emf-table :initform (make-hash-table :test 'equal) :reader emf-table)
+   (cacheingp :initform t :initarg :cacheingp)
+   (single-arg-cacheing-p :initform t :initarg :single-arg-cacheing-p))
   (:metaclass sb-mop:funcallable-standard-class)
   (:default-initargs :method-class (find-class 'specializable-method)))
 
@@ -123,7 +125,8 @@
 
 (defun first-arg-only-special-case (gf)
   (let ((arg-info (sb-pcl::gf-arg-info gf)))
-    (and (>= (sb-pcl::arg-info-number-required arg-info) 1)
+    (and (slot-value gf 'single-arg-cacheing-p)
+         (>= (sb-pcl::arg-info-number-required arg-info) 1)
          (every (lambda (x) (eql x t))
                 (cdr (sb-pcl::arg-info-metatypes arg-info))))))
 
@@ -136,42 +139,52 @@
 ;;; - speed
 ;;; - interaction with TRACE et al.
 (defmethod sb-mop:compute-discriminating-function ((gf specializable-generic-function))
-  (if (first-arg-only-special-case gf)
-      (lambda (&rest args)
-        (let* ((g (generalizer-of-using-class gf (car args)))
-               (k (generalizer-equal-hash-key gf g))
-               (emfun (gethash k (emf-table gf) nil)))
-          (if emfun
-              (sb-pcl::invoke-emf emfun args)
-              (slow-method-lookup gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                                          (cdr (required-portion gf args))))))))
-      (lambda (&rest args)
-        (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
-                                     (required-portion gf args)))
-               (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))))))
+  (cond
+    ((not (slot-value gf 'cacheingp))
+     (lambda (&rest args)
+       (let ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                   args)))
+         (slow-method-lookup-and-call gf args generalizers))))
+    ((first-arg-only-special-case gf)
+     (lambda (&rest args)
+       (let* ((g (generalizer-of-using-class gf (car args)))
+              (k (generalizer-equal-hash-key gf g))
+              (emfun (gethash k (emf-table gf) nil)))
+         (if emfun
+             (sb-pcl::invoke-emf emfun args)
+             (slow-method-lookup-and-call
+              gf args (cons g (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                      (cdr (required-portion gf args)))))))))
+    (t
+     (lambda (&rest args)
+       (let* ((generalizers (mapcar (lambda (x) (generalizer-of-using-class gf x))
+                                    (required-portion gf args)))
+              (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-and-call gf args generalizers)))))))
 
 (defmethod reinitialize-instance :after ((gf specializable-generic-function) &key)
   (clrhash (emf-table gf)))
 
 (defun slow-method-lookup (gf args generalizers)
-  ;; differs from closette
   (multiple-value-bind (applicable-methods definitivep)
       (compute-applicable-methods-using-generalizers gf generalizers)
-    (if definitivep
-	(let* ((emfun
-                (compute-effective-method-function gf applicable-methods))
-               (keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
-          (if (first-arg-only-special-case gf)
-              (setf (gethash (car keys) (emf-table gf)) emfun)
-              (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))
-                            args))))
+    (unless definitivep
+      (setf applicable-methods (compute-applicable-methods gf args)))
+    (values (compute-effective-method-function gf applicable-methods)
+            definitivep)))
+
+(defun slow-method-lookup-and-call (gf args generalizers)
+  (multiple-value-bind (emf cacheablep)
+      (slow-method-lookup gf args generalizers)
+    (when cacheablep
+      (let ((keys (mapcar (lambda (x) (generalizer-equal-hash-key gf x)) generalizers)))
+        (if (first-arg-only-special-case gf)
+            (setf (gethash (car keys) (emf-table gf)) emf)
+            (setf (gethash keys (emf-table gf)) emf))))
+    (sb-pcl::invoke-emf emf args)))
 
 (defun compute-effective-method-function (gf methods)
   (if (null methods)