1.0.0.28: more PCL cleanups

[sbcl.git] / src / pcl / dfun.lisp

diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp
index a83e037..0e816d0 100644 (file)
--- a/src/pcl/dfun.lisp
+++ b/src/pcl/dfun.lisp
@@ -756,8 +756,16 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 (defvar *lazy-dfun-compute-p* t)
 (defvar *early-p* nil)
 
+;;; This variable is used for controlling the load-time effective
+;;; method precomputation: precomputation will only be done for emfs
+;;; with fewer than methods than this value. This value has
+;;; traditionally been NIL on SBCL (meaning that precomputation will
+;;; always be done) but that makes method loading O(n^2). Use a small
+;;; value for now, to flush out any possible problems that doing a
+;;; limited amount of precomputation might cause. If none appear, we
+;;; might change it to a larger value later. -- JES, 2006-12-01
 (declaim (type (or null unsigned-byte) *max-emf-precomputation-methods*))
-(defvar *max-emf-precomputation-methods* nil)
+(defvar *max-emf-precomputation-methods* 1)
 
 (defun finalize-specializers (gf)
   (let ((methods (generic-function-methods gf)))
@@ -855,21 +863,6 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
 
 (defvar *new-class* nil)
 
-(defvar *free-hash-tables* (mapcar #'list '(eq equal eql)))
-
-(defmacro with-hash-table ((table test) &body forms)
-  `(let* ((.free. (assoc ',test *free-hash-tables*))
-          (,table (if (cdr .free.)
-                      (pop (cdr .free.))
-                      (make-hash-table :test ',test))))
-     (multiple-value-prog1
-         (progn ,@forms)
-       (clrhash ,table)
-       (push ,table (cdr .free.)))))
-
-(defmacro with-eq-hash-table ((table) &body forms)
-  `(with-hash-table (,table eq) ,@forms))
-
 (defun final-accessor-dfun-type (gf)
   (let ((methods (if (early-gf-p gf)
                      (early-gf-methods gf)
@@ -907,7 +900,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
            'writer))))
 
 (defun make-final-accessor-dfun (gf type &optional classes-list new-class)
-  (with-eq-hash-table (table)
+  (let ((table (make-hash-table :test #'eq)))
     (multiple-value-bind (table all-index first second size no-class-slots-p)
         (make-accessor-table gf type table)
       (if table
@@ -958,29 +951,20 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
           (t
            (make-final-caching-dfun gf classes-list new-class)))))
 
-(defvar *accessor-miss-history* nil)
 
 (defun accessor-miss (gf new object dfun-info)
-  (let ((wrapper (wrapper-of object))
-        (previous-miss (assq gf *accessor-miss-history*)))
-    (when (eq wrapper (cdr previous-miss))
-      (error "~@<Vicious metacircle:  The computation of a ~
-              dfun of ~s for argument ~s uses the dfun being ~
-              computed.~@:>"
-             gf object))
-    (let* ((*accessor-miss-history* (acons gf wrapper *accessor-miss-history*))
-           (ostate (type-of dfun-info))
-           (otype (dfun-info-accessor-type dfun-info))
-           oindex ow0 ow1 cache
-           (args (ecase otype
-                   ((reader boundp) (list object))
-                   (writer (list new object)))))
-      (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
-        ;; The following lexical functions change the state of the
-        ;; dfun to that which is their name.  They accept arguments
-        ;; which are the parameters of the new state, and get other
-        ;; information from the lexical variables bound above.
-        (flet ((two-class (index w0 w1)
+  (let* ((ostate (type-of dfun-info))
+         (otype (dfun-info-accessor-type dfun-info))
+         oindex ow0 ow1 cache
+         (args (ecase otype
+                 ((reader boundp) (list object))
+                 (writer (list new object)))))
+    (dfun-miss (gf args wrappers invalidp nemf ntype nindex)
+      ;; The following lexical functions change the state of the
+      ;; dfun to that which is their name.  They accept arguments
+      ;; which are the parameters of the new state, and get other
+      ;; information from the lexical variables bound above.
+      (flet ((two-class (index w0 w1)
                (when (zerop (random 2 *pcl-misc-random-state*))
                  (psetf w0 w1 w1 w0))
                (dfun-update gf
@@ -1043,7 +1027,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                   (setq cache (dfun-info-cache dfun-info))
                   (if (consp nindex)
                       (caching)
-                      (do-fill #'n-n)))))))))))
+                      (do-fill #'n-n))))))))))
 
 (defun checking-miss (generic-function args dfun-info)
   (let ((oemf (dfun-info-function dfun-info))
@@ -1668,6 +1652,7 @@ Except see also BREAK-VICIOUS-METACIRCLE.  -- CSR, 2003-05-28
                     root)))
     nil))
 \f
+;;; FIXME: Needs a lock.
 (defvar *effective-method-cache* (make-hash-table :test 'eq))
 
 (defun flush-effective-method-cache (generic-function)