X-Git-Url: http://repo.macrolet.net/gitweb/?a=blobdiff_plain;f=src%2Fpcl%2Fdfun.lisp;h=cc6d267f4f4d591dcdfc3bba19671fcae7960b90;hb=d4b738d6c0b354de817fa490b50814e40872b3d0;hp=2acc37e8827b72402f266f917dd7a9a83934d823;hpb=0756ed4c948806fe79460b1da00c2487cb5ad82b;p=sbcl.git

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index 2acc37e..cc6d267 100644
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -763,17 +763,19 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 ;;; considered as state transitions.
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
+(defvar *max-emf-precomputation-methods* 10)
 
 (defun finalize-specializers (gf)
-  (let ((all-finalized t))
-    (dolist (method (generic-function-methods gf))
-      (dolist (specializer (method-specializers method))
-	(when (and (classp specializer)
-		   (not (class-finalized-p specializer)))
-	  (if (class-has-a-forward-referenced-superclass-p specializer)
-	      (setq all-finalized nil)
-	      (finalize-inheritance specializer)))))
-    all-finalized))
+  (let ((methods (generic-function-methods gf)))
+    (when (<= (length methods) *max-emf-precomputation-methods*)
+      (let ((all-finalized t))
+	(dolist (method methods all-finalized)
+	  (dolist (specializer (method-specializers method))
+	    (when (and (classp specializer)
+		       (not (class-finalized-p specializer)))
+	      (if (class-has-a-forward-referenced-superclass-p specializer)
+		  (setq all-finalized nil)
+		  (finalize-inheritance specializer)))))))))
 
 (defun make-initial-dfun (gf)
   (let ((initial-dfun
@@ -1615,17 +1617,11 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 		    (find-class root)
 		    root)))))
 
-;;; NOTE: We are assuming a restriction on user code that the method
-;;;       combination must not change once it is connected to the
-;;;       generic function.
-;;;
-;;;       This has to be legal, because otherwise any kind of method
-;;;       lookup caching couldn't work. See this by saying that this
-;;;       cache, is just a backing cache for the fast cache. If that
-;;;       cache is legal, this one must be too.
-;;;
-;;; Don't clear this table!
-(defvar *effective-method-table* (make-hash-table :test 'eq))
+(defvar *effective-method-cache* (make-hash-table :test 'eq))
+
+(defun flush-effective-method-cache (generic-function)
+  (dolist (method (generic-function-methods generic-function))
+    (remhash method *effective-method-cache*)))
 
 (defun get-secondary-dispatch-function (gf methods types &optional
 							 method-alist wrappers)
@@ -1653,8 +1649,8 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 	    (lambda (&rest args)
 	      (apply #'no-applicable-method gf args))))
       (let* ((key (car methods))
-	     (ht-value (or (gethash key *effective-method-table*)
-			   (setf (gethash key *effective-method-table*)
+	     (ht-value (or (gethash key *effective-method-cache*)
+			   (setf (gethash key *effective-method-cache*)
 				 (cons nil nil)))))
 	(if (and (null (cdr methods)) all-applicable-p ; the most common case
 		 (null method-alist-p) wrappers-p (not function-p))