added system definition file

[specializable.git] / specializable.lisp

diff --git a/specializable.lisp b/specializable.lisp
index 5a0c09606cef65dce583e9e8052074cd1015584d..e556db4caff1e2a2f0818c97ed64802111a4c097 100644 (file)
--- a/specializable.lisp
+++ b/specializable.lisp
@@ -20,6 +20,7 @@
 (in-package "SPECIALIZABLE")
 
 (defclass extended-specializer (sb-mop:specializer)
+  ;; FIXME: this doesn't actually do quite what I wanted.
   ((direct-methods-table :allocation :class
                          :initform nil :accessor direct-methods-table)))
 
@@ -45,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)))
 
@@ -120,44 +123,76 @@
     ((gf specializable-generic-function) (g class))
   (sb-pcl::class-wrapper g))
 
+(defun first-arg-only-special-case (gf)
+  (let ((arg-info (sb-pcl::gf-arg-info gf)))
+    (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))))))
+
 ;;; FIXME: in some kind of order, the discriminating function needs to handle:
 ;;; - argument count checking;
 ;;; - DONE (in effective method) keyword argument validity;
 ;;; - DONE flushing the emf cache on method addition/removal
 ;;; - DONE (sort of, using wrappers/g-e-h-k) flushing the cache on class redefinition;
 ;;; - cache thread-safety.
+;;; - speed
+;;; - interaction with TRACE et al.
 (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)))
-           (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)))
-         (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)
-  (let* ((mc (sb-mop:generic-function-method-combination gf))
-         (sb-pcl::*applicable-methods* methods)
-         (em (sb-mop:compute-effective-method gf mc methods)))
-    (sb-pcl::make-effective-method-function gf em)))
+  (if (null methods)
+      (lambda (&rest args) (apply #'no-applicable-method gf args))
+      (let* ((mc (sb-mop:generic-function-method-combination gf))
+             (sb-pcl::*applicable-methods* methods)
+             (em (sb-mop:compute-effective-method gf mc methods)))
+        (sb-pcl::make-effective-method-function gf em))))
 
 ;; new, not in closette
 (defgeneric generalizer-of-using-class (generic-function object))