tests/clos-add-remove-method.impure.lisp

   1 ;;;; testing add/remove-method thread thread safety
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 (defpackage "CLOS-ADD/REMOVE-METHOD"
  15   (:use "COMMON-LISP" "SB-THREAD"))
  16
  17 (in-package "CLOS-ADD/REMOVE-METHOD")
  18
  19 (defvar *tons-o-method-count* 0)
  20 ;; Test for lp#492851
  21 ;; On an x86-64 without the fix for garbage retention,
  22 ;; this would use up all memory after ~2400 iterations.
  23 ;; Now it can run forever, as far as I know.
  24 (defun make-tons-o-methods (&optional (n 50000))
  25   (dotimes (i n)
  26     (let ((object (cons "lottajunk" (make-array 20001))))
  27       ;; FIXME: the first method we defined gets its OBJECT immortalized,
  28       ;; because that's the one whose name goes in globaldb
  29       ;; as the chosen one who arbitrarily created the GF.
  30       (defmethod blah ((x (eql object))) "what?"
  31         (when (zerop (mod (incf *tons-o-method-count*) 500))
  32           (write-char #\.)
  33           (force-output))
  34         (if (zerop (mod *tons-o-method-count* 100000))
  35             (terpri)))
  36       (funcall 'blah object)) ; late bind to avoid style warning
  37     (let ((gf (symbol-function 'blah)))
  38       (remove-method gf (first (sb-mop:generic-function-methods gf))))))
  39
  40 (format t "~&;; Be patient. This test is slow.~%")
  41 (test-util:with-test (:name :exhaust-heap-with-eql-specializers)
  42   (let ((n-junk 0)
  43         (starting-eql-spec-count
  44          (hash-table-count sb-pcl::*eql-specializer-table*)))
  45     (make-tons-o-methods 50000)
  46     (sb-int:dx-flet ((visit (object type size)
  47                        (declare (ignore type size))
  48                        (when (and (typep object '(cons string (simple-vector 20001)))
  49                                   (string= (car object) "lottajunk"))
  50                          (incf n-junk))))
  51       (sb-vm::map-allocated-objects #'visit :dynamic)
  52       ;; This is probably not more than a few hundred.
  53       (format t "~&;; Post-test EQL-spec count: ~S, junk obj count: ~D~%"
  54               (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
  55       (sb-ext:gc :full t)
  56       (setq n-junk 0)
  57       (sb-vm::map-allocated-objects #'visit :dynamic)
  58       (format t "~&;; Post-GC EQL-spec count: ~S, junk obj count: ~D~%"
  59               (hash-table-count sb-pcl::*eql-specializer-table*) n-junk)
  60       ;; There should be no stray EQL-specializers left.
  61       ;; The reasoning is a bit elusive, since the first method's specializer's
  62       ;; OBJECT gets permanentized. But due to the weakness on :VALUE
  63       ;; in the specializer table, the table entry is dead even though it's
  64       ;; still possible to get an EQL-specializer for the (almost) zombie object.
  65       ;; But if you do that, you'll get a new specializer, and you can't see
  66       ;; that it wasn't the previously interned one, unless you do something
  67       ;; like extend EQL-specializer to have more slots. In that case you could
  68       ;; sense that your data went missing. But then you probably shouldn't
  69       ;; be relying on the existing interned specializer table.
  70       ;; Generic programming is not a panacea.
  71       (assert (<= (hash-table-count sb-pcl::*eql-specializer-table*)
  72                   (1+ starting-eql-spec-count))))))
  73
  74 ;;; We make a generic function, add a bunch of method for it, and
  75 ;;; prepare another bunch of method objects for later addition.
  76 ;;;
  77 ;;; Then we run several threads in parallel, removing all the old
  78 ;;; ones and adding all the new ones -- and finally we verify that
  79 ;;; the resulting method set is correct.
  80
  81 (defgeneric foo (x))
  82
  83 (defvar *to-remove-a* nil)
  84 (defvar *to-remove-b* nil)
  85 (defvar *to-remove-c* nil)
  86 (defvar *to-add-d* nil)
  87 (defvar *to-add-e* nil)
  88 (defvar *to-add-f* nil)
  89
  90 (defun name (key n)
  91   (intern (format nil "FOO-~A-~A" key n)))
  92
  93 (defun names (key)
  94   (loop for i from 0 upto 128
  95         collect (name key i)))
  96
  97 (defun to-remove (key)
  98   (loop for s in (names key)
  99         collect
 100         `(progn
 101            (defclass ,s () ())
 102            (defmethod foo ((x ,s))
 103              ',s)
 104            (push (find-method #'foo nil (list (find-class ',s)) t)
 105                  ,(intern (format nil "*TO-REMOVE-~A*" key))))))
 106
 107 (defun to-add (key)
 108   (loop for s in (names key)
 109         collect
 110         `(progn
 111            (defclass ,s () ())
 112            (push (make-instance
 113                   'standard-method
 114                   :qualifiers nil
 115                   :specializers (list (find-class ',s))
 116                   :function (lambda (args next)
 117                               (declare (ignore args next))
 118                               ',s)
 119                   :lambda-list '(x))
 120                  ,(intern (format nil "*TO-ADD-~A*" key))))))
 121
 122 (macrolet ((def ()
 123              `(progn
 124                 ,@(to-remove 'a)
 125                 ,@(to-remove 'b)
 126                 ,@(to-remove 'c)
 127                 ,@(to-add 'd)
 128                 ,@(to-add 'e)
 129                 ,@(to-add 'f))))
 130   (def))
 131
 132 (defvar *run* nil)
 133
 134 (defun remove-methods (list)
 135   (loop until *run* do (sb-thread:thread-yield))
 136   (dolist (method list)
 137     (remove-method #'foo method)))
 138
 139 (defun add-methods (list)
 140   (loop until *run* do (sb-thread:thread-yield))
 141   (dolist (method list)
 142     (add-method #'foo method)))
 143
 144 #+sb-thread
 145 (let ((threads (list (make-thread (lambda () (remove-methods *to-remove-a*)))
 146                      (make-thread (lambda () (remove-methods *to-remove-b*)))
 147                      (make-thread (lambda () (remove-methods *to-remove-c*)))
 148                      (make-thread (lambda () (add-methods *to-add-d*)))
 149                      (make-thread (lambda () (add-methods *to-add-e*)))
 150                      (make-thread (lambda () (add-methods *to-add-f*))))))
 151   (setf *run* t)
 152   (mapcar #'join-thread threads))
 153
 154 #-sb-thread
 155 (progn
 156   (setf *run* t)
 157   (remove-methods *to-remove-a*)
 158   (remove-methods *to-remove-b*)
 159   (remove-methods *to-remove-c*)
 160   (add-methods *to-add-d*)
 161   (add-methods *to-add-e*)
 162   (add-methods *to-add-f*))
 163
 164 (let ((target (append *to-add-d* *to-add-e* *to-add-f*))
 165       (real (sb-mop:generic-function-methods #'foo)))
 166   (assert (subsetp target real))
 167   (assert (subsetp real target)))