From 3365a34916d20ccc03cde3ce88db495a1d7f0d9d Mon Sep 17 00:00:00 2001
From: Nikodemus Siivola <nikodemus@sb-studio.net>
Date: Mon, 14 Feb 2011 00:14:41 +0200
Subject: [PATCH] working on CLOS memory leaks

 Current test case:

  (defgeneric blah (x))

  (defun test ()
    (let ((object (make-array 10000)))
      (defmethod blah ((x (eql object)))
        (format t "~A~%" x))
      (remove-method #'blah (first (sb-mop:generic-function-methods #'blah)))
      (print
       (list :specializers (hash-table-count sb-pcl::*eql-specializer-table*)
             :methods (hash-table-count sb-pcl::*eql-specializer-methods*))))
    (values))

  (loop (test))

 Current state of the tree manages to clear the methods, but not the
 specializers.

 One know leak left is in not a CLOS leak at all, but a globaldb one:

  (defun foo ()
    (let ((name (gensym)))
      (setf (fdefinition name) #'foo)
      (fmakunbound name)))

  (loop (foo))

 FMAKUNBOUND leaves the function name intact in the globaldb, even
 though it removes the definition -- and in the case of method
 functions with EQL-specializers, the name includes the object it
 is specialized on.

 ...time to look at my old globaldb patches again, I guess.
---
 src/pcl/boot.lisp      |    4 +++-
 src/pcl/defs.lisp      |    2 +-
 src/pcl/methods.lisp   |   10 +++++++++-
 src/pcl/std-class.lisp |   17 ++++++++++++-----
 4 files changed, 25 insertions(+), 8 deletions(-)

diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp
index d77709b..6674d68 100644
--- a/src/pcl/boot.lisp
+++ b/src/pcl/boot.lisp
@@ -847,7 +847,9 @@ bootstrapping.
          ;; weirdness when bootstrapping.. -- WHN 20000610
          '(ignorable))
         ((typep specializer 'eql-specializer)
-         `(type (eql ,(eql-specializer-object specializer)) ,parameter))
+         `(type ,(type-specifier
+                  (ctype-of (eql-specializer-object specializer)))
+                ,parameter))
         ((or (var-special-p parameter env) (member parameter specials))
          ;; Don't declare types for special variables -- our rebinding magic
          ;; for SETQ cases don't work right there as SET, (SETF SYMBOL-VALUE),
diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp
index f057b9f..641d377 100644
--- a/src/pcl/defs.lisp
+++ b/src/pcl/defs.lisp
@@ -572,7 +572,7 @@
   ((object :initarg :object :reader specializer-object
            :reader eql-specializer-object)))
 
-(defvar *eql-specializer-table* (make-hash-table :test 'eql))
+(defvar *eql-specializer-table* (make-hash-table :test 'eql :weakness :key-and-value))
 
 (defvar *eql-specializer-table-lock*
   (sb-thread::make-spinlock :name "EQL-specializer table lock"))
diff --git a/src/pcl/methods.lisp b/src/pcl/methods.lisp
index e9365a8..e971293 100644
--- a/src/pcl/methods.lisp
+++ b/src/pcl/methods.lisp
@@ -592,7 +592,15 @@
           (map-dependents generic-function
                           (lambda (dep)
                             (update-dependent generic-function
-                                              dep 'remove-method method)))))))
+                                              dep 'remove-method method)))
+          (let* ((mf (method-function method))
+                 (sm (when (typep mf '%method-function)
+                       (%method-function-name mf)))
+                 (fm (when (and sm (eq 'slow-method (car sm)))
+                       (fmakunbound sm)
+                       `(fast-method ,@(cdr sm)))))
+            (when fm
+              (fmakunbound fm)))))))
   generic-function)
 
 
diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp
index b1a60df..3cc6385 100644
--- a/src/pcl/std-class.lisp
+++ b/src/pcl/std-class.lisp
@@ -268,10 +268,9 @@
                               (method method))
   (let* ((object (specializer-object specializer))
          (table (specializer-method-table specializer))
-         (entry (gethash object table)))
-    (unless entry
-      (setf entry
-            (setf (gethash object table) (cons nil nil))))
+         (entry (with-locked-hash-table (table)
+                  (or (gethash object table)
+                      (setf (gethash object table) (cons nil nil))))))
     ;; We need to first smash the CDR, because a parallel read may
     ;; be in progress, and because if an interrupt catches us we
     ;; need to have a consistent state.
@@ -282,7 +281,15 @@
 (defmethod remove-direct-method ((specializer specializer-with-object)
                                  (method method))
   (let* ((object (specializer-object specializer))
-         (entry (gethash object (specializer-method-table specializer))))
+         (table (specializer-method-table specializer))
+         (entry (with-locked-hash-table (table)
+                  (let* ((entry (gethash object table))
+                         (methods (car entry)))
+                    (when (and (eq method (car methods))
+                               (null (cdr methods)))
+                      ;; Last method, nuke the entry from table.
+                      (remhash object table))
+                    entry))))
     (when entry
       ;; We need to first smash the CDR, because a parallel read may
       ;; be in progress, and because if an interrupt catches us we
-- 
1.7.1